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
 ;