208 lines
8.8 KiB
Mathematica
208 lines
8.8 KiB
Mathematica
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
|
|
;
|