Routine: XDRMERG2

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 10

;;

 ; 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)

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

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

XREFS(XVAL,XR,XDRIENS) ; FIND POINTERS BASED ON KNOWN X-REFS FOR FILE

 D XREFS^XDRMERG1

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)

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)

CHKFROM(FROM,FILE) ;

 D CHKFROM^XDRMERGC(FROM,FILE)

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

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")

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")

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")

HEADER ;REM -9/25/96 Write header.

 W !,?55,"Current",?65,"Current"

 W !,"Merge Set             Start    Stat   Last Chk  Phase  File      Entry",!

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)

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMERG2   9632     printed  Feb 19, 2025@00:05:58                                                                                                                                                                                                    Page 2

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 10

 +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      ;

HEADER    ;REM -9/25/96 Write header.

 +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

XDRMERG2.m