BPMXDRV ;IHS/PHXAO/AEF - PATIENT MERGE SPECIAL ROUTINES DRIVER - 6/26/12 ;
;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office
; changed namespace from BZXM to BPM
; changed names of speical merge routines
; added check for REPOINT DELETED VISITS parameter
;IHS/DIT/ENM 08/20/10 EDR MODS ADDED BELOW
;IHS/OIT/NKD 6/13/2012 Restricted merge batches to 1 pair of duplicates
; Moved EDR and MPI processing into separate routines
; Moved processing checks into BPMXVST and BPMXLR
;;
DESC ;;----- ROUTINE DESCRIPTION
;;
;;BPMXDRV:
;;THIS ROUTINE CALLS OTHER SPECIAL IHS MERGE ROUTINES USED TO MERGE
;;DUPLICATE PATIENT DATA.
;;
;;THIS ROUTINE IS ENTERED INTO THE 'NAME OF MERGE ROUTINE' FIELD OF THE
;;'AFFECTS RECORD MERGE' SUBFILE OF THE PACKAGE FILE FOR THE 'IHS
;;PATIENT MERGE' PACKAGE. THIS ROUTINE IS THEN RUN BY THE KERNEL
;;TOOLKIT DUPLICATE PATIENT MERGE SOFTWARE. THIS ROUTINE ELIMINATES
;;THE NEED TO HAVE EACH INDIVIDUAL MERGE ROUTINE ENTERED INTO EACH
;;INDIVIDUAL ENTRY IN THE PACKAGE FILE.
;;
;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT MERGE
;;SOFTWARE:
;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
;;EXAMPLE:
;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
;;WHERE =2 IS THE PARENT FILE (VA PATIENT FILE).
;;
;;$$END
;
N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END" D EN^DDIOL(X)
Q
EN(BPMRY) ;EP
;----- MAIN ENTRY POINT FROM DUPLICATE PATIENT MERGE SOFTWARE
;
; BPMRY = TEMP GLOBAL ARRAY SET UP BY THE PATIENT MERGE
; SOFTWARE, I.E., "^TMP(""XDRFROM"",$J)"
;
; Run iCare special merge; if FROM patient being edited, it stops
I $L($T(CHK^BQIPTMRG)) D I $D(ZTSTOP) Q
. NEW FR S FR=$O(@BPMRY@(0)) Q:'FR
. I '$$CHK^BQIPTMRG(FR) S ZTSTOP=1 Q
. D EN^BQIPTMRG(BPMRY)
;
; Flag all visits for export for FROM patients
D VISITS^BPMMRG(BPMRY)
;
;REPOINT VARIABLE POINTER FIELDS
D EN^BPMXVP(BPMRY)
;
;REPOINT PT TAXONOMY FILE POINTERS
D EN^BPMXTAX(BPMRY)
;
;REPOINT 3P CLAIM AND BILL PATIENTS
D EN^BPMX3PB(BPMRY)
;
;REPOINT VISIT FILE POINTERS if REPOINT DELETED VISITS parameter turned ON
;IHS/OIT/NKD BPM*1.0*2 MOVED PROCESSING CHECK INTO BPMXVST ROUTINE
;I $$GET1^DIQ(15.1,2,99999.01)="YES" D EN^BPMXVST(BPMRY)
D EN^BPMXVST(BPMRY)
;
;MERGE WORD PROCESSING FIELDS
D EN^BPMXWP(BPMRY)
;
;MERGE LAB DATA (calls ^BLRMERG)
;IHS/OIT/NKD BPM*1.0*2 MOVED PROCESSING CHECK INTO BPMXLR ROUTINE
;I $L($T(EN^BLRMERG)) D EN^BPMXLR(BPMRY)
D EN^BPMXLR(BPMRY)
;
;MERGE PROBLEM LIST
D EN^BPMXPRB(BPMRY)
;
;IHS/OIT/NKD BPM*1.0*2 CALL NEW MPI/EDR ROUTINES - START OLD CODE
;IHS/DIT/ENM 02/23/10
;MERGE MPI DATA (Calls ^AGMPIHLO
;S X="AGMPIHLO" X ^%ZOSF("TEST") I $T D NEWMSG^AGMPIHLO(BPMRY)
;
;IHS/DIT/ENM 08/20/10 next 7 lines sent by FJ for the EDR project
;Added for support of GENERIC merge trigger to subscribing applications fje 8/13/10
;S X="BADEMRG" X ^%ZOSF("TEST") I $T D THIS LINE IS NOT NEEDED
;S BPMFR=$O(@BPMRY@(0))
;Q:'BPMFR
;S BPMTO=$O(@BPMRY@(BPMFR,0))
;Q:'BPMTO
;S X="BPM MERGE PATIENT ADT-A40",DIC=101,DFNFROM=+BPMFR,DFNTO=+BPMTO
;D EN^XQOR
;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
;SEND MPI MESSAGE
D EN^BPMXMPI(BPMRY)
;SEND EDR MESSAGE
D EN^BPMXEDR(BPMRY)
;IHS/OIT/NKD BPM*1.0*2 END NEW CODE
Q
QUE ;EP
;IHS/OIT/NKD BPM*1.0*2 New entry point from menu [BPM MERGE READY DUPLICATES]
;This is the entry point for queueing a merge process, modified for single pair batching
;Code functionality copied from QUE^XDRMERG0 and QUE^XDRMERGB
;Use of GOTO statement at end to continue processing in XDR routines
;
D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary
;
N XDRXX,XDRYY,XDRMA,DIE,DIC,DIR,DR,ZTDTH,ZTSK
N XDRX,XDRY,XDRFIL,XDRGLOB,X,Y,XDRNAME
N XDRFDA,XDRIENS,XDRI,XDRJ,XDRK,DA,DIK
;
S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0
I XDRFIL=2 D Q:Y
. N X,XDRKEY
. S (X,XDRKEY)=0 F S X=$O(^VA(200,DUZ,51,"B",X)) Q:X'>0!(XDRKEY) D
. . I $$GET1^DIQ(19.1,X,.01)="DG ELIGIBILITY" S XDRKEY=1
. . Q
. S Y=0 I 'XDRKEY W !!,"You should hold the 'DG ELIGIBILITY' key to run a patient file merge." S Y=1
. Q
S XDRDIC=^DIC(XDRFIL,0,"GL")
S XDRGLOB=$E(XDRDIC,2,999)
S X=""
S XNCNT=0,XNCNT0=0
F S X=$O(^VA(15,"AVDUP",XDRGLOB,X)) Q:X="" S Y=$O(^(X,0)) D
. N YVAL S YVAL=^VA(15,Y,0)
. I $P(YVAL,U,20)>0 Q ; ALREADY DONE OR SCHEDULED
. I $P(YVAL,U,3)'="V" Q ; TAKE ONLY VERIFIED
. I $P(YVAL,U,5)'=1 Q ; TAKE ONLY IF MARKED READY TO MERGE
. I $P(YVAL,U,13)>0 D
. . I '$D(@(XDRDIC_(+YVAL)_",0)"))!'$D(@(XDRDIC_(+$P(YVAL,U,2))_",0)")) Q
. . I $P(YVAL,U,4)'=2 S XDRX(+YVAL,+$P(YVAL,U,2))=Y ; get ien numbers from duplicate file
. . E S XDRX(+$P(YVAL,U,2),+YVAL)=Y ; Reverse - merge to switched
. . S XNCNT=XNCNT+1
W !!,XNCNT," Entries Ready to be included in merge"
I $O(XDRX(0))'>0 D Q
. W !!?15,$C(7),"No Verified Duplicates included in merge",$C(7),!!
;
;IHS/OIT/NKD BPM*1.0*2 BEGIN NEW CODE - Restrict batch to one pair of duplicates
D BATCH(.XDRX)
I '$D(XDRX) W !,"None selected!" Q
;IHS/OIT/NKD BPM*1.0*2 END NEW CODE
;
K DIR S DIR(0)="Y"
S DIR("A",1)="This process will take a **LONG** time (usually over 15 hours, and sometimes"
S DIR("A",2)="considerably longer), but you CAN stop and restart the process when you"
S DIR("A")="want using the options. OK"
D ^DIR K DIR Q:Y'>0
G NAME^XDRMERGB
;
Q
;
BATCH(XDRX) ;
;IHS/OIT/NKD BPM*1.0*2 Restrict batch to one pair of duplicates
; Displays all pairs ready to be merged, and allows the selection of ONE to be batched
N XNCNT,I,J,XDRY,X01,X1,X1S,X02,X2,X2S,XX
M XDRY=XDRX
K XDRX
W @IOF
S XNCNT=0
F I=0:0 S I=$O(XDRY(I)) Q:I'>0 D Q:$D(DUOUT)!$D(DTOUT)!$D(XDRX)
. F J=0:0 S J=$O(XDRY(I,J)) Q:J'>0 D Q:$D(DUOUT)!$D(DTOUT)!$D(XDRX)
. . S X01=$G(@(XDRDIC_I_",0)")),X1=$P(X01,U),X1S=$P(X01,U,9),X1S=$E(X1S,1,3)_"-"_$E(X1S,4,5)_"-"_$E(X1S,6,15)
. . S X02=$G(@(XDRDIC_J_",0)")),X2=$P(X02,U),X2S=$P(X02,U,9),X2S=$E(X2S,1,3)_"-"_$E(X2S,4,5)_"-"_$E(X2S,6,15)
. . I X1=""!(X2="") K XDRY(I,J) Q
. . F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1)
. . S XNCNT=XNCNT+1,XX(XNCNT)=I_U_J
. . ;
. . W !!,$J(XNCNT,3)," ",?8,X1,?42,X1S,?60,"[",I,"]",?70,"#",$$HRCN^BPMU(I,$G(DUZ(2)))
. . W !,?8,X2,?42,X2S,?60,"[",J,"]",?70,"#",$$HRCN^BPMU(J,$G(DUZ(2)))
. . ;
. . I '(XNCNT#6) D ASK Q:$D(DUOUT)!$D(DTOUT) W @IOF
I '($D(DUOUT)!$D(DTOUT)!$D(XDRX)) D ASK
Q
;
ASK ;
;IHS/OIT/NKD BPM*1.0*2 Restrict batch to one pair of duplicates
N DIR,K,Y,N,N1,N2
W ! S DIR(0)="LO^1:"_XNCNT,DIR("A")="Select an entry to schedule a merge"
D ^DIR K DIR K DIRUT Q:$D(DUOUT)!$D(DTOUT)
S K="" F S K=$O(Y(K)) Q:K="" S Y=Y(K) K Y(K) D
. S N=$P(Y,",") Q:N=""
. S N1=+XX(N),N2=$P(XX(N),U,2)
. S XDRX(N1,N2)=XDRY(N1,N2)
Q
;
BPMXDRV ;IHS/PHXAO/AEF - PATIENT MERGE SPECIAL ROUTINES DRIVER - 6/26/12 ;
+1 ;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
+2 ;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office
+3 ; changed namespace from BZXM to BPM
+4 ; changed names of speical merge routines
+5 ; added check for REPOINT DELETED VISITS parameter
+6 ;IHS/DIT/ENM 08/20/10 EDR MODS ADDED BELOW
+7 ;IHS/OIT/NKD 6/13/2012 Restricted merge batches to 1 pair of duplicates
+8 ; Moved EDR and MPI processing into separate routines
+9 ; Moved processing checks into BPMXVST and BPMXLR
+10 ;;
DESC ;;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;BPMXDRV:
+3 ;;THIS ROUTINE CALLS OTHER SPECIAL IHS MERGE ROUTINES USED TO MERGE
+4 ;;DUPLICATE PATIENT DATA.
+5 ;;
+6 ;;THIS ROUTINE IS ENTERED INTO THE 'NAME OF MERGE ROUTINE' FIELD OF THE
+7 ;;'AFFECTS RECORD MERGE' SUBFILE OF THE PACKAGE FILE FOR THE 'IHS
+8 ;;PATIENT MERGE' PACKAGE. THIS ROUTINE IS THEN RUN BY THE KERNEL
+9 ;;TOOLKIT DUPLICATE PATIENT MERGE SOFTWARE. THIS ROUTINE ELIMINATES
+10 ;;THE NEED TO HAVE EACH INDIVIDUAL MERGE ROUTINE ENTERED INTO EACH
+11 ;;INDIVIDUAL ENTRY IN THE PACKAGE FILE.
+12 ;;
+13 ;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
+14 ;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT MERGE
+15 ;;SOFTWARE:
+16 ;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
+17 ;;EXAMPLE:
+18 ;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
+19 ;;WHERE =2 IS THE PARENT FILE (VA PATIENT FILE).
+20 ;;
+21 ;;$$END
+22 ;
+23 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
DO EN^DDIOL(X)
+24 QUIT
EN(BPMRY) ;EP
+1 ;----- MAIN ENTRY POINT FROM DUPLICATE PATIENT MERGE SOFTWARE
+2 ;
+3 ; BPMRY = TEMP GLOBAL ARRAY SET UP BY THE PATIENT MERGE
+4 ; SOFTWARE, I.E., "^TMP(""XDRFROM"",$J)"
+5 ;
+6 ; Run iCare special merge; if FROM patient being edited, it stops
+7 IF $LENGTH($TEXT(CHK^BQIPTMRG))
Begin DoDot:1
+8 NEW FR
SET FR=$ORDER(@BPMRY@(0))
IF 'FR
QUIT
+9 IF '$$CHK^BQIPTMRG(FR)
SET ZTSTOP=1
QUIT
+10 DO EN^BQIPTMRG(BPMRY)
End DoDot:1
IF $DATA(ZTSTOP)
QUIT
+11 ;
+12 ; Flag all visits for export for FROM patients
+13 DO VISITS^BPMMRG(BPMRY)
+14 ;
+15 ;REPOINT VARIABLE POINTER FIELDS
+16 DO EN^BPMXVP(BPMRY)
+17 ;
+18 ;REPOINT PT TAXONOMY FILE POINTERS
+19 DO EN^BPMXTAX(BPMRY)
+20 ;
+21 ;REPOINT 3P CLAIM AND BILL PATIENTS
+22 DO EN^BPMX3PB(BPMRY)
+23 ;
+24 ;REPOINT VISIT FILE POINTERS if REPOINT DELETED VISITS parameter turned ON
+25 ;IHS/OIT/NKD BPM*1.0*2 MOVED PROCESSING CHECK INTO BPMXVST ROUTINE
+26 ;I $$GET1^DIQ(15.1,2,99999.01)="YES" D EN^BPMXVST(BPMRY)
+27 DO EN^BPMXVST(BPMRY)
+28 ;
+29 ;MERGE WORD PROCESSING FIELDS
+30 DO EN^BPMXWP(BPMRY)
+31 ;
+32 ;MERGE LAB DATA (calls ^BLRMERG)
+33 ;IHS/OIT/NKD BPM*1.0*2 MOVED PROCESSING CHECK INTO BPMXLR ROUTINE
+34 ;I $L($T(EN^BLRMERG)) D EN^BPMXLR(BPMRY)
+35 DO EN^BPMXLR(BPMRY)
+36 ;
+37 ;MERGE PROBLEM LIST
+38 DO EN^BPMXPRB(BPMRY)
+39 ;
+40 ;IHS/OIT/NKD BPM*1.0*2 CALL NEW MPI/EDR ROUTINES - START OLD CODE
+41 ;IHS/DIT/ENM 02/23/10
+42 ;MERGE MPI DATA (Calls ^AGMPIHLO
+43 ;S X="AGMPIHLO" X ^%ZOSF("TEST") I $T D NEWMSG^AGMPIHLO(BPMRY)
+44 ;
+45 ;IHS/DIT/ENM 08/20/10 next 7 lines sent by FJ for the EDR project
+46 ;Added for support of GENERIC merge trigger to subscribing applications fje 8/13/10
+47 ;S X="BADEMRG" X ^%ZOSF("TEST") I $T D THIS LINE IS NOT NEEDED
+48 ;S BPMFR=$O(@BPMRY@(0))
+49 ;Q:'BPMFR
+50 ;S BPMTO=$O(@BPMRY@(BPMFR,0))
+51 ;Q:'BPMTO
+52 ;S X="BPM MERGE PATIENT ADT-A40",DIC=101,DFNFROM=+BPMFR,DFNTO=+BPMTO
+53 ;D EN^XQOR
+54 ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
+55 ;SEND MPI MESSAGE
+56 DO EN^BPMXMPI(BPMRY)
+57 ;SEND EDR MESSAGE
+58 DO EN^BPMXEDR(BPMRY)
+59 ;IHS/OIT/NKD BPM*1.0*2 END NEW CODE
+60 QUIT
QUE ;EP
+1 ;IHS/OIT/NKD BPM*1.0*2 New entry point from menu [BPM MERGE READY DUPLICATES]
+2 ;This is the entry point for queueing a merge process, modified for single pair batching
+3 ;Code functionality copied from QUE^XDRMERG0 and QUE^XDRMERGB
+4 ;Use of GOTO statement at end to continue processing in XDR routines
+5 ;
+6 ; update verified and/or ready to merge statuses if necessary
DO EN^XDRVCHEK
+7 ;
+8 NEW XDRXX,XDRYY,XDRMA,DIE,DIC,DIR,DR,ZTDTH,ZTSK
+9 NEW XDRX,XDRY,XDRFIL,XDRGLOB,X,Y,XDRNAME
+10 NEW XDRFDA,XDRIENS,XDRI,XDRJ,XDRK,DA,DIK
+11 ;
+12 SET XDRFIL=$$FILE^XDRDPICK()
IF XDRFIL'>0
QUIT
+13 IF XDRFIL=2
Begin DoDot:1
+14 NEW X,XDRKEY
+15 SET (X,XDRKEY)=0
FOR
SET X=$ORDER(^VA(200,DUZ,51,"B",X))
IF X'>0!(XDRKEY)
QUIT
Begin DoDot:2
+16 IF $$GET1^DIQ(19.1,X,.01)="DG ELIGIBILITY"
SET XDRKEY=1
+17 QUIT
End DoDot:2
+18 SET Y=0
IF 'XDRKEY
WRITE !!,"You should hold the 'DG ELIGIBILITY' key to run a patient file merge."
SET Y=1
+19 QUIT
End DoDot:1
IF Y
QUIT
+20 SET XDRDIC=^DIC(XDRFIL,0,"GL")
+21 SET XDRGLOB=$EXTRACT(XDRDIC,2,999)
+22 SET X=""
+23 SET XNCNT=0
SET XNCNT0=0
+24 FOR
SET X=$ORDER(^VA(15,"AVDUP",XDRGLOB,X))
IF X=""
QUIT
SET Y=$ORDER(^(X,0))
Begin DoDot:1
+25 NEW YVAL
SET YVAL=^VA(15,Y,0)
+26 ; ALREADY DONE OR SCHEDULED
IF $PIECE(YVAL,U,20)>0
QUIT
+27 ; TAKE ONLY VERIFIED
IF $PIECE(YVAL,U,3)'="V"
QUIT
+28 ; TAKE ONLY IF MARKED READY TO MERGE
IF $PIECE(YVAL,U,5)'=1
QUIT
+29 IF $PIECE(YVAL,U,13)>0
Begin DoDot:2
+30 IF '$DATA(@(XDRDIC_(+YVAL)_",0)"))!'$DATA(@(XDRDIC_(+$PIECE(YVAL,U,2))_",0)"))
QUIT
+31 ; get ien numbers from duplicate file
IF $PIECE(YVAL,U,4)'=2
SET XDRX(+YVAL,+$PIECE(YVAL,U,2))=Y
+32 ; Reverse - merge to switched
IF '$TEST
SET XDRX(+$PIECE(YVAL,U,2),+YVAL)=Y
+33 SET XNCNT=XNCNT+1
End DoDot:2
End DoDot:1
+34 WRITE !!,XNCNT," Entries Ready to be included in merge"
+35 IF $ORDER(XDRX(0))'>0
Begin DoDot:1
+36 WRITE !!?15,$CHAR(7),"No Verified Duplicates included in merge",$CHAR(7),!!
End DoDot:1
QUIT
+37 ;
+38 ;IHS/OIT/NKD BPM*1.0*2 BEGIN NEW CODE - Restrict batch to one pair of duplicates
+39 DO BATCH(.XDRX)
+40 IF '$DATA(XDRX)
WRITE !,"None selected!"
QUIT
+41 ;IHS/OIT/NKD BPM*1.0*2 END NEW CODE
+42 ;
+43 KILL DIR
SET DIR(0)="Y"
+44 SET DIR("A",1)="This process will take a **LONG** time (usually over 15 hours, and sometimes"
+45 SET DIR("A",2)="considerably longer), but you CAN stop and restart the process when you"
+46 SET DIR("A")="want using the options. OK"
+47 DO ^DIR
KILL DIR
IF Y'>0
QUIT
+48 GOTO NAME^XDRMERGB
+49 ;
+50 QUIT
+51 ;
BATCH(XDRX) ;
+1 ;IHS/OIT/NKD BPM*1.0*2 Restrict batch to one pair of duplicates
+2 ; Displays all pairs ready to be merged, and allows the selection of ONE to be batched
+3 NEW XNCNT,I,J,XDRY,X01,X1,X1S,X02,X2,X2S,XX
+4 MERGE XDRY=XDRX
+5 KILL XDRX
+6 WRITE @IOF
+7 SET XNCNT=0
+8 FOR I=0:0
SET I=$ORDER(XDRY(I))
IF I'>0
QUIT
Begin DoDot:1
+9 FOR J=0:0
SET J=$ORDER(XDRY(I,J))
IF J'>0
QUIT
Begin DoDot:2
+10 SET X01=$GET(@(XDRDIC_I_",0)"))
SET X1=$PIECE(X01,U)
SET X1S=$PIECE(X01,U,9)
SET X1S=$EXTRACT(X1S,1,3)_"-"_$EXTRACT(X1S,4,5)_"-"_$EXTRACT(X1S,6,15)
+11 SET X02=$GET(@(XDRDIC_J_",0)"))
SET X2=$PIECE(X02,U)
SET X2S=$PIECE(X02,U,9)
SET X2S=$EXTRACT(X2S,1,3)_"-"_$EXTRACT(X2S,4,5)_"-"_$EXTRACT(X2S,6,15)
+12 IF X1=""!(X2="")
KILL XDRY(I,J)
QUIT
+13 FOR
IF X1'["MERGING INTO"
QUIT
SET X1=$PIECE($PIECE(X1,"(",2,10),")",1,$LENGTH(X1,")")-1)
+14 SET XNCNT=XNCNT+1
SET XX(XNCNT)=I_U_J
+15 ;
+16 WRITE !!,$JUSTIFY(XNCNT,3)," ",?8,X1,?42,X1S,?60,"[",I,"]",?70,"#",$$HRCN^BPMU(I,$GET(DUZ(2)))
+17 WRITE !,?8,X2,?42,X2S,?60,"[",J,"]",?70,"#",$$HRCN^BPMU(J,$GET(DUZ(2)))
+18 ;
+19 IF '(XNCNT#6)
DO ASK
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
WRITE @IOF
End DoDot:2
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(XDRX)
QUIT
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(XDRX)
QUIT
+20 IF '($DATA(DUOUT)!$DATA(DTOUT)!$DATA(XDRX))
DO ASK
+21 QUIT
+22 ;
ASK ;
+1 ;IHS/OIT/NKD BPM*1.0*2 Restrict batch to one pair of duplicates
+2 NEW DIR,K,Y,N,N1,N2
+3 WRITE !
SET DIR(0)="LO^1:"_XNCNT
SET DIR("A")="Select an entry to schedule a merge"
+4 DO ^DIR
KILL DIR
KILL DIRUT
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+5 SET K=""
FOR
SET K=$ORDER(Y(K))
IF K=""
QUIT
SET Y=Y(K)
KILL Y(K)
Begin DoDot:1
+6 SET N=$PIECE(Y,",")
IF N=""
QUIT
+7 SET N1=+XX(N)
SET N2=$PIECE(XX(N),U,2)
+8 SET XDRX(N1,N2)=XDRY(N1,N2)
End DoDot:1
+9 QUIT
+10 ;
