KIDS Distribution saved on Sep 19, 2011@14:05:16
Patient Merge Software Updates, Try 2
**KIDS**:JJIH PT MERGE SOFTWARE UPDATES 1.1^

**INSTALL NAME**
JJIH PT MERGE SOFTWARE UPDATES 1.1
"BLD",7536,0)
JJIH PT MERGE SOFTWARE UPDATES 1.1^^0^3110919^n
"BLD",7536,1,0)
^^22^22^3110919^
"BLD",7536,1,1,0)
Written by Sam Habiel for IntraCare Hospital on Aug 22 2011
"BLD",7536,1,2,0)
 
"BLD",7536,1,3,0)
This patch fixes 3 issues with the Patient Merge Software.
"BLD",7536,1,4,0)
 
"BLD",7536,1,5,0)
1. Merging by default interacts with the MPI. Due to various issues in 
"BLD",7536,1,6,0)
the Site Configuration, and how the MPI software works, Merge tries to 
"BLD",7536,1,7,0)
phone to Austin to tell it that a record has changed; and fails when it 
"BLD",7536,1,8,0)
can't find the logical link. I remove MPI interaction by removing the
"BLD",7536,1,9,0)
AFFECTS RECORD MERGE entry for CIRN in the Package File (9.4). This is 
"BLD",7536,1,10,0)
done in JJIHXDRP as the post-init routine.
"BLD",7536,1,11,0)
 
"BLD",7536,1,12,0)
2. Patch XT*7.3*113 takes away the ability to search the patient file 
"BLD",7536,1,13,0)
locally for duplicates, the assumption being that Austin/MPI will do 
"BLD",7536,1,14,0)
that. Well, I don't have Austin, so I am changing the routine back that 
"BLD",7536,1,15,0)
was changed by the patch to allow local checking (XDRDQUE). Since I 
"BLD",7536,1,16,0)
change a patch's work, it's a pre-requisite to running this package.
"BLD",7536,1,17,0)
In the same vein XDRDCOMP is fixed for the same reason.
"BLD",7536,1,18,0)
 
"BLD",7536,1,19,0)
3. X-ref ALK3 on the Merge Status field has a bug in it. Zach Gonzalez 
"BLD",7536,1,20,0)
and Rick Marhsall of Oroville Hospital,CA & VEN helped me fix this. I am 
"BLD",7536,1,21,0)
sending field MERGE STATUS from File 15 (Duplicate Record) to send its DD 
"BLD",7536,1,22,0)
along to fix the x-ref. The comments retain the credits to Zach and Rick.
"BLD",7536,4,0)
^9.64PA^15^1
"BLD",7536,4,15,0)
15
"BLD",7536,4,15,2,0)
^9.641^15^1
"BLD",7536,4,15,2,15,0)
DUPLICATE RECORD  (File-top level)
"BLD",7536,4,15,2,15,1,0)
^9.6411^.05^1
"BLD",7536,4,15,2,15,1,.05,0)
MERGE STATUS
"BLD",7536,4,15,222)
y^n^p^^^^n^^n
"BLD",7536,4,15,224)

"BLD",7536,4,"APDD",15,15)

"BLD",7536,4,"APDD",15,15,.05)

"BLD",7536,4,"B",15,15)

"BLD",7536,6.3)
3
"BLD",7536,"INID")
^
"BLD",7536,"INIT")
JJIHXDRP
"BLD",7536,"KRN",0)
^9.67PA^8989.52^19
"BLD",7536,"KRN",.4,0)
.4
"BLD",7536,"KRN",.401,0)
.401
"BLD",7536,"KRN",.402,0)
.402
"BLD",7536,"KRN",.403,0)
.403
"BLD",7536,"KRN",.5,0)
.5
"BLD",7536,"KRN",.84,0)
.84
"BLD",7536,"KRN",3.6,0)
3.6
"BLD",7536,"KRN",3.8,0)
3.8
"BLD",7536,"KRN",9.2,0)
9.2
"BLD",7536,"KRN",9.8,0)
9.8
"BLD",7536,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",7536,"KRN",9.8,"NM",1,0)
XDRDQUE^^0^B22454803
"BLD",7536,"KRN",9.8,"NM",2,0)
XDRDCOMP^^0^B13668482
"BLD",7536,"KRN",9.8,"NM","B","XDRDCOMP",2)

"BLD",7536,"KRN",9.8,"NM","B","XDRDQUE",1)

"BLD",7536,"KRN",19,0)
19
"BLD",7536,"KRN",19.1,0)
19.1
"BLD",7536,"KRN",101,0)
101
"BLD",7536,"KRN",409.61,0)
409.61
"BLD",7536,"KRN",771,0)
771
"BLD",7536,"KRN",870,0)
870
"BLD",7536,"KRN",8989.51,0)
8989.51
"BLD",7536,"KRN",8989.52,0)
8989.52
"BLD",7536,"KRN",8994,0)
8994
"BLD",7536,"KRN","B",.4,.4)

"BLD",7536,"KRN","B",.401,.401)

"BLD",7536,"KRN","B",.402,.402)

"BLD",7536,"KRN","B",.403,.403)

"BLD",7536,"KRN","B",.5,.5)

"BLD",7536,"KRN","B",.84,.84)

"BLD",7536,"KRN","B",3.6,3.6)

"BLD",7536,"KRN","B",3.8,3.8)

"BLD",7536,"KRN","B",9.2,9.2)

"BLD",7536,"KRN","B",9.8,9.8)

"BLD",7536,"KRN","B",19,19)

"BLD",7536,"KRN","B",19.1,19.1)

"BLD",7536,"KRN","B",101,101)

"BLD",7536,"KRN","B",409.61,409.61)

"BLD",7536,"KRN","B",771,771)

"BLD",7536,"KRN","B",870,870)

"BLD",7536,"KRN","B",8989.51,8989.51)

"BLD",7536,"KRN","B",8989.52,8989.52)

"BLD",7536,"KRN","B",8994,8994)

"BLD",7536,"QUES",0)
^9.62^^
"BLD",7536,"REQB",0)
^9.611^1^1
"BLD",7536,"REQB",1,0)
XT*7.3*113^1
"BLD",7536,"REQB","B","XT*7.3*113",1)

"FIA",15)
DUPLICATE RECORD
"FIA",15,0)
^VA(15,
"FIA",15,0,0)
15IsV
"FIA",15,0,1)
y^n^p^^^^n^^n
"FIA",15,0,10)

"FIA",15,0,11)

"FIA",15,0,"RLRO")

"FIA",15,15)
1
"FIA",15,15,.05)

"INIT")
JJIHXDRP
"MBREQ")
0
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
3
"RTN","JJIHXDRP")
0^^B1285461
"RTN","JJIHXDRP",1,0)
JJIHXDRP ; JJIH/SMH - Patient Merge Mods to get it working on WV ; 9/19/11 2:01pm
"RTN","JJIHXDRP",2,0)
 ;;;;;;Build 3
"RTN","JJIHXDRP",3,0)
EN 
"RTN","JJIHXDRP",4,0)
 ; Kill off the special merge routine for CIRN/MPI from the package file
"RTN","JJIHXDRP",5,0)
 ; We are alone on an island--no need to tell Austin about our dysfunctional
"RTN","JJIHXDRP",6,0)
 ; ICN's.
"RTN","JJIHXDRP",7,0)
 ;
"RTN","JJIHXDRP",8,0)
 ; Find CIRN IEN
"RTN","JJIHXDRP",9,0)
 N CIRNIEN S CIRNIEN=$O(^DIC(9.4,"B","CLINICAL INFO RESOURCE NETWORK",""))
"RTN","JJIHXDRP",10,0)
 I 'CIRNIEN D EN^DDIOL("No CIRN Entry found. Not making any changes to the package file.") QUIT
"RTN","JJIHXDRP",11,0)
 ;
"RTN","JJIHXDRP",12,0)
 ; Remove all entries in multiple 20 (AFFECTS RECORD MERGE)
"RTN","JJIHXDRP",13,0)
 N DA,DIK
"RTN","JJIHXDRP",14,0)
 N I S I=0 ; Counter, fileman style (start from 0 not "")
"RTN","JJIHXDRP",15,0)
 F  S I=$O(^DIC(9.4,CIRNIEN,20,I)) Q:'I  S DIK="^DIC(9.4,"_CIRNIEN_",20,",DA=I,DA(1)=CIRNIEN D ^DIK
"RTN","JJIHXDRP",16,0)
 QUIT
"RTN","XDRDCOMP")
0^2^B13668482
"RTN","XDRDCOMP",1,0)
XDRDCOMP ;SF-IRMFO/IHS/OHPRD/JCM - COMPARE TWO PATIENTS VIA DUP CHECKER ; 9/19/11 1:58pm
"RTN","XDRDCOMP",2,0)
 ;;7.3;TOOLKIT;**23,113,JJIH**;Apr 25, 1995;Build 3
"RTN","XDRDCOMP",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","XDRDCOMP",4,0)
 ;;
"RTN","XDRDCOMP",5,0)
 ; This routine will compare two records (patients), and will result with
"RTN","XDRDCOMP",6,0)
 ; a score (0 - 100%) as to how they match up.  You can not compare the
"RTN","XDRDCOMP",7,0)
 ; same record.
"RTN","XDRDCOMP",8,0)
 ;
"RTN","XDRDCOMP",9,0)
 ; *** NOTE *** As of patch XT*7.3*113, this routine is no longer
"RTN","XDRDCOMP",10,0)
 ; available for use on the PATIENT file. *****
"RTN","XDRDCOMP",11,0)
    ;
"RTN","XDRDCOMP",12,0)
    ; Local mods (JJIH/SMH - 9/19/11)
"RTN","XDRDCOMP",13,0)
    ; - Patient file selectable again - Change in START+3
"RTN","XDRDCOMP",14,0)
 ;
"RTN","XDRDCOMP",15,0)
START ;
"RTN","XDRDCOMP",16,0)
 S XDRQFLG=0
"RTN","XDRDCOMP",17,0)
 ; XT*7.3*113 - Input param to FILE^XDRDPICK makes PATIENT file unselectable.
"RTN","XDRDCOMP",18,0)
 ; S XDRFL=$$FILE^XDRDPICK(1) Q:XDRFL'>0 //smh - reverse patch 113
"RTN","XDRDCOMP",19,0)
    S XDRFL=$$FILE^XDRDPICK(0) Q:XDRFL'>0
"RTN","XDRDCOMP",20,0)
 G:XDRQFLG END
"RTN","XDRDCOMP",21,0)
 S XDRGL=^DIC(XDRFL,0,"GL")
"RTN","XDRDCOMP",22,0)
 S XDRDTYPE="BASIC" ; ADDED 4/11/96  JLI
"RTN","XDRDCOMP",23,0)
 D LKUP G:XDRQFLG END
"RTN","XDRDCOMP",24,0)
 S %ZIS="Q" D ^%ZIS G:POP END
"RTN","XDRDCOMP",25,0)
 S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL
"RTN","XDRDCOMP",26,0)
 I $D(IO("Q")) D  G:XDRQFLG END
"RTN","XDRDCOMP",27,0)
 .S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
"RTN","XDRDCOMP",28,0)
 .F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
"RTN","XDRDCOMP",29,0)
 .D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
"RTN","XDRDCOMP",30,0)
 .S XDRQFLG=1
"RTN","XDRDCOMP",31,0)
DQ ; Entry Point for Taskman
"RTN","XDRDCOMP",32,0)
 U IO W @IOF
"RTN","XDRDCOMP",33,0)
 D ^XDRDSCOR
"RTN","XDRDCOMP",34,0)
 D ^XDRDUP ;S XDRD("NOADD")="" D ^XDRDUP
"RTN","XDRDCOMP",35,0)
 D DITC
"RTN","XDRDCOMP",36,0)
 D SCORE
"RTN","XDRDCOMP",37,0)
 D ^%ZISC
"RTN","XDRDCOMP",38,0)
END D EOJ
"RTN","XDRDCOMP",39,0)
 Q
"RTN","XDRDCOMP",40,0)
 ;
"RTN","XDRDCOMP",41,0)
LKUP ;Look up both reocord.
"RTN","XDRDCOMP",42,0)
 S DIC=XDRGL,DIC(0)="QEAM"
"RTN","XDRDCOMP",43,0)
 S DIC("A")="COMPARE "_$P(^DIC(XDRFL,0),U)_": "
"RTN","XDRDCOMP",44,0)
 D ^DIC ;W !,"X: ",X,"Y: ",Y
"RTN","XDRDCOMP",45,0)
 I $D(DIRUT)!(Y=-1) K DIC,DA S XDRQFLG=1 G LKUPX
"RTN","XDRDCOMP",46,0)
 S XDRCD=+Y S DIT(1)=+Y
"RTN","XDRDCOMP",47,0)
LKUP2 S DIC("A")="    WITH "_$P(^DIC(XDRFL,0),U)_": "
"RTN","XDRDCOMP",48,0)
 D ^DIC K DIC,DA
"RTN","XDRDCOMP",49,0)
 G:$D(DIRUT)!(Y=-1) LKUP
"RTN","XDRDCOMP",50,0)
 S XDRCD2=+Y S DIT(2)=+Y
"RTN","XDRDCOMP",51,0)
 I XDRCD=XDRCD2 W *7,!!,"    CAN NOT COMPARE SAME PATIENT!!  ",!! G LKUP
"RTN","XDRDCOMP",52,0)
LKUPX Q
"RTN","XDRDCOMP",53,0)
 ;
"RTN","XDRDCOMP",54,0)
DITC ;
"RTN","XDRDCOMP",55,0)
 D SHOW^XDRDSHOW(XDRFL,XDRCD,XDRCD2)
"RTN","XDRDCOMP",56,0)
 ;S DFF=XDRFL,DIC=XDRGL,DIT(1)=XDRCD,DIT(2)=XDRCD2,DDIF=2
"RTN","XDRDCOMP",57,0)
 ;S IOP=XDRDCOMP("DEVICE")
"RTN","XDRDCOMP",58,0)
 ;D EN^DITC K DIC,DFF,DIT,IOP,DDIF
"RTN","XDRDCOMP",59,0)
 Q
"RTN","XDRDCOMP",60,0)
SCORE ;
"RTN","XDRDCOMP",61,0)
 S:XDRDSCOR("MAX")>0 XDRD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
"RTN","XDRDCOMP",62,0)
 S:XDRDSCOR("MAX")=0 XDRD("DUPSCORE%")=0
"RTN","XDRDCOMP",63,0)
 S XDRD("DUPSCORE%")=$J(XDRD("DUPSCORE%"),1,2)
"RTN","XDRDCOMP",64,0)
 S XDRD("DUPSCORE%")=$S(XDRD("DUPSCORE%")<0:0,XDRD("DUPSCORE%")<1:$E(XDRD("DUPSCORE%"),3,4),1:100)
"RTN","XDRDCOMP",65,0)
 ;S IOP=XDRDCOMP("DEVICE") D ^%ZIS U IO
"RTN","XDRDCOMP",66,0)
 W !! F I=0:0 S I=$O(XDRDUP("TEST SCORE",I)) Q:I'>0  I +XDRDUP("TEST SCORE",I)'=0 S J=XDRDTEST(I) W !,$P(J,U),?25,"VALUE = ",$J(XDRDUP("TEST SCORE",I),3,0),"   MAX POSSIBLE = ",$J($P(J,U,6),3,0)
"RTN","XDRDCOMP",67,0)
 W !!,?40,"DUPLICATE THRESHOLD % ",XDRDSCOR("PDT%")
"RTN","XDRDCOMP",68,0)
 W !,?40,"DUPLICATE SCORE % ",$G(XDRD("DUPSCORE%")),!
"RTN","XDRDCOMP",69,0)
 K %,XDRDCNT
"RTN","XDRDCOMP",70,0)
 I '$D(ZTQUEUED),$E(IOST,1,2)'="P-" S DIR(0)="E" D ^DIR K DIR S:X=U XDRQFLG=1
"RTN","XDRDCOMP",71,0)
 ;D ^%ZISC
"RTN","XDRDCOMP",72,0)
 Q
"RTN","XDRDCOMP",73,0)
QUEUE ;** Remove after testing **
"RTN","XDRDCOMP",74,0)
 I '$D(IOP),'$D(XDRDCOMP("DEVICE")) S %ZIS="QMN" D ^%ZIS
"RTN","XDRDCOMP",75,0)
 I POP S XDRQFLG=1 G QUEUEX
"RTN","XDRDCOMP",76,0)
 I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you can't queue to your screen or a slave device.",! K IO("Q") G QUEUE
"RTN","XDRDCOMP",77,0)
 S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL K %ZIS
"RTN","XDRDCOMP",78,0)
 I '$D(IO("Q")) G QUEUEX
"RTN","XDRDCOMP",79,0)
 S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
"RTN","XDRDCOMP",80,0)
 F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
"RTN","XDRDCOMP",81,0)
 K %
"RTN","XDRDCOMP",82,0)
 ;S XYY=AAA ***************************
"RTN","XDRDCOMP",83,0)
 D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
"RTN","XDRDCOMP",84,0)
 S XDRQFLG=1
"RTN","XDRDCOMP",85,0)
 K ZTSK
"RTN","XDRDCOMP",86,0)
QUEUEX Q
"RTN","XDRDCOMP",87,0)
 ;
"RTN","XDRDCOMP",88,0)
EOJ ;
"RTN","XDRDCOMP",89,0)
 K XDRDCOMP,XDRDUP,XDRD,XDRFL,XDRGL,XDRQFLG,XDRDTEST,XDRDSCOR
"RTN","XDRDCOMP",90,0)
 K XDRCD,XDRCD2,%IS,POP,IO("C"),IOP,IO("Q"),X,Y,ZTSK
"RTN","XDRDCOMP",91,0)
 S:$D(ZTQUEUED) ZTREQ="@"
"RTN","XDRDCOMP",92,0)
 Q
"RTN","XDRDQUE")
0^1^B22454803
"RTN","XDRDQUE",1,0)
XDRDQUE ;SF-IRMFO/IHS/OHPRD/JCM - START AND STOP DUPLICATE CHECKER SEARCH ; 8/24/11 1:45pm
"RTN","XDRDQUE",2,0)
 ;;7.3;TOOLKIT;**23,47,113,JJIH(LOCAL)**;Apr 25, 1995;Build 3
"RTN","XDRDQUE",3,0)
    ;
"RTN","XDRDQUE",4,0)
 ; JJIH/SMH - August 24th 2011
"RTN","XDRDQUE",5,0)
    ; Restored the ability for sites to locally search the pateint
"RTN","XDRDQUE",6,0)
    ; file for duplicates. This ability was taken away in patch 113.
"RTN","XDRDQUE",7,0)
    ; See comment below //smh for changed line.
"RTN","XDRDQUE",8,0)
 ;
"RTN","XDRDQUE",9,0)
START ;
"RTN","XDRDQUE",10,0)
 S XDRQFLG=0
"RTN","XDRDQUE",11,0)
 ;*** following commented line to be removed from Toolkit ver after 7.3
"RTN","XDRDQUE",12,0)
 ;S XDRDQUE("TASKMAN STATUS")=$P(@$Q(^%ZTSCH("STATUS","")),U,2) I XDRDQUE("TASKMAN STATUS")'="RUN" W !!,"Taskman does not seem to be running properly, Please notify your site manager.",!! G END
"RTN","XDRDQUE",13,0)
 S XDRDQUE("TASKMAN STATUS")=$$TM^%ZTLOAD
"RTN","XDRDQUE",14,0)
 I 'XDRDQUE("TASKMAN STATUS") W !!,"Taskman does not seem to be running properly, Please notify your site manager.",!! G END
"RTN","XDRDQUE",15,0)
 ; XT*7.3*113, variable XDRNOPT=1 makes option unavailable for the PATIENT file
"RTN","XDRDQUE",16,0)
    ; JJIH//smh - Comment line below to undo change in *113
"RTN","XDRDQUE",17,0)
 ; N XDRNOPT S XDRNOPT=1 //smh
"RTN","XDRDQUE",18,0)
 D FILE G:XDRQFLG END ; Asks user which file to check for dups
"RTN","XDRDQUE",19,0)
 D CHECK^XDRU1 G:XDRQFLG END ; Checks the Duplicate Resolution file
"RTN","XDRDQUE",20,0)
 D ASK G:XDRQFLG END ; Asks user what action and type of search
"RTN","XDRDQUE",21,0)
 D QUEUE G:XDRQFLG END ; Queues search
"RTN","XDRDQUE",22,0)
 I XDRDNSTA="r" D ASK3 D:'XDRQFLG QUEUE
"RTN","XDRDQUE",23,0)
END D EOJ ; Clean up variables
"RTN","XDRDQUE",24,0)
 Q
"RTN","XDRDQUE",25,0)
 ;
"RTN","XDRDQUE",26,0)
FILE ; EP - Called by XDRDCOMP,XDRDLIST,XDRDSCOR,XDRMADD,XDRCNT
"RTN","XDRDQUE",27,0)
 K DIC("B")
"RTN","XDRDQUE",28,0)
 K X S:$D(XDRFL) X=XDRFL
"RTN","XDRDQUE",29,0)
 S DIC(0)=$S($D(X):"Z",1:"QEAZ")
"RTN","XDRDQUE",30,0)
 S:'$D(DIC("A")) DIC("A")="Select file to be checked for duplicates: "
"RTN","XDRDQUE",31,0)
 ; If XDRNOPT=1, don't allow selection of PATIENT file.(new with XT*7.3*113)
"RTN","XDRDQUE",32,0)
 I $G(XDRNOPT)=1 D
"RTN","XDRDQUE",33,0)
 . S DIC("S")="I Y'=2"
"RTN","XDRDQUE",34,0)
 . W:'$D(ZTQUEUED) !,"* This option is not available for PATIENTS"
"RTN","XDRDQUE",35,0)
 . Q
"RTN","XDRDQUE",36,0)
 S DIC="^VA(15.1," D ^DIC K DIC,X
"RTN","XDRDQUE",37,0)
 I Y=-1 S XDRQFLG=1 G FILEX
"RTN","XDRDQUE",38,0)
 S XDRD(0)=Y(0),XDRD(0,0)=Y(0,0),XDRFL=$P(Y(0),U),PRIFILE=XDRFL K Y
"RTN","XDRDQUE",39,0)
 W:'$D(ZTQUEUED) !!
"RTN","XDRDQUE",40,0)
FILEX Q
"RTN","XDRDQUE",41,0)
 ;
"RTN","XDRDQUE",42,0)
ASK ;
"RTN","XDRDQUE",43,0)
 D DISP
"RTN","XDRDQUE",44,0)
 D ASK1 G:XDRQFLG ASKX
"RTN","XDRDQUE",45,0)
 I XDRDSTA="c"&($D(^VA(15.1,XDRFL,"APDTI"))) S XDRDPDTI="" W !!,"Since the Potential Duplicate Threshold has been raised",!,"I will only go through the Potential Duplicates and see if they",!,"meet the new threshold." G ASKX
"RTN","XDRDQUE",46,0)
 D:XDRDSTA="c"&('XDRQFLG) ASK2
"RTN","XDRDQUE",47,0)
ASKX ;
"RTN","XDRDQUE",48,0)
 Q
"RTN","XDRDQUE",49,0)
DISP ;
"RTN","XDRDQUE",50,0)
 D DISP^XDRDSTAT
"RTN","XDRDQUE",51,0)
 S XDRDSTA=$P(XDRD(0),U,2)
"RTN","XDRDQUE",52,0)
 S XDRDTYPE=$P(XDRD(0),U,5)
"RTN","XDRDQUE",53,0)
 Q
"RTN","XDRDQUE",54,0)
ASK1 ;
"RTN","XDRDQUE",55,0)
 S:XDRDSTA']"" XDRDSTA="c"
"RTN","XDRDQUE",56,0)
 S DIR(0)="Y",DIR("A")="Do You wish to "_$S(XDRDSTA="h":"CONTINUE",XDRDSTA="e":"CONTINUE",XDRDSTA="r":"HALT",1:"RUN")_" "_$S(XDRDSTA="r":"this",XDRDSTA="h":"this",XDRDSTA="e":"this",1:"a")_" search (Y/N)"
"RTN","XDRDQUE",57,0)
 D ^DIR K DIR D OUT
"RTN","XDRDQUE",58,0)
 I 'XDRQFLG,'Y,$S(XDRDSTA="r":0,XDRDSTA="c":0,1:1) D  S Y=0
"RTN","XDRDQUE",59,0)
 . S DIR(0)="Y",DIR("A")="Do you wish to mark this run COMPLETED (Y/N)",DIR("B")="NO" D ^DIR K DIR D OUT
"RTN","XDRDQUE",60,0)
 . I Y,'XDRQFLG S DIE="^VA(15.1,",DA=XDRFL,DR=".02////c" D ^DIE K DA,DIE,DR
"RTN","XDRDQUE",61,0)
 S:'Y XDRQFLG=1
"RTN","XDRDQUE",62,0)
 K XDRDNSTA
"RTN","XDRDQUE",63,0)
 S:'XDRQFLG XDRDNSTA=$S(XDRDSTA="h":"r",XDRDSTA="r":"h",1:"r")
"RTN","XDRDQUE",64,0)
 Q
"RTN","XDRDQUE",65,0)
ASK2 ;
"RTN","XDRDQUE",66,0)
 K XDRDTYPE
"RTN","XDRDQUE",67,0)
 S DIR(0)="15.1,.05A",DIR("A")="Which type of Search do you wish to run ? (BASIC/NEW) "
"RTN","XDRDQUE",68,0)
 S DIR("B")="BASIC",DIR("?")="A 'BASIC' search starts at the beginning of the file.  A 'NEW' search uses a cross-reference you specify to determine which entries to test."
"RTN","XDRDQUE",69,0)
 D ^DIR K DIR D OUT
"RTN","XDRDQUE",70,0)
 S XDRDTYPE=$S(Y="b":"BASIC",1:"NEW")
"RTN","XDRDQUE",71,0)
 I XDRDTYPE="BASIC" D
"RTN","XDRDQUE",72,0)
 . N DIR S DIR(0)="Y"
"RTN","XDRDQUE",73,0)
 . S DIR("A",1)="This process will take a **LONG** time (known to exceed 100  hours),"
"RTN","XDRDQUE",74,0)
 . S DIR("A",2)="but you CAN stop and restart the process when you want using"
"RTN","XDRDQUE",75,0)
 . S DIR("A")="the options  OK"
"RTN","XDRDQUE",76,0)
 . D ^DIR S:Y'>0 XDRQFLG=1
"RTN","XDRDQUE",77,0)
 . Q
"RTN","XDRDQUE",78,0)
 Q
"RTN","XDRDQUE",79,0)
 ;
"RTN","XDRDQUE",80,0)
ASK3 ;
"RTN","XDRDQUE",81,0)
 W !
"RTN","XDRDQUE",82,0)
 S DIR(0)="Y",DIR("A")="Do You wish to schedule a time to HALT this search (Y/N)"
"RTN","XDRDQUE",83,0)
 D ^DIR K DIR D OUT
"RTN","XDRDQUE",84,0)
 S:'Y XDRQFLG=1
"RTN","XDRDQUE",85,0)
 G:XDRQFLG ASK3X
"RTN","XDRDQUE",86,0)
 S XDRDNSTA="h"
"RTN","XDRDQUE",87,0)
ASK3X Q
"RTN","XDRDQUE",88,0)
 ;
"RTN","XDRDQUE",89,0)
QUEUE ;
"RTN","XDRDQUE",90,0)
 S ZTRTN="XDRDMAIN",ZTIO="",ZTDESC="Duplicate "_XDRD(0,0)_" Search"
"RTN","XDRDQUE",91,0)
 S:XDRDNSTA="h" ZTDESC="Halt "_ZTDESC
"RTN","XDRDQUE",92,0)
 S ZTSAVE("XDRFL")="" S:$D(XDRDPDTI) ZTSAVE("XDRDPDTI")=""
"RTN","XDRDQUE",93,0)
 S ZTSAVE("XDRDTYPE")="",ZTSAVE("XDRDNSTA")=""
"RTN","XDRDQUE",94,0)
 D ^%ZTLOAD
"RTN","XDRDQUE",95,0)
 S:'$D(ZTQUEUED) XDRQFLG=1
"RTN","XDRDQUE",96,0)
 K ZTSK
"RTN","XDRDQUE",97,0)
QUEUEX Q
"RTN","XDRDQUE",98,0)
 ;
"RTN","XDRDQUE",99,0)
OUT ;
"RTN","XDRDQUE",100,0)
 ; Common point to take care of DIR,DIC, and DIE calls
"RTN","XDRDQUE",101,0)
 I ($D(DTOUT))!($D(DUOUT))!($D(DIRUT)) K DTOUT,DUOUT,DIRUT S XDRQFLG=1
"RTN","XDRDQUE",102,0)
 Q
"RTN","XDRDQUE",103,0)
EOJ ;
"RTN","XDRDQUE",104,0)
 K X,Y,XDRFL,XDRDNSTA,XDRDSTA,XDRQFLG,XDRD,XDRDPDTI,XDRDQUE
"RTN","XDRDQUE",105,0)
 Q
"VER")
8.0^22.0
"^DD",15,15,.05,0)
MERGE STATUS^*S^0:NOT READY;1:READY;2:MERGED;3:IN PROGRESS;^0;5^Q
"^DD",15,15,.05,1,0)
^.1^^-1
"^DD",15,15,.05,1,1,0)
15^AFR^MUMPS
"^DD",15,15,.05,1,1,1)
Q:X'=2  S X=$P(^VA(15,DA,0),U,1,2),%=+$P(^(0),U,4),^VA(15,"AFR",$P($P(X,";",2),U,1),+$P(X,U,%),DA)=""
"^DD",15,15,.05,1,1,2)
Q:X'=2  S X=$P(^VA(15,DA,0),U,1,2) K ^VA(15,"AFR",$P($P(X,";",2),U,1),+$P(X,U,1),DA),^VA(15,"AFR",$P($P(X,";",2),U,1),+$P(X,U,2),DA)
"^DD",15,15,.05,1,1,"%D",0)
^^12^12^2900607^^^
"^DD",15,15,.05,1,1,"%D",1,0)
This xref is permanent and exists for all merged entries.  It indicates
"^DD",15,15,.05,1,1,"%D",2,0)
which file entry was the 'from' entry.  It is used by the INPUT TRANSFORMS
"^DD",15,15,.05,1,1,"%D",3,0)
on the .01 and .02 fields to prevent entering a file entry that has
"^DD",15,15,.05,1,1,"%D",4,0)
already been merged away.
"^DD",15,15,.05,1,1,"%D",5,0)

"^DD",15,15,.05,1,1,"%D",6,0)
The form of this xref, using file 2 as an example, is:
"^DD",15,15,.05,1,1,"%D",7,0)

"^DD",15,15,.05,1,1,"%D",8,0)
^VA(15,"AFR","DPT(",fe#,DA)=""  where fe# is the 'from' file entry.
"^DD",15,15,.05,1,1,"%D",9,0)

"^DD",15,15,.05,1,1,"%D",10,0)
Note that the kill side of this xref kills all possible combinations
"^DD",15,15,.05,1,1,"%D",11,0)
because deleting an entry in this file using ^DIK results in the MERGE
"^DD",15,15,.05,1,1,"%D",12,0)
DIRECTION field being NULL when this xref is fired.
"^DD",15,15,.05,1,2,0)
15^ATO^MUMPS
"^DD",15,15,.05,1,2,1)
Q:X'=2  S X=$P(^VA(15,DA,0),U,1,2),%=+$P(^(0),U,4)#2+1,^VA(15,"ATO",$P($P(X,";",2),U,1),+$P(X,U,%),DA)=""
"^DD",15,15,.05,1,2,2)
Q:X'=2  S X=$P(^VA(15,DA,0),U,1,2) K ^VA(15,"ATO",$P($P(X,";",2),U,1),+$P(X,U,1),DA),^VA(15,"ATO",$P($P(X,";",2),U,1),+$P(X,U,2),DA)
"^DD",15,15,.05,1,2,"%D",0)
^^11^11^2900607^
"^DD",15,15,.05,1,2,"%D",1,0)
This xref is permanent and exists for all merged entires.  It indicates
"^DD",15,15,.05,1,2,"%D",2,0)
which file entry was the 'to' entry.  It is currently not used by the
"^DD",15,15,.05,1,2,"%D",3,0)
dictionary.
"^DD",15,15,.05,1,2,"%D",4,0)

"^DD",15,15,.05,1,2,"%D",5,0)
The form of this xref, using file 2 as an example, is:
"^DD",15,15,.05,1,2,"%D",6,0)

"^DD",15,15,.05,1,2,"%D",7,0)
^VA(15,"ATO","DPT(",fe#,DA)="" where fe# is the 'to' file entry.
"^DD",15,15,.05,1,2,"%D",8,0)

"^DD",15,15,.05,1,2,"%D",9,0)
Note that the kill side of this xref kills all possible combinations
"^DD",15,15,.05,1,2,"%D",10,0)
because deleting an entry in this file using ^DIK results in the MERGE
"^DD",15,15,.05,1,2,"%D",11,0)
DIRECTION field being NULL when this xref is fired.
"^DD",15,15,.05,1,3,0)
15^AMRG^MUMPS
"^DD",15,15,.05,1,3,1)
Q:X=2  S %=$P($P(^VA(15,DA,0),U,1),";",2),^VA(15,"AMRG",%,X,DA)=""
"^DD",15,15,.05,1,3,2)
S %=$P($P(^VA(15,DA,0),U,1),";",2) K ^VA(15,"AMRG",%,X,DA)
"^DD",15,15,.05,1,3,"%D",0)
^^9^9^2900607^
"^DD",15,15,.05,1,3,"%D",1,0)
This xref is short lived and exists only for entries that are verified
"^DD",15,15,.05,1,3,"%D",2,0)
duplicates that have not yet been merged.
"^DD",15,15,.05,1,3,"%D",3,0)

"^DD",15,15,.05,1,3,"%D",4,0)
The form of this xref, using file 2 as an example, is:
"^DD",15,15,.05,1,3,"%D",5,0)

"^DD",15,15,.05,1,3,"%D",6,0)
^VA(15,"AMRG","DPT(",n,DA)="" where 'n' will be 0 for a MERGE STATUS of
"^DD",15,15,.05,1,3,"%D",7,0)
                              NOT READY and a 1 for READY.
"^DD",15,15,.05,1,3,"%D",8,0)

"^DD",15,15,.05,1,3,"%D",9,0)
Once merged the "AMRG" xref for this entry will be killed.
"^DD",15,15,.05,1,4,0)
15^ALK3^MUMPS
"^DD",15,15,.05,1,4,1)
Q:X'=2  S X=$P(^VA(15,DA,0),U,1,2) K ^VA(15,"ALK",$P($P(X,";",2),U,1),+$P(X,U),2,+$P(X,U,2),DA) K ^VA(15,"ALK",$P($P(X,";",2),U,1),+$P(X,U,2),2,+$P(X,U),DA)
"^DD",15,15,.05,1,4,2)
Q
"^DD",15,15,.05,1,4,"%D",0)
^^14^14^3110821^
"^DD",15,15,.05,1,4,"%D",1,0)
This xref kills the "ALK" xref for this entry.  See the "ALK" xref on the
"^DD",15,15,.05,1,4,"%D",2,0)
STATUS field for more info.
"^DD",15,15,.05,1,4,"%D",3,0)
 
"^DD",15,15,.05,1,4,"%D",4,0)
**LOCAL MOD** JJOH/ZAG&VEN/TOAD 2009 10:26 
"^DD",15,15,.05,1,4,"%D",5,0)
A bug in how the ALK, ALK2, and ALK3 xrefs maintain the ALK index can
"^DD",15,15,.05,1,4,"%D",6,0)
result in index entries erroneously being left behind after a merge is
"^DD",15,15,.05,1,4,"%D",7,0)
complete, which causes the patient lookup to erroneously report the record
"^DD",15,15,.05,1,4,"%D",8,0)
is still a potential duplicate. We fixed this problem by extending the
"^DD",15,15,.05,1,4,"%D",9,0)
kill logic here to always kill both possible index entries (record 2 then
"^DD",15,15,.05,1,4,"%D",10,0)
record 1, and also record 1 then record 2). Eventually, all three of these
"^DD",15,15,.05,1,4,"%D",11,0)
old-style xrefs should be replaced with one or two new-style compound
"^DD",15,15,.05,1,4,"%D",12,0)
indexes to simplify and bulletproof this algorithm. This change was made
"^DD",15,15,.05,1,4,"%D",13,0)
in Oroville Hospital's Live VISTA environment after experimenting with
"^DD",15,15,.05,1,4,"%D",14,0)
Duplicate Patient Merge.
"^DD",15,15,.05,1,4,"DT")
3110821
"^DD",15,15,.05,1,5,0)
^^TRIGGER^15^.08
"^DD",15,15,.05,1,5,1)
X ^DD(15,.05,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^VA(15,D0,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(15,.05,1,5,1.4)
"^DD",15,15,.05,1,5,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$S($D(^DD(15,.05,0)):$P(^(0),U,3),1:"") S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="MERGED" S:X X=$D(DIU(0))=0
"^DD",15,15,.05,1,5,1.4)
S DIH=$S($D(^VA(15,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,8)=DIV,DIH=15,DIG=.08 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",15,15,.05,1,5,2)
Q
"^DD",15,15,.05,1,5,"%D",0)
^^5^5^2900613^^
"^DD",15,15,.05,1,5,"%D",1,0)
This TRIGGER sets the DATE RESOLVED field when the merge status is set
"^DD",15,15,.05,1,5,"%D",2,0)
to 'merged'.
"^DD",15,15,.05,1,5,"%D",3,0)

"^DD",15,15,.05,1,5,"%D",4,0)
The conditional logic on this TRIGGER was modified, using ^%GEDIT, to
"^DD",15,15,.05,1,5,"%D",5,0)
prevent firing during a RE-INDEX.
"^DD",15,15,.05,1,5,"CREATE CONDITION")
MERGE STATUS="MERGED"
"^DD",15,15,.05,1,5,"CREATE VALUE")
TODAY
"^DD",15,15,.05,1,5,"DELETE VALUE")
NO EFFECT
"^DD",15,15,.05,1,5,"FIELD")
DATE RESOLVED
"^DD",15,15,.05,1,6,0)
15^ADJ^MUMPS
"^DD",15,15,.05,1,6,1)
Q:X'=2  S X="XDRDADJ" X ^%ZOSF("TEST") D:$T ^XDRDADJ
"^DD",15,15,.05,1,6,2)
Q
"^DD",15,15,.05,1,6,"%D",0)
^^8^8^2900830^^^^
"^DD",15,15,.05,1,6,"%D",1,0)
This xref is fired only when an entry has been merged.  The routine ^XDRDADJ
"^DD",15,15,.05,1,6,"%D",2,0)
then looks at the file to determine if any other file entry pairs need to
"^DD",15,15,.05,1,6,"%D",3,0)
be adjusted.  For example, using file 2, if patient 5 was merged to patient
"^DD",15,15,.05,1,6,"%D",4,0)
10, and there was a potential duplicate entry for patient 5 and patient 15,
"^DD",15,15,.05,1,6,"%D",5,0)
that entry would be changed to patient 10 and patient 15.
"^DD",15,15,.05,1,6,"%D",6,0)

"^DD",15,15,.05,1,6,"%D",7,0)
There are other possible situations that are far more complex than the
"^DD",15,15,.05,1,6,"%D",8,0)
above example.
"^DD",15,15,.05,1,6,"DT")
2900830
"^DD",15,15,.05,3)
This field indicates the status of verified duplicate entries with respect to merging.
"^DD",15,15,.05,5,1,0)
15.01101^.02^2
"^DD",15,15,.05,5,2,0)
15^.03^8
"^DD",15,15,.05,12)
Must be verified duplicate and once merged cannot be modified
"^DD",15,15,.05,12.1)
S DIC("S")="I $P(^VA(15,DA,0),U,3)=""V"",$P(^(0),U,5)'=2"
"^DD",15,15,.05,21,0)
^^8^8^2890725^^^^
"^DD",15,15,.05,21,1,0)
This field is set when a duplicate record pair is verified as a duplicate.
"^DD",15,15,.05,21,2,0)
The actual merge will not occur until this field is set to READY (1).  The
"^DD",15,15,.05,21,3,0)
merge routine will set this field to MERGED (2).  Once set to MERGED (2)
"^DD",15,15,.05,21,4,0)
this field cannot be modified.
"^DD",15,15,.05,21,5,0)

"^DD",15,15,.05,21,6,0)
Note:  Kill side of "AFR" and "ATO" xref kill all possible combinations of
"^DD",15,15,.05,21,7,0)
       xref because deleting an entry in this file using ^DIK results in
"^DD",15,15,.05,21,8,0)
       the .04 field being NULL when these xrefs are fired.
"^DD",15,15,.05,23,0)
^^8^8^2900830^^^^
"^DD",15,15,.05,23,1,0)
This field is set when a duplicate record pair is verified as a duplicate.
"^DD",15,15,.05,23,2,0)
The actual merge will not occur until this field is set to READY (1).  The
"^DD",15,15,.05,23,3,0)
merge routine will set this field to MERGED (2).  Once set to MERGED (2)
"^DD",15,15,.05,23,4,0)
this field cannot be modified.
"^DD",15,15,.05,23,5,0)

"^DD",15,15,.05,23,6,0)
Note:  Kill side of "AFR" and "ATO" xref kill all possible combinations of
"^DD",15,15,.05,23,7,0)
       xref because deleting an entry in this file using ^DIK results in
"^DD",15,15,.05,23,8,0)
       the .04 field being NULL when these xrefs are fired.
"^DD",15,15,.05,"DEL",.05,0)
I 1
"^DD",15,15,.05,"DT")
3110821
**END**
**END**