XDRMERG2 ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ; [6/12/02 9:48am]
;;7.3;TOOLKIT;**23,38,40,42,46,62,137**;Apr 25, 1995;Build 11
;;
Q
;
; XDRXFLG is referenced in a few places, but not defined - it was
; used where it was set at the time the run started to identify
; entries which were referenced in one or more files and to
; remove them from a list of entries which were not referenced
; by any files within the database
;
DINUM(XVAL,XR,XDRIENS) ; FIND AND MERGE DINUMMED POINTERS
N IENOLD,IENNEW,FILEI,FLDJ,XREF,VREF
;
D SETVALS
F IENOLD=0:0 S IENOLD=$O(@FROM@(IENOLD)) Q:IENOLD'>0 D
. I '$D(@(XVAL_IENOLD_",0)")) Q
. I $D(XDRXFLG) S @FROM@(IENOLD,"R",FILEI)=$G(@FROM@(IENOLD,"R",FILEI))+1 Q ; POINTER WAS FOUND MARK ENTRY FOR FILE
. S IENNEW=$O(@FROM@(IENOLD,"")) Q:IENNEW'>0
. ; N I F I=IENOLD,IENNEW M @("^XDRM(I,""M"",FILEI,I)="_XVAL_I_")") ; OLD SAVE IMAGE BY SIMPLY MERGING
. D SAVEMERG^XDRMERGB(FILEI,IENOLD,IENNEW)
. I '$D(@(XVAL_IENNEW_",0)")) D
. . N DD,DO,DIC,X,DINUM,DA
. . S DIC=XVAL,DIC(0)="L",X=IENNEW,DINUM=IENNEW D FILE^DICN D:$D(^DD("IX","F",FILEI,FLDJ)) Q:Y'>0 ;LLS 09-DEC-2013 - Added the conditional 'Do' to handle .01, DIMUMed, new style cross references to the Patient file
. . . ;LLS - 09-DEC-2013 begin added section:
. . . ;need to get the new style cross reference key values from the "FROM" patient and move to the "TO" Patient
. . . N XDRINDSB,XDRFFLD,XDRFLDI,Y,XDRARR
. . . S XDRINDSB=$O(^DD("IX","F",FILEI,FLDJ,"")) ;INDEX file subscript
. . . S XDRFLDI="" F S XDRFLDI=$O(^DD("IX","F",FILEI,XDRFLDI)) Q:XDRFLDI="" D:$D(^DD("IX","F",FILEI,XDRFLDI,XDRINDSB)) ;XDRFLDI will hold the field number that we want to file
. . . . S XDRFFLD=$$GET1^DIQ(FILEI,IENOLD_",",XDRFLDI,"I") ;get internal value of the field from "FROM" patient
. . . . S:XDRFLDI=FLDJ XDRFFLD=IENNEW ;want the pointer to the patient file set to the "TO" IEN not the "FROM" IEN
. . . . S XDRARR(FILEI,IENNEW_",",XDRFLDI)=XDRFFLD D UPDATE^DIE("","XDRARR") ;Set the internal value into "TO" patient
. . . ;LLS - 09-DEC-2013 end added section
. D OVRWRI(FILEI,IENOLD,IENNEW)
. D MERGEIT(XVAL,IENOLD,IENNEW)
. D TIMSTAMP(2,FILEI,IENOLD)
Q
MERGEIT(XDRDIC,IENFROM,IENTO) ; MERGE TWO ENTRIES IN FILE
N NODE,NODE1,NODE2,NODEA,SFILE,XDRFROM,XDRTO,NODEA,VALUE,XVALUE,XDRXX,XDRYY,NODEB,DIK,DA,I,Y,VREF,XNN,XFILNO,IENTOSTR,DFN
;
D MERGEIT^XDRMERGB
Q
TIMSTAMP(PHASE,FILE,IEN) ;
S XDRYT=$$NOW^XLFDT()
I $$FMDIFF^XLFDT(XDRYT,+$G(XDRXT),2)>5 D
. I $D(XDRFDA) D I 1
. . S ^VA(15.2,XDRFDA,3,XDRFDA1,1)=XDRYT_U_PHASE_U_FILE_U_IEN
. E D
. . S ^XTMP("XDRSTAT",XDRGID,"TIME",$J)=XDRYT_U_PHASE_U_FILE_U_IEN
. S XDRXT=XDRYT
Q
XREFS(XVAL,XR,XDRIENS) ; FIND POINTERS BASED ON KNOWN X-REFS FOR FILE
D XREFS^XDRMERG1
Q
;
SETVALS ; IDENTIFY THE LOCATIONS OF POINTERS (NODE, PIECE, AND X-REF I ANY)
S FILEI=$O(^TMP($J,"XGLOB",XR,"")),FLDJ=$O(^TMP($J,"XGLOB",XR,FILEI,""))
S FILEI=^TMP($J,"XGLOB",XR,FILEI,FLDJ),FLDJ=+$P(FILEI,U,2)
S XREF=$P(FILEI,U,3),FILEI=+FILEI
S VREF="" I $P(^DD(FILEI,FLDJ,0),U,2)["V" S VREF=";"_$E(XDRFGLOB,2,99)
Q
;
DOMAIN(FILE,FROM) ; MERGE ACTUAL ENTRIES IN THE FILE (THE ONES POINTED TO)
N IENFROM,IENTO,XDRVAL,XDRIENS
I '$D(XDRTESTK) S XDRTESTK=0 S ^XTMP("XDRTESTK",0)=$$FMADD^XLFDT(DT,30)_U_DT ; DEBUG STATEMENT
S XFILNO=FILE
I $D(XDRXFLG) Q
S XDRIENS=""
S XDRDIC=$G(^DIC(FILE,0,"GL")) Q:XDRDIC=""
S IENFROM=0
F S IENFROM=$O(@FROM@(IENFROM)) Q:IENFROM'>0 D
. I '$D(@(XDRDIC_IENFROM_")")) Q
. S IENTO=$O(@FROM@(IENFROM,"")) Q:IENTO'>0
. I $D(@(XDRDIC_IENFROM_",-9)"))!$D(@(XDRDIC_IENTO_",-9)")) Q ; ALREADY MERGED
. S XDRVAL=$P($G(@(XDRDIC_IENFROM_",0)")),U)
. S XDRVAL=$P($G(@(XDRDIC_IENFROM_",0)")),U)
. I $E(XDRVAL,1,12)="MERGING INTO" D
. . N X S X=XDRVAL
. . F Q:X'["MERGING INTO" S X=$P(X,"(",2,99),X=$E(X,1,$L(X)-1)
. . S $P(@(XDRDIC_IENFROM_",0)"),U)=X
. . S XDRVAL=X
. D GETSSN ; GET SSN FOR SELECTED MAIN FILES
. S IENTO=$O(@FROM@(IENFROM,"")) Q:IENTO'>0 S DFN=IENTO D
. . ; N I F I=IENFROM,IENTO M @("^XDRM(I,""M"",FILE,I)="_XDRDIC_I_")") ; ORIGINAL VERSION SAVE IMAGE BY SIMPLY MERGING
. . D SAVEMERG^XDRMERGB(FILE,IENFROM,IENTO) ; SAVE IMAGE IN FM COMPATIBLE STRUCTURE
. . N XDRVAL
. . D OVRWRI(XFILNO,IENFROM,IENTO) ; LOOK FOR DATA TO BE OVERWRITTEN
. . D MERGEIT(XDRDIC,IENFROM,IENTO)
. S @(XDRDIC_IENFROM_",0)")=XDRVAL
. S @(XDRDIC_IENFROM_",-9)")=IENTO
. D SETALIAS ; SET UP ALIAS ENTRY IN SELECTED FILES
. N VALUE,XDRXX,XDRYY
. S VALUE=$$FIND1^DIC(15.3,",","Q",FILE)
. I VALUE'>0 D
. . S XDRXX(15.3,"+1,",.01)=FILE
. . K XDRYY S XDRYY(1)=FILE
. . D UPDATE^DIE("","XDRXX","XDRYY")
. K XDRXX,XDRYY
. S XDRXX(15.31,"+1,"_FILE_",",.01)=IENFROM
. S XDRXX(15.31,"+1,"_FILE_",",.02)=IENTO
. D UPDATE^DIE("","XDRXX","XDRYY","XDRMM")
. D TIMSTAMP(1,FILE,IENFROM)
Q
;
CHKFROM(FROM,FILE) ;
D CHKFROM^XDRMERGC(FROM,FILE)
Q
;
GETSSN ; For files 2 and 200, get SSN value for XDRFROM entry
I FILE=2 S XDRVAL("SSN")=$P(^DPT(IENFROM,0),U,9) Q
I FILE=200 S XDRVAL("SSN")=$P(^VA(200,IENFROM,1),U,9) Q
Q
;
OVRWRI(FILE,IENFR,IENTO) ;
N XNI,XDRARR,XDRARR1,IENSF,I,XNN,IENA,IENB ; THIS WOULD BE ONLY TOP LEVEL
;
S IENA=$O(@FROM@(IENFR,IENTO,"")) Q:IENA=""
S IENB=$O(@FROM@(IENFR,IENTO,IENA,"")) Q:IENB=""
S XNN=@FROM@(IENFR,IENTO,IENA,IENB) Q:XNN'>0
S XNI="",IENSF=IENFR_","
F I=0:0 S I=$O(^VA(15,XNN,3,FILE,1,I)) Q:I'>0 S XNI=XNI_^(I,0)_";"
I XNI'="" D
. D GETS^DIQ(FILE,IENSF,XNI,"I","XDRARR")
. F I=0:0 S I=$O(XDRARR(FILE,IENSF,I)) Q:I'>0 D
. . S XDRARR1(FILE,(IENTO_","),I)=XDRARR(FILE,IENSF,I,"I")
. I FILE=2!(FILE=200),$D(XDRARR1(FILE,(IENTO_","),$S(FILE=2:.09,1:9))) D
. . N IENST,XDRARR2 S IENST=IENTO_","
. . D GETS^DIQ(FILE,IENST,$S(FILE=2:.09,1:9),"I","XDRARR2")
. . I $D(XDRARR2(FILE,IENST,$S(FILE=2:.09,1:9),"I")) D
. . . S XDRARR1(FILE,IENSF,$S(FILE=2:.09,1:9))=XDRARR2(FILE,IENST,$S(FILE=2:.09,1:9),"I")
. . . Q
. . Q
. D FILE^DIE("","XDRARR1")
Q
SETALIAS ; For selected files place data into alias field of TO entry
N XDRARR
I FILE=2 D
. S XDRARR(2.01,"+1,"_IENTO_",",.01)=XDRVAL
. S XDRARR(2.01,"+1,"_IENTO_",",1)=XDRVAL("SSN")
. D UPDATE^DIE("","XDRARR")
I FILE=200 D
. S XDRARR(200.04,"+1,"_IENTO_",",.01)=XDRVAL
. D FILE^DIE("","XDRARR")
Q
;
CHKLOCAL ; CHECK STATUS FOR LOCAL MERGE PROCESSES (EVEN IF SOME DATA EXISTS IN MERGE PROCESS FILE)
N XJOB,X,N,XNAME,XSTAT,XDRFIL,DIRUT,CHKLOCAL
S CHKLOCAL=1,XDRFIL="^XTMP(""XDRSTAT"","
G CHK1
;
CHECK ;
N XJOB,X,N,M,BA,XNAME,XDRFIL,DIRUT,START,XDRFIL1,XDRFIL2
CHK1 ;
I '$D(CHKLOCAL) S XDRFIL=$S($O(^VA(15.2,0))>0:"^VA(15.2,",1:"^XTMP(""XDRSTAT"",")
S N=0,BA=""
W @IOF
S M=":" F S M=$O(@(XDRFIL_""""_M_""")"),-1) Q:M'>0 D
. I XDRFIL["VA(15.2",$P(^VA(15.2,M,0),U,4)="S" Q
. S XDRFIL1=$S(XDRFIL["VA":$NA(@(XDRFIL_M_")")),1:$NA(^XTMP("XDRSTAT",M)))
. S N=$S($D(^TMP($J,"BDT",N)):N+1,1:N) S XNAME="",XJOB="",N=N+1
. D ONESET(XDRFIL1,0)
. I XDRFIL["VA" D
. . F J=0:0 S J=$O(@XDRFIL1@(3,J)) Q:J'>0 D
. . . S XDRFIL2=$NA(@XDRFIL1@(3,J))
. . . D ONESET(XDRFIL2,1)
D HEADER
F N=0:0 S N=$O(^TMP($J,"BDT",N)) Q:N'>0 D Q:$D(DIRUT)
.I (IOSL-$Y)<6 D:IOST["C-" Q:$D(DIRUT) W @IOF,! D HEADER ;REM -9/25/96 page breaks
..W ! S DIR(0)="E" D ^DIR K DIR
. S XNAME=$P($G(^TMP($J,"BDT",N)),"~",2)
. S START=$P($G(^TMP($J,"BDT",N)),"~",3)
. S XJOB=$P($G(^TMP($J,"BDT",N)),"~",4)
. I BA'="",BA'=$P($G(START),"."),START'="" W !
. S BA=$P($G(START),".")
. S:XNAME["THREAD" XNAME=" "_XNAME
. W !,XNAME Q:XNAME="" I $L(XNAME)>18 W !
. S X=START D DATE8 W ?20,X," ",$P(^TMP($J,"BDT",N),"~") W:START="" !
. S X=$P(XJOB,U) I X'="" D DATE8 W ?36,X
. I X="" D
. . S X=$P(XJOB,U,2) D DATE8 W ?36,X
. . W ?50,$P(XJOB,U,3),?55,$P(XJOB,U,4),?64," ",$P(XJOB,U,5)
. . I $P(^TMP($J,"BDT",N),"~")="E" S N=N+1 W !?5,"ERROR: ",$E($P(^TMP($J,"BDT",N),"~"),1,230),!
K ^TMP($J,"BDT")
Q
;
W !,?55,"Current",?65,"Current"
W !,"Merge Set Start Stat Last Chk Phase File Entry",!
Q
;
DATE8 ;
N X1
I X="" S X=" " Q
S X1=X
S X=$E(X1,4,5)_"/"_$E(X1,6,7)_" "
S X1=$P(X1,".",2)_"000000"
S X=X_$E(X1,1,2)_":"_$E(X1,3,4)
Q
;
ONESET(FILE,SPECIAL) ;
N JOBNUM,JVAL
I FILE'["VA" S JVAL=0 F JOBNUM=0:0 S JOBNUM=$O(@FILE@("START",JOBNUM)) Q:JOBNUM'>0 S JVAL=JVAL+1 D LOOP
I FILE'["VA" Q
LOOP S N=N+1 I $D(^TMP($J,"BDT",N)) G LOOP
I 'SPECIAL S START=$S(FILE'["VA":@FILE@("START",JOBNUM),$P(@FILE@(0),U,5)>0:$P(^(0),U,5),1:$P(^(0),U,3)) I 1
I SPECIAL S START=$S($P(@FILE@(0),U,4)>0:$P(^(0),U,4),1:$P(^(0),U,2))
S XNAME=$S(XDRFIL'["VA":XJOB_" J"_JVAL_" ",'SPECIAL:$P(@FILE@(0),U),1:" "_$E($P(@FILE@(0),U),1,15))
I XDRFIL["VA" S ^TMP($J,"BDT",N)=$S('SPECIAL:$P(@FILE@(0),U,4),1:$P(@FILE@(0),U,3))
E S ^TMP($J,"BDT",N)=$S($D(@FILE@("DONE",JOBNUM)):"C",1:"A")
I ^TMP($J,"BDT",N)="E" S ^TMP($J,"BDT",N+1)=$G(@FILE@(2))
S XJOB=$S(XDRFIL'["VA":$G(@FILE@("DONE",JOBNUM)),'SPECIAL:$P(@FILE@(0),U,6),1:$P(@FILE@(0),U,5))
I XJOB="" D
. S XJOB=XJOB_U_$S(XDRFIL'["VA":$G(@FILE@("TIME",JOBNUM)),1:$G(@FILE@(1)))
. I XDRFIL'["VA"!SPECIAL,^TMP($J,"BDT",N)="A",$$FMDIFF^XLFDT($$NOW^XLFDT(),$P(XJOB,U,2),2)>43000 D
. . S ^TMP($J,"BDT",N)="U"
. . I XDRFIL["VA" D
. . . S $P(@FILE@(0),U,3)="U"
. I ^TMP($J,"BDT",N)="U",XDRFIL["VA",SPECIAL,$$FMDIFF^XLFDT($$NOW^XLFDT(),$P(XJOB,U,2),2)'>43000 S ^TMP($J,"BDT",N)="A",$P(@FILE@(0),U,3)="A"
S ^TMP($J,"BDT",N)=$P(^TMP($J,"BDT",N),"~")_"~"_XNAME_"~"_START_"~"_XJOB
Q
XDRMERG2 ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ; [6/12/02 9:48am]
+1 ;;7.3;TOOLKIT;**23,38,40,42,46,62,137**;Apr 25, 1995;Build 11
+2 ;;
+3 QUIT
+4 ;
+5 ; XDRXFLG is referenced in a few places, but not defined - it was
+6 ; used where it was set at the time the run started to identify
+7 ; entries which were referenced in one or more files and to
+8 ; remove them from a list of entries which were not referenced
+9 ; by any files within the database
+10 ;
DINUM(XVAL,XR,XDRIENS) ; FIND AND MERGE DINUMMED POINTERS
+1 NEW IENOLD,IENNEW,FILEI,FLDJ,XREF,VREF
+2 ;
+3 DO SETVALS
+4 FOR IENOLD=0:0
SET IENOLD=$ORDER(@FROM@(IENOLD))
IF IENOLD'>0
QUIT
Begin DoDot:1
+5 IF '$DATA(@(XVAL_IENOLD_",0)"))
QUIT
+6 ; POINTER WAS FOUND MARK ENTRY FOR FILE
IF $DATA(XDRXFLG)
SET @FROM@(IENOLD,"R",FILEI)=$GET(@FROM@(IENOLD,"R",FILEI))+1
QUIT
+7 SET IENNEW=$ORDER(@FROM@(IENOLD,""))
IF IENNEW'>0
QUIT
+8 ; N I F I=IENOLD,IENNEW M @("^XDRM(I,""M"",FILEI,I)="_XVAL_I_")") ; OLD SAVE IMAGE BY SIMPLY MERGING
+9 DO SAVEMERG^XDRMERGB(FILEI,IENOLD,IENNEW)
+10 IF '$DATA(@(XVAL_IENNEW_",0)"))
Begin DoDot:2
+11 NEW DD,DO,DIC,X,DINUM,DA
+12 ;LLS 09-DEC-2013 - Added the conditional 'Do' to handle .01, DIMUMed, new style cross references to the Patient file
SET DIC=XVAL
SET DIC(0)="L"
SET X=IENNEW
SET DINUM=IENNEW
DO FILE^DICN
IF $DATA(^DD("IX","F",FILEI,FLDJ))
Begin DoDot:3
+13 ;LLS - 09-DEC-2013 begin added section:
+14 ;need to get the new style cross reference key values from the "FROM" patient and move to the "TO" Patient
+15 NEW XDRINDSB,XDRFFLD,XDRFLDI,Y,XDRARR
+16 ;INDEX file subscript
SET XDRINDSB=$ORDER(^DD("IX","F",FILEI,FLDJ,""))
+17 ;XDRFLDI will hold the field number that we want to file
SET XDRFLDI=""
FOR
SET XDRFLDI=$ORDER(^DD("IX","F",FILEI,XDRFLDI))
IF XDRFLDI=""
QUIT
IF $DATA(^DD("IX","F",FILEI,XDRFLDI,XDRINDSB))
Begin DoDot:4
+18 ;get internal value of the field from "FROM" patient
SET XDRFFLD=$$GET1^DIQ(FILEI,IENOLD_",",XDRFLDI,"I")
+19 ;want the pointer to the patient file set to the "TO" IEN not the "FROM" IEN
IF XDRFLDI=FLDJ
SET XDRFFLD=IENNEW
+20 ;Set the internal value into "TO" patient
SET XDRARR(FILEI,IENNEW_",",XDRFLDI)=XDRFFLD
DO UPDATE^DIE("","XDRARR")
End DoDot:4
+21 ;LLS - 09-DEC-2013 end added section
End DoDot:3
IF Y'>0
QUIT
End DoDot:2
+22 DO OVRWRI(FILEI,IENOLD,IENNEW)
+23 DO MERGEIT(XVAL,IENOLD,IENNEW)
+24 DO TIMSTAMP(2,FILEI,IENOLD)
End DoDot:1
+25 QUIT
MERGEIT(XDRDIC,IENFROM,IENTO) ; MERGE TWO ENTRIES IN FILE
+1 NEW NODE,NODE1,NODE2,NODEA,SFILE,XDRFROM,XDRTO,NODEA,VALUE,XVALUE,XDRXX,XDRYY,NODEB,DIK,DA,I,Y,VREF,XNN,XFILNO,IENTOSTR,DFN
+2 ;
+3 DO MERGEIT^XDRMERGB
+4 QUIT
TIMSTAMP(PHASE,FILE,IEN) ;
+1 SET XDRYT=$$NOW^XLFDT()
+2 IF $$FMDIFF^XLFDT(XDRYT,+$GET(XDRXT),2)>5
Begin DoDot:1
+3 IF $DATA(XDRFDA)
Begin DoDot:2
+4 SET ^VA(15.2,XDRFDA,3,XDRFDA1,1)=XDRYT_U_PHASE_U_FILE_U_IEN
End DoDot:2
IF 1
+5 IF '$TEST
Begin DoDot:2
+6 SET ^XTMP("XDRSTAT",XDRGID,"TIME",$JOB)=XDRYT_U_PHASE_U_FILE_U_IEN
End DoDot:2
+7 SET XDRXT=XDRYT
End DoDot:1
+8 QUIT
XREFS(XVAL,XR,XDRIENS) ; FIND POINTERS BASED ON KNOWN X-REFS FOR FILE
+1 DO XREFS^XDRMERG1
+2 QUIT
+3 ;
SETVALS ; IDENTIFY THE LOCATIONS OF POINTERS (NODE, PIECE, AND X-REF I ANY)
+1 SET FILEI=$ORDER(^TMP($JOB,"XGLOB",XR,""))
SET FLDJ=$ORDER(^TMP($JOB,"XGLOB",XR,FILEI,""))
+2 SET FILEI=^TMP($JOB,"XGLOB",XR,FILEI,FLDJ)
SET FLDJ=+$PIECE(FILEI,U,2)
+3 SET XREF=$PIECE(FILEI,U,3)
SET FILEI=+FILEI
+4 SET VREF=""
IF $PIECE(^DD(FILEI,FLDJ,0),U,2)["V"
SET VREF=";"_$EXTRACT(XDRFGLOB,2,99)
+5 QUIT
+6 ;
DOMAIN(FILE,FROM) ; MERGE ACTUAL ENTRIES IN THE FILE (THE ONES POINTED TO)
+1 NEW IENFROM,IENTO,XDRVAL,XDRIENS
+2 ; DEBUG STATEMENT
IF '$DATA(XDRTESTK)
SET XDRTESTK=0
SET ^XTMP("XDRTESTK",0)=$$FMADD^XLFDT(DT,30)_U_DT
+3 SET XFILNO=FILE
+4 IF $DATA(XDRXFLG)
QUIT
+5 SET XDRIENS=""
+6 SET XDRDIC=$GET(^DIC(FILE,0,"GL"))
IF XDRDIC=""
QUIT
+7 SET IENFROM=0
+8 FOR
SET IENFROM=$ORDER(@FROM@(IENFROM))
IF IENFROM'>0
QUIT
Begin DoDot:1
+9 IF '$DATA(@(XDRDIC_IENFROM_")"))
QUIT
+10 SET IENTO=$ORDER(@FROM@(IENFROM,""))
IF IENTO'>0
QUIT
+11 ; ALREADY MERGED
IF $DATA(@(XDRDIC_IENFROM_",-9)"))!$DATA(@(XDRDIC_IENTO_",-9)"))
QUIT
+12 SET XDRVAL=$PIECE($GET(@(XDRDIC_IENFROM_",0)")),U)
+13 SET XDRVAL=$PIECE($GET(@(XDRDIC_IENFROM_",0)")),U)
+14 IF $EXTRACT(XDRVAL,1,12)="MERGING INTO"
Begin DoDot:2
+15 NEW X
SET X=XDRVAL
+16 FOR
IF X'["MERGING INTO"
QUIT
SET X=$PIECE(X,"(",2,99)
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+17 SET $PIECE(@(XDRDIC_IENFROM_",0)"),U)=X
+18 SET XDRVAL=X
End DoDot:2
+19 ; GET SSN FOR SELECTED MAIN FILES
DO GETSSN
+20 SET IENTO=$ORDER(@FROM@(IENFROM,""))
IF IENTO'>0
QUIT
SET DFN=IENTO
Begin DoDot:2
+21 ; N I F I=IENFROM,IENTO M @("^XDRM(I,""M"",FILE,I)="_XDRDIC_I_")") ; ORIGINAL VERSION SAVE IMAGE BY SIMPLY MERGING
+22 ; SAVE IMAGE IN FM COMPATIBLE STRUCTURE
DO SAVEMERG^XDRMERGB(FILE,IENFROM,IENTO)
+23 NEW XDRVAL
+24 ; LOOK FOR DATA TO BE OVERWRITTEN
DO OVRWRI(XFILNO,IENFROM,IENTO)
+25 DO MERGEIT(XDRDIC,IENFROM,IENTO)
End DoDot:2
+26 SET @(XDRDIC_IENFROM_",0)")=XDRVAL
+27 SET @(XDRDIC_IENFROM_",-9)")=IENTO
+28 ; SET UP ALIAS ENTRY IN SELECTED FILES
DO SETALIAS
+29 NEW VALUE,XDRXX,XDRYY
+30 SET VALUE=$$FIND1^DIC(15.3,",","Q",FILE)
+31 IF VALUE'>0
Begin DoDot:2
+32 SET XDRXX(15.3,"+1,",.01)=FILE
+33 KILL XDRYY
SET XDRYY(1)=FILE
+34 DO UPDATE^DIE("","XDRXX","XDRYY")
End DoDot:2
+35 KILL XDRXX,XDRYY
+36 SET XDRXX(15.31,"+1,"_FILE_",",.01)=IENFROM
+37 SET XDRXX(15.31,"+1,"_FILE_",",.02)=IENTO
+38 DO UPDATE^DIE("","XDRXX","XDRYY","XDRMM")
+39 DO TIMSTAMP(1,FILE,IENFROM)
End DoDot:1
+40 QUIT
+41 ;
CHKFROM(FROM,FILE) ;
+1 DO CHKFROM^XDRMERGC(FROM,FILE)
+2 QUIT
+3 ;
GETSSN ; For files 2 and 200, get SSN value for XDRFROM entry
+1 IF FILE=2
SET XDRVAL("SSN")=$PIECE(^DPT(IENFROM,0),U,9)
QUIT
+2 IF FILE=200
SET XDRVAL("SSN")=$PIECE(^VA(200,IENFROM,1),U,9)
QUIT
+3 QUIT
+4 ;
OVRWRI(FILE,IENFR,IENTO) ;
+1 ; THIS WOULD BE ONLY TOP LEVEL
NEW XNI,XDRARR,XDRARR1,IENSF,I,XNN,IENA,IENB
+2 ;
+3 SET IENA=$ORDER(@FROM@(IENFR,IENTO,""))
IF IENA=""
QUIT
+4 SET IENB=$ORDER(@FROM@(IENFR,IENTO,IENA,""))
IF IENB=""
QUIT
+5 SET XNN=@FROM@(IENFR,IENTO,IENA,IENB)
IF XNN'>0
QUIT
+6 SET XNI=""
SET IENSF=IENFR_","
+7 FOR I=0:0
SET I=$ORDER(^VA(15,XNN,3,FILE,1,I))
IF I'>0
QUIT
SET XNI=XNI_^(I,0)_";"
+8 IF XNI'=""
Begin DoDot:1
+9 DO GETS^DIQ(FILE,IENSF,XNI,"I","XDRARR")
+10 FOR I=0:0
SET I=$ORDER(XDRARR(FILE,IENSF,I))
IF I'>0
QUIT
Begin DoDot:2
+11 SET XDRARR1(FILE,(IENTO_","),I)=XDRARR(FILE,IENSF,I,"I")
End DoDot:2
+12 IF FILE=2!(FILE=200)
IF $DATA(XDRARR1(FILE,(IENTO_","),$SELECT(FILE=2:.09,1:9)))
Begin DoDot:2
+13 NEW IENST,XDRARR2
SET IENST=IENTO_","
+14 DO GETS^DIQ(FILE,IENST,$SELECT(FILE=2:.09,1:9),"I","XDRARR2")
+15 IF $DATA(XDRARR2(FILE,IENST,$SELECT(FILE=2:.09,1:9),"I"))
Begin DoDot:3
+16 SET XDRARR1(FILE,IENSF,$SELECT(FILE=2:.09,1:9))=XDRARR2(FILE,IENST,$SELECT(FILE=2:.09,1:9),"I")
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 DO FILE^DIE("","XDRARR1")
End DoDot:1
+20 QUIT
SETALIAS ; For selected files place data into alias field of TO entry
+1 NEW XDRARR
+2 IF FILE=2
Begin DoDot:1
+3 SET XDRARR(2.01,"+1,"_IENTO_",",.01)=XDRVAL
+4 SET XDRARR(2.01,"+1,"_IENTO_",",1)=XDRVAL("SSN")
+5 DO UPDATE^DIE("","XDRARR")
End DoDot:1
+6 IF FILE=200
Begin DoDot:1
+7 SET XDRARR(200.04,"+1,"_IENTO_",",.01)=XDRVAL
+8 DO FILE^DIE("","XDRARR")
End DoDot:1
+9 QUIT
+10 ;
CHKLOCAL ; CHECK STATUS FOR LOCAL MERGE PROCESSES (EVEN IF SOME DATA EXISTS IN MERGE PROCESS FILE)
+1 NEW XJOB,X,N,XNAME,XSTAT,XDRFIL,DIRUT,CHKLOCAL
+2 SET CHKLOCAL=1
SET XDRFIL="^XTMP(""XDRSTAT"","
+3 GOTO CHK1
+4 ;
CHECK ;
+1 NEW XJOB,X,N,M,BA,XNAME,XDRFIL,DIRUT,START,XDRFIL1,XDRFIL2
CHK1 ;
+1 IF '$DATA(CHKLOCAL)
SET XDRFIL=$SELECT($ORDER(^VA(15.2,0))>0:"^VA(15.2,",1:"^XTMP(""XDRSTAT"",")
+2 SET N=0
SET BA=""
+3 WRITE @IOF
+4 SET M=":"
FOR
SET M=$ORDER(@(XDRFIL_""""_M_""")"),-1)
IF M'>0
QUIT
Begin DoDot:1
+5 IF XDRFIL["VA(15.2"
IF $PIECE(^VA(15.2,M,0),U,4)="S"
QUIT
+6 SET XDRFIL1=$SELECT(XDRFIL["VA":$NAME(@(XDRFIL_M_")")),1:$NAME(^XTMP("XDRSTAT",M)))
+7 SET N=$SELECT($DATA(^TMP($JOB,"BDT",N)):N+1,1:N)
SET XNAME=""
SET XJOB=""
SET N=N+1
+8 DO ONESET(XDRFIL1,0)
+9 IF XDRFIL["VA"
Begin DoDot:2
+10 FOR J=0:0
SET J=$ORDER(@XDRFIL1@(3,J))
IF J'>0
QUIT
Begin DoDot:3
+11 SET XDRFIL2=$NAME(@XDRFIL1@(3,J))
+12 DO ONESET(XDRFIL2,1)
End DoDot:3
End DoDot:2
End DoDot:1
+13 DO HEADER
+14 FOR N=0:0
SET N=$ORDER(^TMP($JOB,"BDT",N))
IF N'>0
QUIT
Begin DoDot:1
+15 ;REM -9/25/96 page breaks
IF (IOSL-$Y)<6
IF IOST["C-"
Begin DoDot:2
+16 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:2
IF $DATA(DIRUT)
QUIT
WRITE @IOF,!
DO HEADER
+17 SET XNAME=$PIECE($GET(^TMP($JOB,"BDT",N)),"~",2)
+18 SET START=$PIECE($GET(^TMP($JOB,"BDT",N)),"~",3)
+19 SET XJOB=$PIECE($GET(^TMP($JOB,"BDT",N)),"~",4)
+20 IF BA'=""
IF BA'=$PIECE($GET(START),".")
IF START'=""
WRITE !
+21 SET BA=$PIECE($GET(START),".")
+22 IF XNAME["THREAD"
SET XNAME=" "_XNAME
+23 WRITE !,XNAME
IF XNAME=""
QUIT
IF $LENGTH(XNAME)>18
WRITE !
+24 SET X=START
DO DATE8
WRITE ?20,X," ",$PIECE(^TMP($JOB,"BDT",N),"~")
IF START=""
WRITE !
+25 SET X=$PIECE(XJOB,U)
IF X'=""
DO DATE8
WRITE ?36,X
+26 IF X=""
Begin DoDot:2
+27 SET X=$PIECE(XJOB,U,2)
DO DATE8
WRITE ?36,X
+28 WRITE ?50,$PIECE(XJOB,U,3),?55,$PIECE(XJOB,U,4),?64," ",$PIECE(XJOB,U,5)
+29 IF $PIECE(^TMP($JOB,"BDT",N),"~")="E"
SET N=N+1
WRITE !?5,"ERROR: ",$EXTRACT($PIECE(^TMP($JOB,"BDT",N),"~"),1,230),!
End DoDot:2
End DoDot:1
IF $DATA(DIRUT)
QUIT
+30 KILL ^TMP($JOB,"BDT")
+31 QUIT
+32 ;
+1 WRITE !,?55,"Current",?65,"Current"
+2 WRITE !,"Merge Set Start Stat Last Chk Phase File Entry",!
+3 QUIT
+4 ;
DATE8 ;
+1 NEW X1
+2 IF X=""
SET X=" "
QUIT
+3 SET X1=X
+4 SET X=$EXTRACT(X1,4,5)_"/"_$EXTRACT(X1,6,7)_" "
+5 SET X1=$PIECE(X1,".",2)_"000000"
+6 SET X=X_$EXTRACT(X1,1,2)_":"_$EXTRACT(X1,3,4)
+7 QUIT
+8 ;
ONESET(FILE,SPECIAL) ;
+1 NEW JOBNUM,JVAL
+2 IF FILE'["VA"
SET JVAL=0
FOR JOBNUM=0:0
SET JOBNUM=$ORDER(@FILE@("START",JOBNUM))
IF JOBNUM'>0
QUIT
SET JVAL=JVAL+1
DO LOOP
+3 IF FILE'["VA"
QUIT
LOOP SET N=N+1
IF $DATA(^TMP($JOB,"BDT",N))
GOTO LOOP
+1 IF 'SPECIAL
SET START=$SELECT(FILE'["VA":@FILE@("START",JOBNUM),$PIECE(@FILE@(0),U,5)>0:$PIECE(^(0),U,5),1:$PIECE(^(0),U,3))
IF 1
+2 IF SPECIAL
SET START=$SELECT($PIECE(@FILE@(0),U,4)>0:$PIECE(^(0),U,4),1:$PIECE(^(0),U,2))
+3 SET XNAME=$SELECT(XDRFIL'["VA":XJOB_" J"_JVAL_" ",'SPECIAL:$PIECE(@FILE@(0),U),1:" "_$EXTRACT($PIECE(@FILE@(0),U),1,15))
+4 IF XDRFIL["VA"
SET ^TMP($JOB,"BDT",N)=$SELECT('SPECIAL:$PIECE(@FILE@(0),U,4),1:$PIECE(@FILE@(0),U,3))
+5 IF '$TEST
SET ^TMP($JOB,"BDT",N)=$SELECT($DATA(@FILE@("DONE",JOBNUM)):"C",1:"A")
+6 IF ^TMP($JOB,"BDT",N)="E"
SET ^TMP($JOB,"BDT",N+1)=$GET(@FILE@(2))
+7 SET XJOB=$SELECT(XDRFIL'["VA":$GET(@FILE@("DONE",JOBNUM)),'SPECIAL:$PIECE(@FILE@(0),U,6),1:$PIECE(@FILE@(0),U,5))
+8 IF XJOB=""
Begin DoDot:1
+9 SET XJOB=XJOB_U_$SELECT(XDRFIL'["VA":$GET(@FILE@("TIME",JOBNUM)),1:$GET(@FILE@(1)))
+10 IF XDRFIL'["VA"!SPECIAL
IF ^TMP($JOB,"BDT",N)="A"
IF $$FMDIFF^XLFDT($$NOW^XLFDT(),$PIECE(XJOB,U,2),2)>43000
Begin DoDot:2
+11 SET ^TMP($JOB,"BDT",N)="U"
+12 IF XDRFIL["VA"
Begin DoDot:3
+13 SET $PIECE(@FILE@(0),U,3)="U"
End DoDot:3
End DoDot:2
+14 IF ^TMP($JOB,"BDT",N)="U"
IF XDRFIL["VA"
IF SPECIAL
IF $$FMDIFF^XLFDT($$NOW^XLFDT(),$PIECE(XJOB,U,2),2)'>43000
SET ^TMP($JOB,"BDT",N)="A"
SET $PIECE(@FILE@(0),U,3)="A"
End DoDot:1
+15 SET ^TMP($JOB,"BDT",N)=$PIECE(^TMP($JOB,"BDT",N),"~")_"~"_XNAME_"~"_START_"~"_XJOB
+16 QUIT
