Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XDRMERG0

XDRMERG0.m

Go to the documentation of this file. 
  1. 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
  1.  ;;
  1.  ; Covered Under DBIA's (#2710, #2796, #3765)
  1.  ;
  1.  Q
  1. QUE ; This is the entry point for queueing a merge process
  1.  ;
  1.  D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary
  1.  ;
  1.  G QUE^XDRMERGB ; CODE MOVED TO KEEP DOWN SIZE OF ROUTINE
  1.  ;
  1. DQ ; This is the entry point for actually processing the merge task
  1.  ; Either as the initial entry or on restart.
  1.  ;
  1.  N XDRZZZ,XDRFILE,XDRPACK,XDRPACKN,XDRSFILE,XDRFDA1,XDRPACKN
  1.  N XDRROU,XDRCODE,XDRGLOB,XDRDVALF,DIQUIET,RGRSICN,XDRTIME
  1.  S XDRDVALF=1,XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ
  1.  S DIQUIET=1,RGRSICN=1
  1.  ;
  1.  I $$NEWERR^%ZTER() N $ETRAP,$ESTACK S $ETRAP="D ERR^XDRMERG0"
  1.  E  S X="ERR^XDRMERG0",@^%ZOSF("TRAP")
  1.  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)
  1.  F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0  S X=^(I,0) D
  1.  . 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
  1.  . ;
  1.  . ; 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
  1.  . ; DURING THE MERGE PROCESS THE ^LR( ENTRY IS SET TO SIMPLY THE LRIEN VALUE AND A -9 NODE ADDED,
  1.  . ; AT THE END OF LAB MERGE PROCESSING, THE FROM PATIENT ENTRY HAS ITS LR VALUE SET TO THE LRIEN FOR THE TO ENTRY
  1.  . ; WHICH IS PRESENT UNTIL THE PATIENT ENTRIES ARE MERGED.  IF THE MERGE IS STOPPED PRIOR TO THE LABORATORY
  1.  . ; PROCESSING BEING MARKED COMPLETE, ON RE-ENTRY INTO THE LAB PROCESSING PAIRS WITH THE FROM ENTRY LAB DATA LEFT
  1.  . ; IN EITHER OF THE ABOVE STATES ARE EXCLUDED FROM THE MERGE.
  1.  . ; THE FOLLOWING CODE RESTORES THE CORRECT LRIEN POINTER AND LR(LRIEN,0) NODE FOR THE FROM VALUES
  1.  . ;
  1.  . I XDRGLOB=";DPT(",$D(^DPT(+X,"LR")) D
  1.  . . 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
  1.  . . I ($P(LR,U,2)=""&($P(LR,U,3)=""))!($P(LR,U,2)=2&($P(LR,U,3)=TO)) D
  1.  . . . 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
  1.  . ; END OF CODE ADDITION FOR LAB POINTER PROBLEM
  1.  ;
  1.  ; DO DATA CHECKING BEFORE STARTING MERGE
  1.  ;
  1.  I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
  1.  S XDRPRE=1 D
  1.  . S XDRFDA1=$$ADDSPECL("DATA CHECKING")
  1.  . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
  1.  . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"
  1.  . D ENPAIR^XDRDVAL1($P(^VA(15.2,XDRFDA,0),U,2),XDRZZZ,XDRFDA) ; CHECK FOR DATA VALIDITY PROBLEMS, REMOVE ANY PAIRS THAT HAVE PROBLEMS
  1.  . D CHKFROM^XDRMERG2(XDRZZZ,$P(^VA(15.2,XDRFDA,0),U,2))
  1.  . I '$D(@XDRZZZ) D
  1.  . . D SETCOMPL ; MARK DATA CHECKING COMPLETE
  1.  . . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL
  1.  . . S XDRFDA1=$$ADDSPECL("**STOPPED**")
  1.  . . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS
  1.  . D SETCOMPL
  1.  . Q
  1.  ;
  1.  I '$D(@XDRZZZ) Q
  1.  S XDRFILE=$P(^VA(15.2,XDRFDA,0),U,2) Q:XDRFILE'>0
  1.  I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A"
  1.  E  S I=$P(^VA(15.2,XDRFDA,0),U,7),$P(^(0),U,4,7)="A"_U_$$NOW^XLFDT()_U_U_(I+1)
  1.  ;
  1.  ; PROCESS ANY SPECIAL HANDLING INDICATED FOR PACKAGES
  1.  ;
  1.  F XDRPACK=0:0 S XDRPACK=$O(^DIC(9.4,XDRPACK)) Q:XDRPACK'>0  D  Q:'$D(@XDRZZZ)
  1.  . F XDRSFILE=0:0 S XDRSFILE=$O(^DIC(9.4,XDRPACK,20,XDRSFILE)) Q:XDRSFILE'>0  D  Q:'$D(@XDRZZZ)
  1.  . . I $P(^DIC(9.4,XDRPACK,20,XDRSFILE,0),U)=XDRFILE D
  1.  . . . S X=^DIC(9.4,XDRPACK,20,XDRSFILE,0)
  1.  . . . S XDRPACKN=$P(^DIC(9.4,XDRPACK,0),U)
  1.  . . . S XDRROU=$P(X,U,2,3)
  1.  . . . S XDRCODE=$G(^DIC(9.4,XDRPACK,20,XDRSFILE,1))
  1.  . . . S XDRFDA1=$$ADDSPECL(XDRPACKN)
  1.  . . . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
  1.  . . . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"_ZTSK_U_XDRROU
  1.  . . . D DQ1
  1.  . . . I '$D(@XDRZZZ) D
  1.  . . . . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL
  1.  . . . . S XDRFDA1=$$ADDSPECL("**STOPPED**")
  1.  . . . . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS
  1.  K XDRPRE
  1.  ;
  1.  ; Mark completed and quit if no pairs are left
  1.  ;
  1.  I '$D(@XDRZZZ) S $P(^VA(15.2,XDRFDA,0),U,4)="C",$P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT() Q
  1.  ;
  1.  ; NOW PROCESS THE MAIN FILE AND ITS DEPENDENCIES
  1.  ;
  1.  I '$D(ZTSTOP) D
  1.  . S XDRFDA1=$$ADDSPECL($P(^DIC(XDRFILE,0),U)_" FILE")
  1.  . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
  1.  . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
  1.  . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
  1.  . S X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
  1.  . S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4)
  1.  . ;
  1.  . I XDRCSTAT'="" Q
  1.  . I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
  1.  ;
  1.  I '$D(ZTSTOP) D
  1.  . S XDRFDA2=XDRFDA1
  1.  . F  S XDRFDA1=$O(^VA(15.2,XDRFDA,3,XDRFDA1)) Q:XDRFDA1'>0  D
  1.  . . S ZTRTN="RETHREAD^XDRMERG0",ZTIO="",ZTDESC="MERGE THREAD"
  1.  . . S ZTSAVE("XDRFDA")="",ZTSAVE("XDRFDA1")="",ZTDTH=$$NOW^XLFDT()
  1.  . . D ^%ZTLOAD
  1.  . I $P(^VA(15.2,XDRFDA,3,XDRFDA2,0),U,3)="C" Q
  1.  . 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)=""
  1.  . S ^VA(15.2,XDRFDA,1)=$$NOW^XLFDT()
  1.  . D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),XDRCSTAT,XDRCFIL,XDRCENT)
  1.  ;
  1.  I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,0),U,4)="H"
  1.  E  D SETCOMPL
  1.  Q
  1.  ;
  1. DQTHREAD ; START POINT FOR EXTRA THREADS
  1.  N XDRNAME,XDRFDA1,I,X,XDRZZZ,XDRTIME
  1.  S XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ
  1.  ;
  1.  S XDRFILE=$P($G(^VA(15.2,XDRFDA,0)),U,2) Q:XDRFILE'>0
  1.  S XDRTIME=$P(^VA(15.1,$P(^VA(15.2,XDRFDA,0),U,2),1),U,3)
  1.  S XDRNAME="  THREAD "_XDRTHRED
  1.  S XDRFDA1=$$ADDSPECL(XDRNAME)
  1.  I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q
  1.  S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
  1.  S XDRGLOB=^DIC($P(^VA(15.2,XDRFDA,0),U,2),0,"GL"),XDRGLOB=";"_$E(XDRGLOB,2,$L(XDRGLOB))
  1.  F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0  S X=^(I,0) D
  1.  . ; S @XDRZZZ@(+X,+$P(X,U,2))=$P(X,U,3) ; ORIGINAL VERSION WITH 2 SUBSCRIPTS
  1.  . 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
  1.  F I=0:0 S I=$O(XDRTHRED(I)) Q:I'>0  D
  1.  . S ^VA(15.2,XDRFDA,3,XDRFDA1,2,I,0)=I
  1.  S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,1))
  1.  S XDRCFIL=+$P(X,U,3),XDRCENT=+$P(X,U,4)
  1.  D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),3,XDRCFIL,XDRCENT)
  1.  I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
  1.  E  D SETCOMPL
  1.  Q
  1.  ;
  1. RETHREAD ; RESTART THREADS
  1.  N I
  1.  K XDRTHRED
  1.  F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,XDRFDA1,2,I)) Q:I'>0  S J=^(I,0),XDRTHRED(J)=""
  1.  S XDRTHRED=$P($P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U)," THREAD ",2)
  1.  D DQTHREAD
  1.  Q
  1.  ;
  1. DQ1 ; HANDLE MERGE OF SPECIAL FILES
  1.  N X,XDRROU
  1.  S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,0))
  1.  I $P(X,U,3)="C" Q
  1.  S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK)
  1.  S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT()
  1.  S X=^VA(15.2,XDRFDA,3,XDRFDA1,1)
  1.  S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4)
  1.  S XDRROU=$P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,8,9) Q:XDRROU=""
  1.  I $P(XDRROU,U)="" S XDRROU="EN"_XDRROU
  1.  D @(XDRROU_"(XDRZZZ)")
  1.  I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H"
  1.  E  D SETCOMPL
  1.  Q
  1.  ;
  1. SETCOMPL ; Indicate that a component of the process was completed
  1.  ;
  1.  S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,5)=$$NOW^XLFDT()
  1.  S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C"
  1.  K ^VA(15.2,XDRFDA,3,XDRFDA1,1)
  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
  1.  I J=1,+$G(XDRPRE)=0 D  ; All threads have completed
  1.  . S $P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT()
  1.  . S $P(^VA(15.2,XDRFDA,0),U,4)="C"
  1.  . F XDRXX=0:0 S XDRXX=$O(@XDRZZZ@(XDRXX)) Q:XDRXX'>0  D
  1.  . . S XDRYY=$O(@XDRZZZ@(XDRXX,0)),XDRY1=$O(@XDRZZZ@(XDRXX,XDRYY,"")),XDRY2=$O(@XDRZZZ@(XDRXX,XDRYY,XDRY1,""))
  1.  . . S XDRK=@XDRZZZ@(XDRXX,XDRYY,XDRY1,XDRY2)
  1.  . . N XDRAA S XDRAA(15,(XDRK_","),.05)=2
  1.  . . D UPDATE^DIE("","XDRAA")
  1.  . . ;
  1.  . . ;   recalc CMOR scores on newly merged TO record
  1.  . . I XDRY2[";DPT(",$T(CALC^RGVCCMR2)]"" D
  1.  . . . N RGDFN S RGDFN=XDRYY D CALC^RGVCCMR2
  1.  . . . ;   create an A31 message for newly merged TO record
  1.  . . . S ERR=$$A31^MPIFA31B(XDRYY)
  1.  . . . 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()
  1.  . S (FILE,XDRFILE)=$P(^VA(15.2,XDRFDA,0),U,2)
  1.  . S FROM=$NA(^TMP("XDRFROM",$J))
  1.  . D CLOSEIT^XDRMERG
  1.  . D SNDMSG^XDRMERGB(XDRFDA)
  1.  Q
  1.  ;
  1. ADDSPECL(PACKAGE) ; Add a package identifier to merge process
  1.  ;  if already present, simply return the internal entry number
  1.  ;  (it would be present if re-starting)
  1.  ;
  1.  N Y,XDRZZ,XDRXX
  1.  S Y=$$FIND1^DIC(15.23,","_XDRFDA_",","Q",PACKAGE)
  1.  I Y'>0 D
  1.  . S XDRZZ(15.23,"+1,"_XDRFDA_",",.01)=PACKAGE
  1.  . D UPDATE^DIE("","XDRZZ","XDRXX")
  1.  . S Y=XDRXX(1)
  1.  Q +Y
  1.  ;
  1.  ;
  1. ERR ; On an error mark status as error, and save the error message
  1.  ;
  1.  S XDRZE=$ZE
  1.  D ^%ZTER
  1.  I $D(XDRFDA),$D(XDRFDA1) D
  1.  . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="E",^(2)=XDRZE
  1.  G UNWIND^%ZTER
  1.  ;