XDRMERG0 ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;04/28/2005 12:11
;;7.3;TOOLKIT;**23,36,43,49,83,95**;Apr 25, 1995
;;
; Covered Under DBIA's (#2710, #2796, #3765)
;
Q
QUE ; This is the entry point for queueing a merge process
;
D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary
;
G QUE^XDRMERGB ; CODE MOVED TO KEEP DOWN SIZE OF ROUTINE
;
DQ ; This is the entry point for actually processing the merge task
; Either as the initial entry or on restart.
;
N XDRZZZ,XDRFILE,XDRPACK,XDRPACKN,XDRSFILE,XDRFDA1,XDRPACKN
N XDRROU,XDRCODE,XDRGLOB,XDRDVALF,DIQUIET,RGRSICN,XDRTIME
S XDRDVALF=1,XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ
S DIQUIET=1,RGRSICN=1
;
I $$NEWERR^%ZTER() N $ETRAP,$ESTACK S $ETRAP="D ERR^XDRMERG0"
E S X="ERR^XDRMERG0",@^%ZOSF("TRAP")
S XDRGLOB=^DIC($P(^VA(15.2,XDRFDA,0),U,2),0,"GL"),XDRGLOB=";"_$E(XDRGLOB,2,$L(XDRGLOB)),XDRTIME=$P(^VA(15.1,$P(^VA(15.2,XDRFDA,0),U,2),1),U,3)
F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0 S X=^(I,0) D
. S @XDRZZZ@(+X,$P(X,U,2),((+X)_XDRGLOB),$P(X,U,2)_XDRGLOB)=$P(X,U,3) ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE
. ;
. ; THE FOLLOWING LINES OF CODE ADDED TO TAKE CARE OF RESTARTS IN WHICH THE LABORATORY POINTERS ARE IN AN INTERMEDIATE STATE PRIOR TO COMPLETION - JLI 03-22-99
. ; DURING THE MERGE PROCESS THE ^LR( ENTRY IS SET TO SIMPLY THE LRIEN VALUE AND A -9 NODE ADDED,
. ; AT THE END OF LAB MERGE PROCESSING, THE FROM PATIENT ENTRY HAS ITS LR VALUE SET TO THE LRIEN FOR THE TO ENTRY
. ; WHICH IS PRESENT UNTIL THE PATIENT ENTRIES ARE MERGED. IF THE MERGE IS STOPPED PRIOR TO THE LABORATORY
. ; PROCESSING BEING MARKED COMPLETE, ON RE-ENTRY INTO THE LAB PROCESSING PAIRS WITH THE FROM ENTRY LAB DATA LEFT
. ; IN EITHER OF THE ABOVE STATES ARE EXCLUDED FROM THE MERGE.
. ; THE FOLLOWING CODE RESTORES THE CORRECT LRIEN POINTER AND LR(LRIEN,0) NODE FOR THE FROM VALUES
. ;
. I XDRGLOB=";DPT(",$D(^DPT(+X,"LR")) D
. . N TO,LR,FROMVAR S TO=$P(X,U,2),LR=^DPT(+X,"LR"),LR=$G(^LR(LR,0)) I $P(LR,U,2)=2,$P(LR,U,3)=+X Q
. . I ($P(LR,U,2)=""&($P(LR,U,3)=""))!($P(LR,U,2)=2&($P(LR,U,3)=TO)) D
. . . N DA F DA=0:0 S DA=$O(^XDRM("B",((+X)_XDRGLOB),DA)) Q:DA'>0 S LR=^XDRM(DA,1,1,0) I LR["LAB DATA" S LR=$P(LR,U,2) I LR>0 S ^DPT(+X,"LR")=LR,^LR(LR,0)=LR_U_"2"_U_(+X) K ^LR(LR,-9) Q
. ; END OF CODE ADDITION FOR LAB POINTER PROBLEM
;
; DO DATA CHECKING BEFORE STARTING MERGE
;
I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
S XDRPRE=1 D
. S XDRFDA1=$$ADDSPECL("DATA CHECKING")
. I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
. S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"
. D ENPAIR^XDRDVAL1($P(^VA(15.2,XDRFDA,0),U,2),XDRZZZ,XDRFDA) ; CHECK FOR DATA VALIDITY PROBLEMS, REMOVE ANY PAIRS THAT HAVE PROBLEMS
. D CHKFROM^XDRMERG2(XDRZZZ,$P(^VA(15.2,XDRFDA,0),U,2))
. I '$D(@XDRZZZ) D
. . D SETCOMPL ; MARK DATA CHECKING COMPLETE
. . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL
. . S XDRFDA1=$$ADDSPECL("**STOPPED**")
. . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS
. D SETCOMPL
. Q
;
I '$D(@XDRZZZ) Q
S XDRFILE=$P(^VA(15.2,XDRFDA,0),U,2) Q:XDRFILE'>0
I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
E S I=$P(^VA(15.2,XDRFDA,0),U,7),$P(^(0),U,4,7)="A"_U_$$NOW^XLFDT()_U_U_(I+1)
;
; PROCESS ANY SPECIAL HANDLING INDICATED FOR PACKAGES
;
F XDRPACK=0:0 S XDRPACK=$O(^DIC(9.4,XDRPACK)) Q:XDRPACK'>0 D Q:'$D(@XDRZZZ)
. F XDRSFILE=0:0 S XDRSFILE=$O(^DIC(9.4,XDRPACK,20,XDRSFILE)) Q:XDRSFILE'>0 D Q:'$D(@XDRZZZ)
. . I $P(^DIC(9.4,XDRPACK,20,XDRSFILE,0),U)=XDRFILE D
. . . S X=^DIC(9.4,XDRPACK,20,XDRSFILE,0)
. . . S XDRPACKN=$P(^DIC(9.4,XDRPACK,0),U)
. . . S XDRROU=$P(X,U,2,3)
. . . S XDRCODE=$G(^DIC(9.4,XDRPACK,20,XDRSFILE,1))
. . . S XDRFDA1=$$ADDSPECL(XDRPACKN)
. . . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
. . . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"_ZTSK_U_XDRROU
. . . D DQ1
. . . I '$D(@XDRZZZ) D
. . . . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL
. . . . S XDRFDA1=$$ADDSPECL("**STOPPED**")
. . . . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS
K XDRPRE
;
; Mark completed and quit if no pairs are left
;
I '$D(@XDRZZZ) S $P(^VA(15.2,XDRFDA,0),U,4)="C",$P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT() Q
;
; NOW PROCESS THE MAIN FILE AND ITS DEPENDENCIES
;
I '$D(ZTSTOP) D
. S XDRFDA1=$$ADDSPECL($P(^DIC(XDRFILE,0),U)_" FILE")
. I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
. S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
. S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
. S X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
. S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4)
. ;
. I XDRCSTAT'="" Q
. I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
;
I '$D(ZTSTOP) D
. S XDRFDA2=XDRFDA1
. F S XDRFDA1=$O(^VA(15.2,XDRFDA,3,XDRFDA1)) Q:XDRFDA1'>0 D
. . S ZTRTN="RETHREAD^XDRMERG0",ZTIO="",ZTDESC="MERGE THREAD"
. . S ZTSAVE("XDRFDA")="",ZTSAVE("XDRFDA1")="",ZTDTH=$$NOW^XLFDT()
. . D ^%ZTLOAD
. I $P(^VA(15.2,XDRFDA,3,XDRFDA2,0),U,3)="C" Q
. S XDRFDA1=XDRFDA2 K XDRTHRED F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,XDRFDA1,2,I)) Q:I'>0 S J=^(I,0) S XDRTHRED(J)=""
. S ^VA(15.2,XDRFDA,1)=$$NOW^XLFDT()
. D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),XDRCSTAT,XDRCFIL,XDRCENT)
;
I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,0),U,4)="H"
E D SETCOMPL
Q
;
DQTHREAD ; START POINT FOR EXTRA THREADS
N XDRNAME,XDRFDA1,I,X,XDRZZZ,XDRTIME
S XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ
;
S XDRFILE=$P($G(^VA(15.2,XDRFDA,0)),U,2) Q:XDRFILE'>0
S XDRTIME=$P(^VA(15.1,$P(^VA(15.2,XDRFDA,0),U,2),1),U,3)
S XDRNAME=" THREAD "_XDRTHRED
S XDRFDA1=$$ADDSPECL(XDRNAME)
I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
S XDRGLOB=^DIC($P(^VA(15.2,XDRFDA,0),U,2),0,"GL"),XDRGLOB=";"_$E(XDRGLOB,2,$L(XDRGLOB))
F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0 S X=^(I,0) D
. ; S @XDRZZZ@(+X,+$P(X,U,2))=$P(X,U,3) ; ORIGINAL VERSION WITH 2 SUBSCRIPTS
. S @XDRZZZ@(+X,$P(X,U,2),((+X)_XDRGLOB),$P(X,U,2)_XDRGLOB)=$P(X,U,3) ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE
F I=0:0 S I=$O(XDRTHRED(I)) Q:I'>0 D
. S ^VA(15.2,XDRFDA,3,XDRFDA1,2,I,0)=I
S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,1))
S XDRCFIL=+$P(X,U,3),XDRCENT=+$P(X,U,4)
D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),3,XDRCFIL,XDRCENT)
I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
E D SETCOMPL
Q
;
RETHREAD ; RESTART THREADS
N I
K XDRTHRED
F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,XDRFDA1,2,I)) Q:I'>0 S J=^(I,0),XDRTHRED(J)=""
S XDRTHRED=$P($P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U)," THREAD ",2)
D DQTHREAD
Q
;
DQ1 ; HANDLE MERGE OF SPECIAL FILES
N X,XDRROU
S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,0))
I $P(X,U,3)="C" Q
S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
S X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4)
S XDRROU=$P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,8,9) Q:XDRROU=""
I $P(XDRROU,U)="" S XDRROU="EN"_XDRROU
D @(XDRROU_"(XDRZZZ)")
I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
E D SETCOMPL
Q
;
SETCOMPL ; Indicate that a component of the process was completed
;
S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,5)=$$NOW^XLFDT()
S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
K ^VA(15.2,XDRFDA,3,XDRFDA1,1)
S J=1 F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,I)) Q:I'>0 I $P(^(I,0),U,3)'="C" S J=0 Q
I J=1,+$G(XDRPRE)=0 D ; All threads have completed
. S $P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT()
. S $P(^VA(15.2,XDRFDA,0),U,4)="C"
. F XDRXX=0:0 S XDRXX=$O(@XDRZZZ@(XDRXX)) Q:XDRXX'>0 D
. . S XDRYY=$O(@XDRZZZ@(XDRXX,0)),XDRY1=$O(@XDRZZZ@(XDRXX,XDRYY,"")),XDRY2=$O(@XDRZZZ@(XDRXX,XDRYY,XDRY1,""))
. . S XDRK=@XDRZZZ@(XDRXX,XDRYY,XDRY1,XDRY2)
. . N XDRAA S XDRAA(15,(XDRK_","),.05)=2
. . D UPDATE^DIE("","XDRAA")
. . ;
. . ; recalc CMOR scores on newly merged TO record
. . I XDRY2[";DPT(",$T(CALC^RGVCCMR2)]"" D
. . . N RGDFN S RGDFN=XDRYY D CALC^RGVCCMR2
. . . ; create an A31 message for newly merged TO record
. . . S ERR=$$A31^MPIFA31B(XDRYY)
. . . I +ERR<0 D START^RGHLLOG(),EXC^RGHLLOG(208,"Error returned while building A31 after merge (DFN="_XDRYY_") ERROR="_$P(ERR,"^",2),XDRYY),STOP^RGHLLOG()
. S (FILE,XDRFILE)=$P(^VA(15.2,XDRFDA,0),U,2)
. S FROM=$NA(^TMP("XDRFROM",$J))
. D CLOSEIT^XDRMERG
. D SNDMSG^XDRMERGB(XDRFDA)
Q
;
ADDSPECL(PACKAGE) ; Add a package identifier to merge process
; if already present, simply return the internal entry number
; (it would be present if re-starting)
;
N Y,XDRZZ,XDRXX
S Y=$$FIND1^DIC(15.23,","_XDRFDA_",","Q",PACKAGE)
I Y'>0 D
. S XDRZZ(15.23,"+1,"_XDRFDA_",",.01)=PACKAGE
. D UPDATE^DIE("","XDRZZ","XDRXX")
. S Y=XDRXX(1)
Q +Y
;
;
ERR ; On an error mark status as error, and save the error message
;
S XDRZE=$ZE
D ^%ZTER
I $D(XDRFDA),$D(XDRFDA1) D
. S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="E",^(2)=XDRZE
G UNWIND^%ZTER
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMERG0 9221 printed Apr 09, 2024@21:44:58 Page 2
XDRMERG0 ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;04/28/2005 12:11
+1 ;;7.3;TOOLKIT;**23,36,43,49,83,95**;Apr 25, 1995
+2 ;;
+3 ; Covered Under DBIA's (#2710, #2796, #3765)
+4 ;
+5 QUIT
QUE ; This is the entry point for queueing a merge process
+1 ;
+2 ; update verified and/or ready to merge statuses if necessary
DO EN^XDRVCHEK
+3 ;
+4 ; CODE MOVED TO KEEP DOWN SIZE OF ROUTINE
GOTO QUE^XDRMERGB
+5 ;
DQ ; This is the entry point for actually processing the merge task
+1 ; Either as the initial entry or on restart.
+2 ;
+3 NEW XDRZZZ,XDRFILE,XDRPACK,XDRPACKN,XDRSFILE,XDRFDA1,XDRPACKN
+4 NEW XDRROU,XDRCODE,XDRGLOB,XDRDVALF,DIQUIET,RGRSICN,XDRTIME
+5 SET XDRDVALF=1
SET XDRZZZ=$NAME(^TMP("XDRFROM",$JOB))
KILL @XDRZZZ
+6 SET DIQUIET=1
SET RGRSICN=1
+7 ;
+8 IF $$NEWERR^%ZTER()
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^XDRMERG0"
+9 IF '$TEST
SET X="ERR^XDRMERG0"
SET @^%ZOSF("TRAP")
+10 SET XDRGLOB=^DIC($PIECE(^VA(15.2,XDRFDA,0),U,2),0,"GL")
SET XDRGLOB=";"_$EXTRACT(XDRGLOB,2,$LENGTH(XDRGLOB))
SET XDRTIME=$PIECE(^VA(15.1,$PIECE(^VA(15.2,XDRFDA,0),U,2),1),U,3)
+11 FOR I=0:0
SET I=$ORDER(^VA(15.2,XDRFDA,2,I))
if I'>0
QUIT
SET X=^(I,0)
Begin DoDot:1
+12 ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE
SET @XDRZZZ@(+X,$PIECE(X,U,2),((+X)_XDRGLOB),$PIECE(X,U,2)_XDRGLOB)=$PIECE(X,U,3)
+13 ;
+14 ; THE FOLLOWING LINES OF CODE ADDED TO TAKE CARE OF RESTARTS IN WHICH THE LABORATORY POINTERS ARE IN AN INTERMEDIATE STATE PRIOR TO COMPLETION - JLI 03-22-99
+15 ; DURING THE MERGE PROCESS THE ^LR( ENTRY IS SET TO SIMPLY THE LRIEN VALUE AND A -9 NODE ADDED,
+16 ; AT THE END OF LAB MERGE PROCESSING, THE FROM PATIENT ENTRY HAS ITS LR VALUE SET TO THE LRIEN FOR THE TO ENTRY
+17 ; WHICH IS PRESENT UNTIL THE PATIENT ENTRIES ARE MERGED. IF THE MERGE IS STOPPED PRIOR TO THE LABORATORY
+18 ; PROCESSING BEING MARKED COMPLETE, ON RE-ENTRY INTO THE LAB PROCESSING PAIRS WITH THE FROM ENTRY LAB DATA LEFT
+19 ; IN EITHER OF THE ABOVE STATES ARE EXCLUDED FROM THE MERGE.
+20 ; THE FOLLOWING CODE RESTORES THE CORRECT LRIEN POINTER AND LR(LRIEN,0) NODE FOR THE FROM VALUES
+21 ;
+22 IF XDRGLOB=";DPT("
IF $DATA(^DPT(+X,"LR"))
Begin DoDot:2
+23 NEW TO,LR,FROMVAR
SET TO=$PIECE(X,U,2)
SET LR=^DPT(+X,"LR")
SET LR=$GET(^LR(LR,0))
IF $PIECE(LR,U,2)=2
IF $PIECE(LR,U,3)=+X
QUIT
+24 IF ($PIECE(LR,U,2)=""&($PIECE(LR,U,3)=""))!($PIECE(LR,U,2)=2&($PIECE(LR,U,3)=TO))
Begin DoDot:3
+25 NEW DA
FOR DA=0:0
SET DA=$ORDER(^XDRM("B",((+X)_XDRGLOB),DA))
if DA'>0
QUIT
SET LR=^XDRM(DA,1,1,0)
IF LR["LAB DATA"
SET LR=$PIECE(LR,U,2)
IF LR>0
SET ^DPT(+X,"LR")=LR
SET ^LR(LR,0)=LR_U_"2"_U_(+X)
KILL ^LR(LR,-9)
QUIT
End DoDot:3
End DoDot:2
+26 ; END OF CODE ADDITION FOR LAB POINTER PROBLEM
End DoDot:1
+27 ;
+28 ; DO DATA CHECKING BEFORE STARTING MERGE
+29 ;
+30 IF $PIECE(^VA(15.2,XDRFDA,0),U,4)="S"
SET $PIECE(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
+31 SET XDRPRE=1
Begin DoDot:1
+32 SET XDRFDA1=$$ADDSPECL("DATA CHECKING")
+33 IF $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
QUIT
+34 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"
+35 ; CHECK FOR DATA VALIDITY PROBLEMS, REMOVE ANY PAIRS THAT HAVE PROBLEMS
DO ENPAIR^XDRDVAL1($PIECE(^VA(15.2,XDRFDA,0),U,2),XDRZZZ,XDRFDA)
+36 DO CHKFROM^XDRMERG2(XDRZZZ,$PIECE(^VA(15.2,XDRFDA,0),U,2))
+37 IF '$DATA(@XDRZZZ)
Begin DoDot:2
+38 ; MARK DATA CHECKING COMPLETE
DO SETCOMPL
+39 SET XDRFDA1=$$ADDSPECL("NO PAIRS LEFT")
DO SETCOMPL
+40 SET XDRFDA1=$$ADDSPECL("**STOPPED**")
+41 ; AND MAKE IT CLOSE WHOLE PROCESS
KILL XDRPRE
End DoDot:2
+42 DO SETCOMPL
+43 QUIT
End DoDot:1
+44 ;
+45 IF '$DATA(@XDRZZZ)
QUIT
+46 SET XDRFILE=$PIECE(^VA(15.2,XDRFDA,0),U,2)
if XDRFILE'>0
QUIT
+47 IF $PIECE(^VA(15.2,XDRFDA,0),U,4)="S"
SET $PIECE(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
+48 IF '$TEST
SET I=$PIECE(^VA(15.2,XDRFDA,0),U,7)
SET $PIECE(^(0),U,4,7)="A"_U_$$NOW^XLFDT()_U_U_(I+1)
+49 ;
+50 ; PROCESS ANY SPECIAL HANDLING INDICATED FOR PACKAGES
+51 ;
+52 FOR XDRPACK=0:0
SET XDRPACK=$ORDER(^DIC(9.4,XDRPACK))
if XDRPACK'>0
QUIT
Begin DoDot:1
+53 FOR XDRSFILE=0:0
SET XDRSFILE=$ORDER(^DIC(9.4,XDRPACK,20,XDRSFILE))
if XDRSFILE'>0
QUIT
Begin DoDot:2
+54 IF $PIECE(^DIC(9.4,XDRPACK,20,XDRSFILE,0),U)=XDRFILE
Begin DoDot:3
+55 SET X=^DIC(9.4,XDRPACK,20,XDRSFILE,0)
+56 SET XDRPACKN=$PIECE(^DIC(9.4,XDRPACK,0),U)
+57 SET XDRROU=$PIECE(X,U,2,3)
+58 SET XDRCODE=$GET(^DIC(9.4,XDRPACK,20,XDRSFILE,1))
+59 SET XDRFDA1=$$ADDSPECL(XDRPACKN)
+60 IF $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
QUIT
+61 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"_ZTSK_U_XDRROU
+62 DO DQ1
+63 IF '$DATA(@XDRZZZ)
Begin DoDot:4
+64 SET XDRFDA1=$$ADDSPECL("NO PAIRS LEFT")
DO SETCOMPL
+65 SET XDRFDA1=$$ADDSPECL("**STOPPED**")
+66 ; AND MAKE IT CLOSE WHOLE PROCESS
KILL XDRPRE
End DoDot:4
End DoDot:3
End DoDot:2
if '$DATA(@XDRZZZ)
QUIT
End DoDot:1
if '$DATA(@XDRZZZ)
QUIT
+67 KILL XDRPRE
+68 ;
+69 ; Mark completed and quit if no pairs are left
+70 ;
+71 IF '$DATA(@XDRZZZ)
SET $PIECE(^VA(15.2,XDRFDA,0),U,4)="C"
SET $PIECE(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT()
QUIT
+72 ;
+73 ; NOW PROCESS THE MAIN FILE AND ITS DEPENDENCIES
+74 ;
+75 IF '$DATA(ZTSTOP)
Begin DoDot:1
+76 SET XDRFDA1=$$ADDSPECL($PIECE(^DIC(XDRFILE,0),U)_" FILE")
+77 IF $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
QUIT
+78 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$GET(ZTSK)
+79 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
+80 SET X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
+81 SET XDRCSTAT=$PIECE(X,U,2)
SET XDRCFIL=$PIECE(X,U,3)
SET XDRCENT=$PIECE(X,U,4)
+82 ;
+83 IF XDRCSTAT'=""
QUIT
+84 IF $DATA(ZTSTOP)
SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
End DoDot:1
+85 ;
+86 IF '$DATA(ZTSTOP)
Begin DoDot:1
+87 SET XDRFDA2=XDRFDA1
+88 FOR
SET XDRFDA1=$ORDER(^VA(15.2,XDRFDA,3,XDRFDA1))
if XDRFDA1'>0
QUIT
Begin DoDot:2
+89 SET ZTRTN="RETHREAD^XDRMERG0"
SET ZTIO=""
SET ZTDESC="MERGE THREAD"
+90 SET ZTSAVE("XDRFDA")=""
SET ZTSAVE("XDRFDA1")=""
SET ZTDTH=$$NOW^XLFDT()
+91 DO ^%ZTLOAD
End DoDot:2
+92 IF $PIECE(^VA(15.2,XDRFDA,3,XDRFDA2,0),U,3)="C"
QUIT
+93 SET XDRFDA1=XDRFDA2
KILL XDRTHRED
FOR I=0:0
SET I=$ORDER(^VA(15.2,XDRFDA,3,XDRFDA1,2,I))
if I'>0
QUIT
SET J=^(I,0)
SET XDRTHRED(J)=""
+94 SET ^VA(15.2,XDRFDA,1)=$$NOW^XLFDT()
+95 DO RESTART^XDRMERG(XDRFILE,$NAME(^TMP("XDRFROM",$JOB)),XDRCSTAT,XDRCFIL,XDRCENT)
End DoDot:1
+96 ;
+97 IF $DATA(ZTSTOP)
SET $PIECE(^VA(15.2,XDRFDA,0),U,4)="H"
+98 IF '$TEST
DO SETCOMPL
+99 QUIT
+100 ;
DQTHREAD ; START POINT FOR EXTRA THREADS
+1 NEW XDRNAME,XDRFDA1,I,X,XDRZZZ,XDRTIME
+2 SET XDRZZZ=$NAME(^TMP("XDRFROM",$JOB))
KILL @XDRZZZ
+3 ;
+4 SET XDRFILE=$PIECE($GET(^VA(15.2,XDRFDA,0)),U,2)
if XDRFILE'>0
QUIT
+5 SET XDRTIME=$PIECE(^VA(15.1,$PIECE(^VA(15.2,XDRFDA,0),U,2),1),U,3)
+6 SET XDRNAME=" THREAD "_XDRTHRED
+7 SET XDRFDA1=$$ADDSPECL(XDRNAME)
+8 IF $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
QUIT
+9 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$GET(ZTSK)
+10 SET XDRGLOB=^DIC($PIECE(^VA(15.2,XDRFDA,0),U,2),0,"GL")
SET XDRGLOB=";"_$EXTRACT(XDRGLOB,2,$LENGTH(XDRGLOB))
+11 FOR I=0:0
SET I=$ORDER(^VA(15.2,XDRFDA,2,I))
if I'>0
QUIT
SET X=^(I,0)
Begin DoDot:1
+12 ; S @XDRZZZ@(+X,+$P(X,U,2))=$P(X,U,3) ; ORIGINAL VERSION WITH 2 SUBSCRIPTS
+13 ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE
SET @XDRZZZ@(+X,$PIECE(X,U,2),((+X)_XDRGLOB),$PIECE(X,U,2)_XDRGLOB)=$PIECE(X,U,3)
End DoDot:1
+14 FOR I=0:0
SET I=$ORDER(XDRTHRED(I))
if I'>0
QUIT
Begin DoDot:1
+15 SET ^VA(15.2,XDRFDA,3,XDRFDA1,2,I,0)=I
End DoDot:1
+16 SET X=$GET(^VA(15.2,XDRFDA,3,XDRFDA1,1))
+17 SET XDRCFIL=+$PIECE(X,U,3)
SET XDRCENT=+$PIECE(X,U,4)
+18 DO RESTART^XDRMERG(XDRFILE,$NAME(^TMP("XDRFROM",$JOB)),3,XDRCFIL,XDRCENT)
+19 IF $DATA(ZTSTOP)
SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
+20 IF '$TEST
DO SETCOMPL
+21 QUIT
+22 ;
RETHREAD ; RESTART THREADS
+1 NEW I
+2 KILL XDRTHRED
+3 FOR I=0:0
SET I=$ORDER(^VA(15.2,XDRFDA,3,XDRFDA1,2,I))
if I'>0
QUIT
SET J=^(I,0)
SET XDRTHRED(J)=""
+4 SET XDRTHRED=$PIECE($PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U)," THREAD ",2)
+5 DO DQTHREAD
+6 QUIT
+7 ;
DQ1 ; HANDLE MERGE OF SPECIAL FILES
+1 NEW X,XDRROU
+2 SET X=$GET(^VA(15.2,XDRFDA,3,XDRFDA1,0))
+3 IF $PIECE(X,U,3)="C"
QUIT
+4 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$GET(ZTSK)
+5 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
+6 SET X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
+7 SET XDRCSTAT=$PIECE(X,U,2)
SET XDRCFIL=$PIECE(X,U,3)
SET XDRCENT=$PIECE(X,U,4)
+8 SET XDRROU=$PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,8,9)
if XDRROU=""
QUIT
+9 IF $PIECE(XDRROU,U)=""
SET XDRROU="EN"_XDRROU
+10 DO @(XDRROU_"(XDRZZZ)")
+11 IF $DATA(ZTSTOP)
SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
+12 IF '$TEST
DO SETCOMPL
+13 QUIT
+14 ;
SETCOMPL ; Indicate that a component of the process was completed
+1 ;
+2 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,5)=$$NOW^XLFDT()
+3 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
+4 KILL ^VA(15.2,XDRFDA,3,XDRFDA1,1)
+5 SET J=1
FOR I=0:0
SET I=$ORDER(^VA(15.2,XDRFDA,3,I))
if I'>0
QUIT
IF $PIECE(^(I,0),U,3)'="C"
SET J=0
QUIT
+6 ; All threads have completed
IF J=1
IF +$GET(XDRPRE)=0
Begin DoDot:1
+7 SET $PIECE(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT()
+8 SET $PIECE(^VA(15.2,XDRFDA,0),U,4)="C"
+9 FOR XDRXX=0:0
SET XDRXX=$ORDER(@XDRZZZ@(XDRXX))
if XDRXX'>0
QUIT
Begin DoDot:2
+10 SET XDRYY=$ORDER(@XDRZZZ@(XDRXX,0))
SET XDRY1=$ORDER(@XDRZZZ@(XDRXX,XDRYY,""))
SET XDRY2=$ORDER(@XDRZZZ@(XDRXX,XDRYY,XDRY1,""))
+11 SET XDRK=@XDRZZZ@(XDRXX,XDRYY,XDRY1,XDRY2)
+12 NEW XDRAA
SET XDRAA(15,(XDRK_","),.05)=2
+13 DO UPDATE^DIE("","XDRAA")
+14 ;
+15 ; recalc CMOR scores on newly merged TO record
+16 IF XDRY2[";DPT("
IF $TEXT(CALC^RGVCCMR2)]""
Begin DoDot:3
+17 NEW RGDFN
SET RGDFN=XDRYY
DO CALC^RGVCCMR2
+18 ; create an A31 message for newly merged TO record
+19 SET ERR=$$A31^MPIFA31B(XDRYY)
+20 IF +ERR<0
DO START^RGHLLOG()
DO EXC^RGHLLOG(208,"Error returned while building A31 after merge (DFN="_XDRYY_") ERROR="_$PIECE(ERR,"^",2),XDRYY)
DO STOP^RGHLLOG()
End DoDot:3
End DoDot:2
+21 SET (FILE,XDRFILE)=$PIECE(^VA(15.2,XDRFDA,0),U,2)
+22 SET FROM=$NAME(^TMP("XDRFROM",$JOB))
+23 DO CLOSEIT^XDRMERG
+24 DO SNDMSG^XDRMERGB(XDRFDA)
End DoDot:1
+25 QUIT
+26 ;
ADDSPECL(PACKAGE) ; Add a package identifier to merge process
+1 ; if already present, simply return the internal entry number
+2 ; (it would be present if re-starting)
+3 ;
+4 NEW Y,XDRZZ,XDRXX
+5 SET Y=$$FIND1^DIC(15.23,","_XDRFDA_",","Q",PACKAGE)
+6 IF Y'>0
Begin DoDot:1
+7 SET XDRZZ(15.23,"+1,"_XDRFDA_",",.01)=PACKAGE
+8 DO UPDATE^DIE("","XDRZZ","XDRXX")
+9 SET Y=XDRXX(1)
End DoDot:1
+10 QUIT +Y
+11 ;
+12 ;
ERR ; On an error mark status as error, and save the error message
+1 ;
+2 SET XDRZE=$ZE
+3 DO ^%ZTER
+4 IF $DATA(XDRFDA)
IF $DATA(XDRFDA1)
Begin DoDot:1
+5 SET $PIECE(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="E"
SET ^(2)=XDRZE
End DoDot:1
+6 GOTO UNWIND^%ZTER
+7 ;
