XDRMERGA ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;01/31/2000 09:14
;;7.3;TOOLKIT;**23,28,37,40,45,137**;Apr 25, 1995;Build 10
;;
Q
APPROVE ; This is the entry point for approving a duplicate pair for merge
K DIRUT,DUOUT,DTOUT ;
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
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,4)="" D Q ; MAKE SURE MERGE DIRECTION IS DEFINED
. . W !,"Entry `",Y," DOES NOT HAVE MERGE DIRECTION DEFINED - CAN'T APPROVE"
. . N XDRDICA S XDRDICA=U_$P($P(YVAL,U),";",2)
. . I '$D(@(XDRDICA_(+YVAL)_",0)"))!$D(@(XDRDICA_(+YVAL)_",-9)"))!'$D(@(XDRDICA_(+$P(YVAL,U,2))_",0)"))!$D(@(XDRDICA_(+$P(YVAL,U,2))_",-9)")) D Q
. . . D RESET^XDRDPICK(Y)
. I $P(YVAL,U,13)'>0 D
. . I $P(YVAL,U,4)'=2 S XDRY(+YVAL,+$P(YVAL,U,2))=Y
. . E S XDRY(+$P(YVAL,U,2),+YVAL)=Y
. . S XNCNT0=XNCNT0+1
I XNCNT0>0 W !!,XNCNT0," Entries are awaiting approval for merging Return to continue..." R X:DTIME
I $D(XDRY) D CHKBKUP I $D(DUOUT)!$D(DTOUT) Q
K XDRY
Q
;
STOP ;
N XDRI,DIE,DA,DR,DIR,XDRC
S XDRC=0 F XDRI=0:0 S XDRI=$O(^VA(15.2,XDRI)) Q:XDRI'>0 I $P(^(XDRI,0),U,4)="A" D
. S XDRC=XDRC+1
. S DIR(0)="Y",DIR("A")="Do you want to stop "_$P(^VA(15.2,XDRI,0),U)
. D ^DIR K DIR I Y'>0 Q
. S DIE="^VA(15.2,",DA=XDRI,DR=".09///1" D ^DIE
. K DIE,DR
I XDRC'>0 W !!,$C(7),"No active merge processes were found.",!!
Q
;
CHKBKUP ; Check if backups have been generated for outstanding pairs
N I,J,X,Y,X1,X2,XNCNT,I,J,K,L,M,N,XX
K DIR
;S DIR("A")="Do you want to check pairs awaiting backups (Y/N)"
;S DIR("?")="Indication that a backup of the data for the entries for a duplicate pair is required prior to merging the entries. You may review entries to see if any should be marked as completed."
;S DIR(0)="Y" D ^DIR K DIR Q:Y'>0
S ASKNAME="ASK1" D CHECK
Q
;
CHECK ;
W @IOF
S XNCNT=0
F I=0:0 S I=$O(XDRY(I)) Q:I'>0 D Q:$D(DUOUT)!$D(DTOUT)
. F J=0:0 S J=$O(XDRY(I,J)) Q:J'>0 D Q:$D(DUOUT)!$D(DTOUT)
. . 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,"]"
. . W !,?8,X2,?42,X2S,?60,"[",J,"]"
. . S ^TMP("XDR",$J,XNCNT)=X1_U_X1S_U_I_U_X2_U_X2S_U_J ;LLS 07-NOV-2013 - save for possible verification prompt
. . I '(XNCNT#6) D @ASKNAME Q:$D(DUOUT)!$D(DTOUT) W @IOF
I '($D(DUOUT)!$D(DTOUT)) D @ASKNAME
Q
;
ASK1 ;
W ! S DIR(0)="LO^1:"_XNCNT,DIR("A")="Select entries to approve them for merging"
;W !,"TEST"
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
. F M=1:1 S N=$P(Y,",",M) Q:N="" D
. . S N1=+XX(N),N2=$P(XX(N),U,2)
. . I $$TESTPAT^VADPT(N1)=1,$$TESTPAT^VADPT(N2)'=1 D Q:Y'=1 ;LLS - trying to merge test patient into real patient
. . . N XDRFLDI,XDRPC
. . . F XDRFLDI=1:1:6 S XDRPC(XDRFLDI)=$P(^TMP("XDR",$J,XNCNT),U,XDRFLDI) ;LLS 07-NOV-2013
. . . W !!,$J(N,3)," ",?8,XDRPC(1),?42,XDRPC(2),?60,"[",XDRPC(3),"]" ;LLS 07-NOV-2013
. . . W !,?8,XDRPC(4),?42,XDRPC(5),?60,"[",XDRPC(6),"]" ;LLS 07-NOV-2013
. . . W !!!! S DIR(0)="Y^"_XNCNT,DIR("A")="Merge the above pair (a test patient into a real patient) SURE" ;LLS 07-NOV-2013
. . . D ^DIR K DIR ;LLS 07-NOV-2013
. . . I Y'=1 W !!,"*****[",XDRPC(3),"] WILL NOT BE MERGED INTO [",XDRPC(6),"]" ;LLS 07-NOV-2013
. . S (DA,XDRX(N1,N2))=XDRY(N1,N2)
. . N I,J,K,M,N,N1,N2,X1,X2,X,DIE,DR,Y
. . S DIE="^VA(15,"
. . S X=DT,X=$$FMTE^XLFDT(X,"2D")
. . S X=$P($P(^VA(200,DUZ,0),U),",",2)_" "_$P($P(^(0),U),",")_" (DUZ="_DUZ_") "_X
. . S DR=".13///1;.14///"_X
. . D ^DIE
Q
;
RESTART ; Entry point to restart non-completed merges
N NC,N S NC=0
F XDRFDA=0:0 S XDRFDA=$O(^VA(15.2,XDRFDA)) Q:XDRFDA'>0 D
. S X=$P(^VA(15.2,XDRFDA,0),U,4) I X="C"!(X="A") S N=1 D Q:N=1
. . F J=0:0 S J=$O(^VA(15.2,XDRFDA,3,J)) Q:J'>0 I "CA"'[$P(^(J,0),U,3) S N=0 Q
. S NC=NC+1
. S DIR(0)="Y",DIR("A")="Do you want to RESTART merge process "_$P(^VA(15.2,XDRFDA,0),U),DIR("B")="NO"
. D ^DIR K DIR Q:Y'>0
. S ZTRTN="DQ^XDRMERG0",ZTSAVE("XDRFDA")="",ZTIO="NULL"
. D ^%ZTLOAD I '$D(ZTSK) W !!,$C(7),"RESTART **NOT** QUEUED" Q
. S $P(^VA(15.2,XDRFDA,0),U,8,9)=ZTSK_U ; SET TASK NUMBER AND REMOVE HALT FLAG IF SET
. W !,"Restart queued as task ",ZTSK,!
I NC'>0 W !!,$C(7),"No merge processes found that needed restarting.",!!
Q
;
;
DOSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
N XDRAA,XDRZZ ; DEBUG STATEMENT
N XDRALY1,XDRALY2,XDRALY1,XDRALY2,XDRALY1A,XDRALY2A,XDRDUPAF,XDRDUPAT,XDRALYSS,XDRALYNM,XDR1,NODEB ;;LLS 17-OCT-2013 - my new arrays and NODEB was not NEWed and thought it should be
S SFILE=+$P($G(@(XDRFROM_"0)")),U,2)
I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
;
;LLS 17-OCT-2013 added this section to setup arrays for fix duplicate (same Name & Social Security Number) aliases being merged:
I $G(FILE)=2,SFILE="2.01" D
. D GETS^DIQ(FILE,$P(XDRGID,U,2)_",","1*","","XDRALY1") ;Put 'FROM' patient ALIAS data into XDRALY1 array
. M XDRALY1A=XDRALY1(SFILE) ;strip first subscript
. D GETS^DIQ(FILE,$P(XDRGID,U,3)_",","1*","","XDRALY2") ;Put 'TO' patient ALIAS data into XDRALY2 array
. M XDRALY2A=XDRALY2(SFILE) ;strip first subscript
. S XDR1="" F S XDR1=$O(XDRALY1A(XDR1)) Q:XDR1="" D ;Create new 'FROM' patient alias array subscripted by NAME^SSN
. . S XDRALYSS=XDRALY1A(XDR1,1),XDRALYNM=XDRALY1A(XDR1,.01)
. . S XDRDUPAF(XDRALYNM_U_XDRALYSS)=$P(XDR1,",",1) ;'FROM' array format: XDRDUPAF(NAME^SSN)=node
. S XDR1="" F S XDR1=$O(XDRALY2A(XDR1)) Q:XDR1="" D ;Create new 'TO' patient alias array subscripted by NAME^SSN
. . S XDRALYSS=XDRALY2A(XDR1,1),XDRALYNM=XDRALY2A(XDR1,.01)
. . S XDRDUPAT(XDRALYNM_U_XDRALYSS)=$P(XDR1,",",1) ;'TO' array format: XDRDUPAT(NAME^SSN)=node
;LLS 17-OCT-2013 end of added section
;
I $P($G(^DD(SFILE,.01,0)),U,2)["W" D Q ; HANDLE WORD PROCESSING FIELDS
. N XF,XT S XT=$E(XDRTO,1,$L(XDRTO)-1)_")"
. I '$D(@XT) D
. . S XF=$E(XDRFROM,1,$L(XDRFROM)-1)_")"
. . M @XT=@XF
. . Q
. Q
F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D
. ;LLS 17-OCT-2013 - the following line of code was added to check patient alias multiple (file #2.01) and
. ; skip moving this alias because it already exists in the 'merge to' patient file.
. ; XDRDUPAF array contains 'FROM' file aliases and XDRDUPAT contains 'TO' file aliases
. I SFILE=2.01,$D(XDRDUPAF($P($G(@(XDRFROM_NODEA_",0)"),"*"),U,1,2))),$D(XDRDUPAT($P($G(@(XDRFROM_NODEA_",0)"),"*"),U,1,2))) Q ;LLS 17-OCT-2013 - added
. S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE
. N XDRDT S XDRDT=^DD(SFILE,.01,0)
. I $P(XDRDT,U,2)["D" S XDRDT=$P(XDRDT,U,5,999),XDRDINUM=$S(XDRDT["DINUM":1,1:0) I XDRDINUM S XDRDT=0 D DINUMDAT Q:XDRDT ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM
. S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE
. I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA
. I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT
. I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
. . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
. . S NODE=""
. . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D
. . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q
. . . S NEWFROM=XDRFROM_NODEA_","""_NODE_""","
. . . S NEWTO=XDRTO_XVALUE_","""_NODE_""","
. . . S NEWTOIEN=XVALUE_","_IENTOSTR
. . . D DOSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
. K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE
. S XENTOSTR="+1,"_IENTOSTR
. S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2)
. I XDRFILTY["P" S VALUE="`"_VALUE
. I XDRFILTY["V" D
. . N Y S Y=$P(VALUE,";",2) Q:Y=""
. . S Y=$P($G(@("^"_Y_"0)")),U) Q:Y=""
. . S VALUE=Y_".`"_(+VALUE)
. . Q
. I SFILE=70.03 S XDRFILTY="D" ;use internal data for file 70.03
. I XDRFILTY'["P"&(XDRFILTY'["V"),XDRFILTY'["D" S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE)
. S XDRXX(SFILE,XENTOSTR,.01)=VALUE
. I $O(^DD(SFILE,0,"ID",0))>0 D
. . ;CODE FOR ADDING IDENTIFIERS
. . N I,N,XDRFROM1,IENFR
. . S N=0,I=SFILE F S I=$G(^DD(I,0,"UP")) Q:I'>0 S N=N+1
. . S XDRFROM1=$P(XDRFROM,"(",2,99),IENFR=NODEA_","
. . F I=$L(XDRFROM1,",")-2:-2 Q:N'>0 S IENFR=IENFR_$P(XDRFROM1,",",I)_",",N=N-1
. . ;
. . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D
. . . S N=$$GET1^DIQ(SFILE,IENFR,XDRID)
. . . I N'="" S XDRXX(SFILE,XENTOSTR,XDRID)=N
. . . Q
. . Q
. ;
. K XDRAA,XDRZZ I $D(XDRTESTK) M XDRAA=XDRXX ; DEBUG STATEMENT
. ; DATES THAT ARE DINUMED HAVE BEEN HANDLED ABOVE, SO CAN PASS A DATE IN AS AN INTERNAL VALUE
. D UPDATE^DIE($S(XDRFILTY["D":"",1:"E"),"XDRXX","XDRYY","XDRZZ") ; CREATE A NEW ENTRY IN IENTO FOR VALUE
. I $D(XDRZZ),$D(XDRTESTK),SFILE'=2.0361 S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ ; DEBUG STATEMENT
. S NODEB=$G(XDRYY(1)) I NODEB'>0 Q
. M @(XDRTO_NODEB_")")=@(XDRFROM_NODEA_")")
. S DIK=XDRTO,DA=NODEB D
. . F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q
. I SFILE=55.06 N DIU S DIU(0)=1 F DIK(1)=".01^B","10^AUDS","34^AUD","64^AUDDD","7^ACR1" D EN1^DIK
. I SFILE'=55.06 N DIU S DIU(0)=1 D IX^DIK
Q
;
GETEXT(DICA,DA,FILNUM) ; GET EXTERNAL VALUE FOR .01 FIELD
N DIC,DIQ,DR,XDRQ
S DIC=DICA,DIC("P")=FILNUM,DR=.01,DIQ="XDRQ",DIQ(0)="E"
D EN^DIQ1
Q $G(XDRQ(FILNUM,DA,.01,"E"))
;
DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
N NEWVAL,NODETO
S NODETO=NODEA
I $D(@(XDRTO_NODEA_")")) Q:(SFILE'=63.04) D
. S NEWVAL=VALUE
. F Q:'$D(@(XDRTO_NODETO_")")) S NODETO=NODETO-.000001,NEWVAL=NEWVAL+.000001
M @(XDRTO_NODETO_")")=@(XDRFROM_NODEA_")")
I $D(NEWVAL) S $P(@(XDRTO_NODETO_",0)"),U)=NEWVAL
S DIK=XDRTO,DA=NODEA D D IX^DIK
. F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q
S XDRDT=1
Q
;
DODIS ; CODE TO HANDLE DISPOSITION ENTRIES IN PATIENT FILE
N XDRI,DA,DIK
F XDRI=0:0 S XDRI=$O(@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")) Q:XDRI'>0 D
. I $D(@(XDRDIC_IENTO_",""DIS"","_XDRI_")")) Q
. M @(XDRDIC_IENTO_",""DIS"","_XDRI_")")=@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")
. S DA=XDRI,DA(1)=IENTO,DIK=XDRDIC_IENTO_",""DIS""," D IX^DIK
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMERGA 11159 printed Apr 09, 2024@21:42:14 Page 2
XDRMERGA ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;01/31/2000 09:14
+1 ;;7.3;TOOLKIT;**23,28,37,40,45,137**;Apr 25, 1995;Build 10
+2 ;;
+3 QUIT
APPROVE ; This is the entry point for approving a duplicate pair for merge
+1 ;
KILL DIRUT,DUOUT,DTOUT
+2 ; update verified and/or ready to merge statuses if necessary
DO EN^XDRVCHEK
+3 ;
+4 NEW XDRXX,XDRYY,XDRMA,DIE,DIC,DIR,DR,ZTDTH,ZTSK
+5 NEW XDRX,XDRY,XDRFIL,XDRGLOB,X,Y,XDRNAME
+6 NEW XDRFDA,XDRIENS,XDRI,XDRJ,XDRK,DA,DIK
+7 ;
+8 SET XDRFIL=$$FILE^XDRDPICK()
if XDRFIL'>0
QUIT
+9 SET XDRDIC=^DIC(XDRFIL,0,"GL")
+10 SET XDRGLOB=$EXTRACT(XDRDIC,2,999)
+11 SET X=""
+12 SET XNCNT=0
SET XNCNT0=0
+13 FOR
SET X=$ORDER(^VA(15,"AVDUP",XDRGLOB,X))
if X=""
QUIT
SET Y=$ORDER(^(X,0))
Begin DoDot:1
+14 NEW YVAL
SET YVAL=^VA(15,Y,0)
+15 ; ALREADY DONE OR SCHEDULED
IF $PIECE(YVAL,U,20)>0
QUIT
+16 ; TAKE ONLY VERIFIED
IF $PIECE(YVAL,U,3)'="V"
QUIT
+17 ; TAKE ONLY IF MARKED READY TO MERGE
IF $PIECE(YVAL,U,5)'=1
QUIT
+18 ; MAKE SURE MERGE DIRECTION IS DEFINED
IF $PIECE(YVAL,U,4)=""
Begin DoDot:2
+19 WRITE !,"Entry `",Y," DOES NOT HAVE MERGE DIRECTION DEFINED - CAN'T APPROVE"
+20 NEW XDRDICA
SET XDRDICA=U_$PIECE($PIECE(YVAL,U),";",2)
+21 IF '$DATA(@(XDRDICA_(+YVAL)_",0)"))!$DATA(@(XDRDICA_(+YVAL)_",-9)"))!'$DATA(@(XDRDICA_(+$PIECE(YVAL,U,2))_",0)"))!$DATA(@(XDRDICA_(+$PIECE(YVAL,U,2))_",-9)"))
Begin DoDot:3
+22 DO RESET^XDRDPICK(Y)
End DoDot:3
QUIT
End DoDot:2
QUIT
+23 IF $PIECE(YVAL,U,13)'>0
Begin DoDot:2
+24 IF $PIECE(YVAL,U,4)'=2
SET XDRY(+YVAL,+$PIECE(YVAL,U,2))=Y
+25 IF '$TEST
SET XDRY(+$PIECE(YVAL,U,2),+YVAL)=Y
+26 SET XNCNT0=XNCNT0+1
End DoDot:2
End DoDot:1
+27 IF XNCNT0>0
WRITE !!,XNCNT0," Entries are awaiting approval for merging Return to continue..."
READ X:DTIME
+28 IF $DATA(XDRY)
DO CHKBKUP
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+29 KILL XDRY
+30 QUIT
+31 ;
STOP ;
+1 NEW XDRI,DIE,DA,DR,DIR,XDRC
+2 SET XDRC=0
FOR XDRI=0:0
SET XDRI=$ORDER(^VA(15.2,XDRI))
if XDRI'>0
QUIT
IF $PIECE(^(XDRI,0),U,4)="A"
Begin DoDot:1
+3 SET XDRC=XDRC+1
+4 SET DIR(0)="Y"
SET DIR("A")="Do you want to stop "_$PIECE(^VA(15.2,XDRI,0),U)
+5 DO ^DIR
KILL DIR
IF Y'>0
QUIT
+6 SET DIE="^VA(15.2,"
SET DA=XDRI
SET DR=".09///1"
DO ^DIE
+7 KILL DIE,DR
End DoDot:1
+8 IF XDRC'>0
WRITE !!,$CHAR(7),"No active merge processes were found.",!!
+9 QUIT
+10 ;
CHKBKUP ; Check if backups have been generated for outstanding pairs
+1 NEW I,J,X,Y,X1,X2,XNCNT,I,J,K,L,M,N,XX
+2 KILL DIR
+3 ;S DIR("A")="Do you want to check pairs awaiting backups (Y/N)"
+4 ;S DIR("?")="Indication that a backup of the data for the entries for a duplicate pair is required prior to merging the entries. You may review entries to see if any should be marked as completed."
+5 ;S DIR(0)="Y" D ^DIR K DIR Q:Y'>0
+6 SET ASKNAME="ASK1"
DO CHECK
+7 QUIT
+8 ;
CHECK ;
+1 WRITE @IOF
+2 SET XNCNT=0
+3 FOR I=0:0
SET I=$ORDER(XDRY(I))
if I'>0
QUIT
Begin DoDot:1
+4 FOR J=0:0
SET J=$ORDER(XDRY(I,J))
if J'>0
QUIT
Begin DoDot:2
+5 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)
+6 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)
+7 IF X1=""!(X2="")
KILL XDRY(I,J)
QUIT
+8 FOR
if X1'["MERGING INTO"
QUIT
SET X1=$PIECE($PIECE(X1,"(",2,10),")",1,$LENGTH(X1,")")-1)
+9 SET XNCNT=XNCNT+1
SET XX(XNCNT)=I_U_J
+10 WRITE !!,$JUSTIFY(XNCNT,3)," ",?8,X1,?42,X1S,?60,"[",I,"]"
+11 WRITE !,?8,X2,?42,X2S,?60,"[",J,"]"
+12 ;LLS 07-NOV-2013 - save for possible verification prompt
SET ^TMP("XDR",$JOB,XNCNT)=X1_U_X1S_U_I_U_X2_U_X2S_U_J
+13 IF '(XNCNT#6)
DO @ASKNAME
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
WRITE @IOF
End DoDot:2
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
End DoDot:1
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+14 IF '($DATA(DUOUT)!$DATA(DTOUT))
DO @ASKNAME
+15 QUIT
+16 ;
ASK1 ;
+1 WRITE !
SET DIR(0)="LO^1:"_XNCNT
SET DIR("A")="Select entries to approve them for merging"
+2 ;W !,"TEST"
+3 DO ^DIR
KILL DIR
KILL DIRUT
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+4 SET K=""
FOR
SET K=$ORDER(Y(K))
if K=""
QUIT
SET Y=Y(K)
KILL Y(K)
Begin DoDot:1
+5 FOR M=1:1
SET N=$PIECE(Y,",",M)
if N=""
QUIT
Begin DoDot:2
+6 SET N1=+XX(N)
SET N2=$PIECE(XX(N),U,2)
+7 ;LLS - trying to merge test patient into real patient
IF $$TESTPAT^VADPT(N1)=1
IF $$TESTPAT^VADPT(N2)'=1
Begin DoDot:3
+8 NEW XDRFLDI,XDRPC
+9 ;LLS 07-NOV-2013
FOR XDRFLDI=1:1:6
SET XDRPC(XDRFLDI)=$PIECE(^TMP("XDR",$JOB,XNCNT),U,XDRFLDI)
+10 ;LLS 07-NOV-2013
WRITE !!,$JUSTIFY(N,3)," ",?8,XDRPC(1),?42,XDRPC(2),?60,"[",XDRPC(3),"]"
+11 ;LLS 07-NOV-2013
WRITE !,?8,XDRPC(4),?42,XDRPC(5),?60,"[",XDRPC(6),"]"
+12 ;LLS 07-NOV-2013
WRITE !!!!
SET DIR(0)="Y^"_XNCNT
SET DIR("A")="Merge the above pair (a test patient into a real patient) SURE"
+13 ;LLS 07-NOV-2013
DO ^DIR
KILL DIR
+14 ;LLS 07-NOV-2013
IF Y'=1
WRITE !!,"*****[",XDRPC(3),"] WILL NOT BE MERGED INTO [",XDRPC(6),"]"
End DoDot:3
if Y'=1
QUIT
+15 SET (DA,XDRX(N1,N2))=XDRY(N1,N2)
+16 NEW I,J,K,M,N,N1,N2,X1,X2,X,DIE,DR,Y
+17 SET DIE="^VA(15,"
+18 SET X=DT
SET X=$$FMTE^XLFDT(X,"2D")
+19 SET X=$PIECE($PIECE(^VA(200,DUZ,0),U),",",2)_" "_$PIECE($PIECE(^(0),U),",")_" (DUZ="_DUZ_") "_X
+20 SET DR=".13///1;.14///"_X
+21 DO ^DIE
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
RESTART ; Entry point to restart non-completed merges
+1 NEW NC,N
SET NC=0
+2 FOR XDRFDA=0:0
SET XDRFDA=$ORDER(^VA(15.2,XDRFDA))
if XDRFDA'>0
QUIT
Begin DoDot:1
+3 SET X=$PIECE(^VA(15.2,XDRFDA,0),U,4)
IF X="C"!(X="A")
SET N=1
Begin DoDot:2
+4 FOR J=0:0
SET J=$ORDER(^VA(15.2,XDRFDA,3,J))
if J'>0
QUIT
IF "CA"'[$PIECE(^(J,0),U,3)
SET N=0
QUIT
End DoDot:2
if N=1
QUIT
+5 SET NC=NC+1
+6 SET DIR(0)="Y"
SET DIR("A")="Do you want to RESTART merge process "_$PIECE(^VA(15.2,XDRFDA,0),U)
SET DIR("B")="NO"
+7 DO ^DIR
KILL DIR
if Y'>0
QUIT
+8 SET ZTRTN="DQ^XDRMERG0"
SET ZTSAVE("XDRFDA")=""
SET ZTIO="NULL"
+9 DO ^%ZTLOAD
IF '$DATA(ZTSK)
WRITE !!,$CHAR(7),"RESTART **NOT** QUEUED"
QUIT
+10 ; SET TASK NUMBER AND REMOVE HALT FLAG IF SET
SET $PIECE(^VA(15.2,XDRFDA,0),U,8,9)=ZTSK_U
+11 WRITE !,"Restart queued as task ",ZTSK,!
End DoDot:1
+12 IF NC'>0
WRITE !!,$CHAR(7),"No merge processes found that needed restarting.",!!
+13 QUIT
+14 ;
+15 ;
DOSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
+1 NEW NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
+2 ; DEBUG STATEMENT
NEW XDRAA,XDRZZ
+3 ;;LLS 17-OCT-2013 - my new arrays and NODEB was not NEWed and thought it should be
NEW XDRALY1,XDRALY2,XDRALY1,XDRALY2,XDRALY1A,XDRALY2A,XDRDUPAF,XDRDUPAT,XDRALYSS,XDRALYNM,XDR1,NODEB
+4 SET SFILE=+$PIECE($GET(@(XDRFROM_"0)")),U,2)
+5 ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
IF SFILE'>0
QUIT
+6 ;
+7 ;LLS 17-OCT-2013 added this section to setup arrays for fix duplicate (same Name & Social Security Number) aliases being merged:
+8 IF $GET(FILE)=2
IF SFILE="2.01"
Begin DoDot:1
+9 ;Put 'FROM' patient ALIAS data into XDRALY1 array
DO GETS^DIQ(FILE,$PIECE(XDRGID,U,2)_",","1*","","XDRALY1")
+10 ;strip first subscript
MERGE XDRALY1A=XDRALY1(SFILE)
+11 ;Put 'TO' patient ALIAS data into XDRALY2 array
DO GETS^DIQ(FILE,$PIECE(XDRGID,U,3)_",","1*","","XDRALY2")
+12 ;strip first subscript
MERGE XDRALY2A=XDRALY2(SFILE)
+13 ;Create new 'FROM' patient alias array subscripted by NAME^SSN
SET XDR1=""
FOR
SET XDR1=$ORDER(XDRALY1A(XDR1))
if XDR1=""
QUIT
Begin DoDot:2
+14 SET XDRALYSS=XDRALY1A(XDR1,1)
SET XDRALYNM=XDRALY1A(XDR1,.01)
+15 ;'FROM' array format: XDRDUPAF(NAME^SSN)=node
SET XDRDUPAF(XDRALYNM_U_XDRALYSS)=$PIECE(XDR1,",",1)
End DoDot:2
+16 ;Create new 'TO' patient alias array subscripted by NAME^SSN
SET XDR1=""
FOR
SET XDR1=$ORDER(XDRALY2A(XDR1))
if XDR1=""
QUIT
Begin DoDot:2
+17 SET XDRALYSS=XDRALY2A(XDR1,1)
SET XDRALYNM=XDRALY2A(XDR1,.01)
+18 ;'TO' array format: XDRDUPAT(NAME^SSN)=node
SET XDRDUPAT(XDRALYNM_U_XDRALYSS)=$PIECE(XDR1,",",1)
End DoDot:2
End DoDot:1
+19 ;LLS 17-OCT-2013 end of added section
+20 ;
+21 ; HANDLE WORD PROCESSING FIELDS
IF $PIECE($GET(^DD(SFILE,.01,0)),U,2)["W"
Begin DoDot:1
+22 NEW XF,XT
SET XT=$EXTRACT(XDRTO,1,$LENGTH(XDRTO)-1)_")"
+23 IF '$DATA(@XT)
Begin DoDot:2
+24 SET XF=$EXTRACT(XDRFROM,1,$LENGTH(XDRFROM)-1)_")"
+25 MERGE @XT=@XF
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
QUIT
+28 FOR NODEA=0:0
SET NODEA=$ORDER(@(XDRFROM_NODEA_")"))
if NODEA'>0
QUIT
Begin DoDot:1
+29 ;LLS 17-OCT-2013 - the following line of code was added to check patient alias multiple (file #2.01) and
+30 ; skip moving this alias because it already exists in the 'merge to' patient file.
+31 ; XDRDUPAF array contains 'FROM' file aliases and XDRDUPAT contains 'TO' file aliases
+32 ;LLS 17-OCT-2013 - added
IF SFILE=2.01
IF $DATA(XDRDUPAF($PIECE($GET(@(XDRFROM_NODEA_",0)"),"*"),U,1,2)))
IF $DATA(XDRDUPAT($PIECE($GET(@(XDRFROM_NODEA_",0)"),"*"),U,1,2)))
QUIT
+33 ; GET .01 VALUE
SET VALUE=$PIECE($GET(@(XDRFROM_NODEA_",0)")),U)
+34 NEW XDRDT
SET XDRDT=^DD(SFILE,.01,0)
+35 ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM
IF $PIECE(XDRDT,U,2)["D"
SET XDRDT=$PIECE(XDRDT,U,5,999)
SET XDRDINUM=$SELECT(XDRDT["DINUM":1,1:0)
IF XDRDINUM
SET XDRDT=0
DO DINUMDAT
if XDRDT
QUIT
+36 SET YVALUE=0
SET XVALUE=0
IF $DATA(^DD(SFILE,.001,0))
SET YVALUE=NODEA
IF $DATA(@(XDRTO_NODEA_")"))
SET XVALUE=YVALUE
+37 IF XVALUE=0
IF $PIECE(^DD(SFILE,.01,0),U,5,99)["DINUM"
IF $DATA(@(XDRTO_NODEA_")"))
SET XVALUE=NODEA
+38 ; FIND CURRENT ENTRY NUMBER, IF PRESENT
IF XVALUE=0
SET XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE)
+39 ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
IF XVALUE>0
Begin DoDot:2
+40 NEW X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
+41 SET NODE=""
+42 FOR
SET NODE=$ORDER(@(XDRFROM_NODEA_","""_NODE_""")"))
if NODE=""
QUIT
Begin DoDot:3
+43 IF $DATA(@(XDRFROM_NODEA_","""_NODE_""")"))'>1
QUIT
+44 SET NEWFROM=XDRFROM_NODEA_","""_NODE_""","
+45 SET NEWTO=XDRTO_XVALUE_","""_NODE_""","
+46 SET NEWTOIEN=XVALUE_","_IENTOSTR
+47 DO DOSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
End DoDot:3
End DoDot:2
QUIT
+48 KILL XDRYY
IF YVALUE>0
SET XDRYY(1)=YVALUE
+49 SET XENTOSTR="+1,"_IENTOSTR
+50 SET XDRFILTY=$PIECE($GET(^DD(SFILE,.01,0)),U,2)
+51 IF XDRFILTY["P"
SET VALUE="`"_VALUE
+52 IF XDRFILTY["V"
Begin DoDot:2
+53 NEW Y
SET Y=$PIECE(VALUE,";",2)
if Y=""
QUIT
+54 SET Y=$PIECE($GET(@("^"_Y_"0)")),U)
if Y=""
QUIT
+55 SET VALUE=Y_".`"_(+VALUE)
+56 QUIT
End DoDot:2
+57 ;use internal data for file 70.03
IF SFILE=70.03
SET XDRFILTY="D"
+58 IF XDRFILTY'["P"&(XDRFILTY'["V")
IF XDRFILTY'["D"
SET VALUE=$$GETEXT(XDRFROM,NODEA,SFILE)
+59 SET XDRXX(SFILE,XENTOSTR,.01)=VALUE
+60 IF $ORDER(^DD(SFILE,0,"ID",0))>0
Begin DoDot:2
+61 ;CODE FOR ADDING IDENTIFIERS
+62 NEW I,N,XDRFROM1,IENFR
+63 SET N=0
SET I=SFILE
FOR
SET I=$GET(^DD(I,0,"UP"))
if I'>0
QUIT
SET N=N+1
+64 SET XDRFROM1=$PIECE(XDRFROM,"(",2,99)
SET IENFR=NODEA_","
+65 FOR I=$LENGTH(XDRFROM1,",")-2:-2
if N'>0
QUIT
SET IENFR=IENFR_$PIECE(XDRFROM1,",",I)_","
SET N=N-1
+66 ;
+67 FOR XDRID=0:0
SET XDRID=$ORDER(^DD(SFILE,0,"ID",XDRID))
if XDRID'>0
QUIT
Begin DoDot:3
+68 SET N=$$GET1^DIQ(SFILE,IENFR,XDRID)
+69 IF N'=""
SET XDRXX(SFILE,XENTOSTR,XDRID)=N
+70 QUIT
End DoDot:3
+71 QUIT
End DoDot:2
+72 ;
+73 ; DEBUG STATEMENT
KILL XDRAA,XDRZZ
IF $DATA(XDRTESTK)
MERGE XDRAA=XDRXX
+74 ; DATES THAT ARE DINUMED HAVE BEEN HANDLED ABOVE, SO CAN PASS A DATE IN AS AN INTERNAL VALUE
+75 ; CREATE A NEW ENTRY IN IENTO FOR VALUE
DO UPDATE^DIE($SELECT(XDRFILTY["D":"",1:"E"),"XDRXX","XDRYY","XDRZZ")
+76 ; DEBUG STATEMENT
IF $DATA(XDRZZ)
IF $DATA(XDRTESTK)
IF SFILE'=2.0361
SET XDRTESTK=XDRTESTK+1
MERGE ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ
+77 SET NODEB=$GET(XDRYY(1))
IF NODEB'>0
QUIT
+78 MERGE @(XDRTO_NODEB_")")=@(XDRFROM_NODEA_")")
+79 SET DIK=XDRTO
SET DA=NODEB
Begin DoDot:2
+80 FOR I=1:1
SET DA(I)=$PIECE(XDRDASEQ,U,I)
IF DA(I)=""
KILL DA(I)
QUIT
End DoDot:2
+81 IF SFILE=55.06
NEW DIU
SET DIU(0)=1
FOR DIK(1)=".01^B","10^AUDS","34^AUD","64^AUDDD","7^ACR1"
DO EN1^DIK
+82 IF SFILE'=55.06
NEW DIU
SET DIU(0)=1
DO IX^DIK
End DoDot:1
+83 QUIT
+84 ;
GETEXT(DICA,DA,FILNUM) ; GET EXTERNAL VALUE FOR .01 FIELD
+1 NEW DIC,DIQ,DR,XDRQ
+2 SET DIC=DICA
SET DIC("P")=FILNUM
SET DR=.01
SET DIQ="XDRQ"
SET DIQ(0)="E"
+3 DO EN^DIQ1
+4 QUIT $GET(XDRQ(FILNUM,DA,.01,"E"))
+5 ;
DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
+1 NEW NEWVAL,NODETO
+2 SET NODETO=NODEA
+3 IF $DATA(@(XDRTO_NODEA_")"))
if (SFILE'=63.04)
QUIT
Begin DoDot:1
+4 SET NEWVAL=VALUE
+5 FOR
if '$DATA(@(XDRTO_NODETO_")"))
QUIT
SET NODETO=NODETO-.000001
SET NEWVAL=NEWVAL+.000001
End DoDot:1
+6 MERGE @(XDRTO_NODETO_")")=@(XDRFROM_NODEA_")")
+7 IF $DATA(NEWVAL)
SET $PIECE(@(XDRTO_NODETO_",0)"),U)=NEWVAL
+8 SET DIK=XDRTO
SET DA=NODEA
Begin DoDot:1
+9 FOR I=1:1
SET DA(I)=$PIECE(XDRDASEQ,U,I)
IF DA(I)=""
KILL DA(I)
QUIT
End DoDot:1
DO IX^DIK
+10 SET XDRDT=1
+11 QUIT
+12 ;
DODIS ; CODE TO HANDLE DISPOSITION ENTRIES IN PATIENT FILE
+1 NEW XDRI,DA,DIK
+2 FOR XDRI=0:0
SET XDRI=$ORDER(@(XDRDIC_IENFROM_",""DIS"","_XDRI_")"))
if XDRI'>0
QUIT
Begin DoDot:1
+3 IF $DATA(@(XDRDIC_IENTO_",""DIS"","_XDRI_")"))
QUIT
+4 MERGE @(XDRDIC_IENTO_",""DIS"","_XDRI_")")=@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")
+5 SET DA=XDRI
SET DA(1)=IENTO
SET DIK=XDRDIC_IENTO_",""DIS"","
DO IX^DIK
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
