XDRMERG1 ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ;06/02/2005 09:01
;;7.3;TOOLKIT;**23,34,38,44,47,95**;Apr 25, 1995
;;
;;
CHASE(XVAL,RVAL,XDRIENS) ;
N XDRYT,XDRYTT,NODE,X,PC,Y,XDRTO,XDRIEN,XV,XN,XXV,XTYPE,X
N DA,XV,XXV,XDRFILE,OLDH
S OLDH=$P($H,",",2)
F DA=SENTRY:0 Q:$D(ZTSTOP) S DA=$O(@(XVAL_DA_")")) Q:DA'>0 D
. I (($P($H,",",2)-OLDH>XDRTIME)!($P($H,",",2)<OLDH)) S OLDH=$P($H,",",2) I $$S^%ZTLOAD S ZTSTOP=1 D Q
. . I '$D(XDRFDA) Q
. . I $P(^VA(15.2,XDRFDA,0),U,9)="" S $P(^(0),U,9)=1
. I $D(XDRFDA),$P(^VA(15.2,XDRFDA,0),U,9)=1 S ZTSTOP=1 Q
. I XDRIENS="" D
. . S XDRYT=$$NOW^XLFDT()
. . I $$FMDIFF^XLFDT(XDRYT,XDRXT,2)>5 D ;60 D
. . . I $D(XDRFDA) D I 1
. . . . S ^VA(15.2,XDRFDA,3,XDRFDA1,1)=XDRYT_U_CURRTYPE_U_CURRFIL_U_DA
. . . E D
. . . . S ^XTMP("XDRSTAT",XDRGID,"TIME",$J)=XDRYT_U_CURRTYPE_U_CURRFIL_U_DA
. . . S XDRXT=XDRYT
. I $D(^TMP($J,"XGLOB",RVAL)) D
. . S NODE="" F S NODE=$O(^TMP($J,"XGLOB",RVAL,NODE)) Q:NODE="" D
. . . S X=$G(@(XVAL_DA_","_NODE_")")) Q:X=""
. . . F PC=0:0 S PC=$O(^TMP($J,"XGLOB",RVAL,NODE,PC)) Q:PC'>0 D
. . . . S Y=$P(X,U,PC),XDRFR=Y
. . . . I Y>0,$D(XDRXFLG),$D(@FROM@(+Y))=1 S @FROM@(+Y,"R",CURRFIL)=$G(@FROM@(+Y,"R",CURRFIL))+1 Q ; USED TO DETERMINE WHICH ENTRIES AREN'T POINTED TO.
. . . . I Y>0 S XDRTO=$O(@FROM@(+Y,"")) I XDRTO>0 D
. . . . . I +Y'=Y D Q:Y'>0
. . . . . . I $P(Y,";",2)'=$E(XDRFGLOB,2,99) S Y=0 Q
. . . . . . S XDRTO=XDRTO_";"_$E(XDRFGLOB,2,99)
. . . . . I $P(^TMP($J,"XGLOB",RVAL,NODE,PC),U,3)="DINUM" D Q
. . . . . . D DINUM^XDRMERG2(XVAL,RVAL,XDRIENS)
. . . . . I ^TMP($J,"XGLOB",RVAL,NODE,PC)>0 D Q
. . . . . . S XDRIEN=DA_","_XDRIENS
. . . . . . N DA,XDRFILE,XDRFLD,XDR
. . . . . . S XDRFILE=+^TMP($J,"XGLOB",RVAL,NODE,PC)
. . . . . . S XDRFLD=+$P(^TMP($J,"XGLOB",RVAL,NODE,PC),U,2)
. . . . . . S XDR(XDRFILE,XDRIEN,XDRFLD)=XDRTO
. . . . . . ; S ^XDRM(+XDRFR,"P",XDRFILE,XDRIEN,XDRFLD)=XDRFR ; ORIGINAL VERSION SIMPLY STORE DATA ON POINTER CHANGE
. . . . . . D SAVEPNTR^XDRMERGB(+XDRFR,+XDRTO,XDRFILE,XDRIEN,XDRFLD,XDRFR) ; REVISED TO STORE POINTER CHANGE IN FM COMPATIBLE STRUCTURE
. . . . . . D FILE^DIE("","XDR")
. . . . . S $P(@(XVAL_DA_","_NODE_")"),U,PC)=XDRTO
. . . . . S XDRFILE=+$P(@(XVAL_"0)"),U,2)
. . . . . S XDRFLD=$O(@("^DD("_XDRFILE_",""GL"","_NODE_","_PC_",0)"))
. . . . . S XDRIEN=DA_","_XDRIENS
. . . . . ; S ^XDRM(+XDRFR,"P",XDRFILE,XDRIEN,XDRFLD)=XDRFR ; ORIGINAL VERSION SIMPLY STORE DATA ON POINTER CHANGE
. . . . . D SAVEPNTR^XDRMERGB(+XDRFR,+XDRTO,XDRFILE,XDRIEN,XDRFLD,XDRFR)
. S XV=RVAL
. F S XV=$O(^TMP($J,"XGLO",XV)) Q:XV'[RVAL D
. . S XN=$P(XV,RVAL,2),XN=DA_","_$P(XN,"DA,",2)
. . S XXV=XVAL_XN
. . S XTYPE=$$TYPE(XV)
. . I XTYPE="DINUM" D DINUM^XDRMERG2(XXV,XV,DA_","_XDRIENS) Q
. . I XTYPE'="" D XREFS^XDRMERG2(XXV,XV,DA_","_XDRIENS) Q
. . D CHASE(XXV,XV,DA_","_XDRIENS)
S SENTRY=0
Q
;
TYPE(GLOB) ;
N I,J
S I=$O(^TMP($J,"XGLOB",GLOB,"")) Q:I="" ""
S J=$O(^TMP($J,"XGLOB",GLOB,I,"")) Q:J="" ""
Q $P(^TMP($J,"XGLOB",GLOB,I,J),U,3)
;
XREFS ; CONTINUATION FROM XDRMERG2 DUE TO SPACE LIMITS
N IENOLD,IENNEW,IENVAL,FILEI,FLDJ,XREF,XDRXX,VREF,NMAX,GLOBPCS
N NODE,PIECE
N XDRZZ,XDRAA ; DEBUG STATEMENT
S XDRXX=$NA(^TMP($J,"XDRXX"))
K @XDRXX
S NMAX=$L(XR,"DA,") F J=1:1:NMAX S GLOBPCS(J)=$P(XR,"DA,",J)
S NODE="" F S NODE=$O(^TMP($J,"XGLOB",XR,NODE)) Q:NODE="" F PIECE=0:0 S PIECE=$O(^TMP($J,"XGLOB",XR,NODE,PIECE)) Q:PIECE'>0 S FILEI=^(PIECE) D
. S FLDJ=$P(FILEI,U,2),XREF=$P(FILEI,U,3),FILEI=+FILEI,VREF="" I $P(^DD(FILEI,FLDJ,0),U,2)["V" S VREF=";"_$E(XDRFGLOB,2,99)
. I XREF="DINUM" Q
. F IENOLD=0:0 S IENOLD=$O(@FROM@(IENOLD)) Q:IENOLD'>0 D
. . N KVALUE,YGLOB,NCNT,DAIENS,ZGLOB
. . S IENNEW=$O(@FROM@(IENOLD,"")) Q:IENNEW'>0&'$D(XDRXFLG)
. . S KVALUE=$S(VREF'="":IENOLD_VREF,1:IENOLD),ZGLOB=GLOBPCS(1)_XREF_","_""""_KVALUE_""""_")" I $D(@ZGLOB) S DAIENS="",YGLOB=GLOBPCS(1),NCNT=0 D FINDXREF(NMAX,XDRXX,ZGLOB,NCNT,DAIENS,YGLOB)
. . Q
. Q
K XDRAA,XDRZZ I $D(XDRTESTK) M XDRAA=@XDRXX ; DEBUG STATEMENT
I $D(@XDRXX) D FILE^DIE("",XDRXX)
I $D(XDRZZ),$D(XDRTESTK) S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ K XDRAA,XDRZZ ; DEBUG STATEMENT
Q
;
FINDXREF(NMAX,XDRXX,ZGLOB,NCNT,DAIENS,YGLOB) ;
N LVAL,NVAL
S NVAL=NCNT+1
I NVAL=NMAX D Q
. F LVAL=0:0 S LVAL=$O(@ZGLOB@(LVAL)) Q:LVAL'>0!(LVAL'=+LVAL) D SETXREF((YGLOB_LVAL_","),(LVAL_","_DAIENS))
. Q
F LVAL=0:0 S LVAL=$O(@ZGLOB@(LVAL)) Q:LVAL'>0!(LVAL'=+LVAL) D FINDXREF(NMAX,XDRXX,$NA(@ZGLOB@(LVAL)),NVAL,(LVAL_","_DAIENS),(YGLOB_LVAL_","_GLOBPCS(NVAL+1)))
Q
;
SETXREF(YGLOB,DAIENS) ;
I $E($P($G(@(YGLOB_NODE_")")),U,PIECE),1,30)'=KVALUE Q
I $D(XDRXFLG) S @FROM@(IENOLD,"R",FILEI)=$G(@FROM@(IENOLD,"R",FILEI))+1 Q ; POINTER WAS FOUND, MARK ENTRY FOR FILE
S @XDRXX@(FILEI,DAIENS,FLDJ)=IENNEW_VREF
D SAVEPNTR^XDRMERGB(+IENOLD,+IENNEW,FILEI,DAIENS,FLDJ,(IENOLD_VREF))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMERG1 4978 printed Oct 16, 2024@18:40:06 Page 2
XDRMERG1 ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ;06/02/2005 09:01
+1 ;;7.3;TOOLKIT;**23,34,38,44,47,95**;Apr 25, 1995
+2 ;;
+3 ;;
CHASE(XVAL,RVAL,XDRIENS) ;
+1 NEW XDRYT,XDRYTT,NODE,X,PC,Y,XDRTO,XDRIEN,XV,XN,XXV,XTYPE,X
+2 NEW DA,XV,XXV,XDRFILE,OLDH
+3 SET OLDH=$PIECE($HOROLOG,",",2)
+4 FOR DA=SENTRY:0
if $DATA(ZTSTOP)
QUIT
SET DA=$ORDER(@(XVAL_DA_")"))
if DA'>0
QUIT
Begin DoDot:1
+5 IF (($PIECE($HOROLOG,",",2)-OLDH>XDRTIME)!($PIECE($HOROLOG,",",2)<OLDH))
SET OLDH=$PIECE($HOROLOG,",",2)
IF $$S^%ZTLOAD
SET ZTSTOP=1
Begin DoDot:2
+6 IF '$DATA(XDRFDA)
QUIT
+7 IF $PIECE(^VA(15.2,XDRFDA,0),U,9)=""
SET $PIECE(^(0),U,9)=1
End DoDot:2
QUIT
+8 IF $DATA(XDRFDA)
IF $PIECE(^VA(15.2,XDRFDA,0),U,9)=1
SET ZTSTOP=1
QUIT
+9 IF XDRIENS=""
Begin DoDot:2
+10 SET XDRYT=$$NOW^XLFDT()
+11 ;60 D
IF $$FMDIFF^XLFDT(XDRYT,XDRXT,2)>5
Begin DoDot:3
+12 IF $DATA(XDRFDA)
Begin DoDot:4
+13 SET ^VA(15.2,XDRFDA,3,XDRFDA1,1)=XDRYT_U_CURRTYPE_U_CURRFIL_U_DA
End DoDot:4
IF 1
+14 IF '$TEST
Begin DoDot:4
+15 SET ^XTMP("XDRSTAT",XDRGID,"TIME",$JOB)=XDRYT_U_CURRTYPE_U_CURRFIL_U_DA
End DoDot:4
+16 SET XDRXT=XDRYT
End DoDot:3
End DoDot:2
+17 IF $DATA(^TMP($JOB,"XGLOB",RVAL))
Begin DoDot:2
+18 SET NODE=""
FOR
SET NODE=$ORDER(^TMP($JOB,"XGLOB",RVAL,NODE))
if NODE=""
QUIT
Begin DoDot:3
+19 SET X=$GET(@(XVAL_DA_","_NODE_")"))
if X=""
QUIT
+20 FOR PC=0:0
SET PC=$ORDER(^TMP($JOB,"XGLOB",RVAL,NODE,PC))
if PC'>0
QUIT
Begin DoDot:4
+21 SET Y=$PIECE(X,U,PC)
SET XDRFR=Y
+22 ; USED TO DETERMINE WHICH ENTRIES AREN'T POINTED TO.
IF Y>0
IF $DATA(XDRXFLG)
IF $DATA(@FROM@(+Y))=1
SET @FROM@(+Y,"R",CURRFIL)=$GET(@FROM@(+Y,"R",CURRFIL))+1
QUIT
+23 IF Y>0
SET XDRTO=$ORDER(@FROM@(+Y,""))
IF XDRTO>0
Begin DoDot:5
+24 IF +Y'=Y
Begin DoDot:6
+25 IF $PIECE(Y,";",2)'=$EXTRACT(XDRFGLOB,2,99)
SET Y=0
QUIT
+26 SET XDRTO=XDRTO_";"_$EXTRACT(XDRFGLOB,2,99)
End DoDot:6
if Y'>0
QUIT
+27 IF $PIECE(^TMP($JOB,"XGLOB",RVAL,NODE,PC),U,3)="DINUM"
Begin DoDot:6
+28 DO DINUM^XDRMERG2(XVAL,RVAL,XDRIENS)
End DoDot:6
QUIT
+29 IF ^TMP($JOB,"XGLOB",RVAL,NODE,PC)>0
Begin DoDot:6
+30 SET XDRIEN=DA_","_XDRIENS
+31 NEW DA,XDRFILE,XDRFLD,XDR
+32 SET XDRFILE=+^TMP($JOB,"XGLOB",RVAL,NODE,PC)
+33 SET XDRFLD=+$PIECE(^TMP($JOB,"XGLOB",RVAL,NODE,PC),U,2)
+34 SET XDR(XDRFILE,XDRIEN,XDRFLD)=XDRTO
+35 ; S ^XDRM(+XDRFR,"P",XDRFILE,XDRIEN,XDRFLD)=XDRFR ; ORIGINAL VERSION SIMPLY STORE DATA ON POINTER CHANGE
+36 ; REVISED TO STORE POINTER CHANGE IN FM COMPATIBLE STRUCTURE
DO SAVEPNTR^XDRMERGB(+XDRFR,+XDRTO,XDRFILE,XDRIEN,XDRFLD,XDRFR)
+37 DO FILE^DIE("","XDR")
End DoDot:6
QUIT
+38 SET $PIECE(@(XVAL_DA_","_NODE_")"),U,PC)=XDRTO
+39 SET XDRFILE=+$PIECE(@(XVAL_"0)"),U,2)
+40 SET XDRFLD=$ORDER(@("^DD("_XDRFILE_",""GL"","_NODE_","_PC_",0)"))
+41 SET XDRIEN=DA_","_XDRIENS
+42 ; S ^XDRM(+XDRFR,"P",XDRFILE,XDRIEN,XDRFLD)=XDRFR ; ORIGINAL VERSION SIMPLY STORE DATA ON POINTER CHANGE
+43 DO SAVEPNTR^XDRMERGB(+XDRFR,+XDRTO,XDRFILE,XDRIEN,XDRFLD,XDRFR)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+44 SET XV=RVAL
+45 FOR
SET XV=$ORDER(^TMP($JOB,"XGLO",XV))
if XV'[RVAL
QUIT
Begin DoDot:2
+46 SET XN=$PIECE(XV,RVAL,2)
SET XN=DA_","_$PIECE(XN,"DA,",2)
+47 SET XXV=XVAL_XN
+48 SET XTYPE=$$TYPE(XV)
+49 IF XTYPE="DINUM"
DO DINUM^XDRMERG2(XXV,XV,DA_","_XDRIENS)
QUIT
+50 IF XTYPE'=""
DO XREFS^XDRMERG2(XXV,XV,DA_","_XDRIENS)
QUIT
+51 DO CHASE(XXV,XV,DA_","_XDRIENS)
End DoDot:2
End DoDot:1
+52 SET SENTRY=0
+53 QUIT
+54 ;
TYPE(GLOB) ;
+1 NEW I,J
+2 SET I=$ORDER(^TMP($JOB,"XGLOB",GLOB,""))
if I=""
QUIT ""
+3 SET J=$ORDER(^TMP($JOB,"XGLOB",GLOB,I,""))
if J=""
QUIT ""
+4 QUIT $PIECE(^TMP($JOB,"XGLOB",GLOB,I,J),U,3)
+5 ;
XREFS ; CONTINUATION FROM XDRMERG2 DUE TO SPACE LIMITS
+1 NEW IENOLD,IENNEW,IENVAL,FILEI,FLDJ,XREF,XDRXX,VREF,NMAX,GLOBPCS
+2 NEW NODE,PIECE
+3 ; DEBUG STATEMENT
NEW XDRZZ,XDRAA
+4 SET XDRXX=$NAME(^TMP($JOB,"XDRXX"))
+5 KILL @XDRXX
+6 SET NMAX=$LENGTH(XR,"DA,")
FOR J=1:1:NMAX
SET GLOBPCS(J)=$PIECE(XR,"DA,",J)
+7 SET NODE=""
FOR
SET NODE=$ORDER(^TMP($JOB,"XGLOB",XR,NODE))
if NODE=""
QUIT
FOR PIECE=0:0
SET PIECE=$ORDER(^TMP($JOB,"XGLOB",XR,NODE,PIECE))
if PIECE'>0
QUIT
SET FILEI=^(PIECE)
Begin DoDot:1
+8 SET FLDJ=$PIECE(FILEI,U,2)
SET XREF=$PIECE(FILEI,U,3)
SET FILEI=+FILEI
SET VREF=""
IF $PIECE(^DD(FILEI,FLDJ,0),U,2)["V"
SET VREF=";"_$EXTRACT(XDRFGLOB,2,99)
+9 IF XREF="DINUM"
QUIT
+10 FOR IENOLD=0:0
SET IENOLD=$ORDER(@FROM@(IENOLD))
if IENOLD'>0
QUIT
Begin DoDot:2
+11 NEW KVALUE,YGLOB,NCNT,DAIENS,ZGLOB
+12 SET IENNEW=$ORDER(@FROM@(IENOLD,""))
if IENNEW'>0&'$DATA(XDRXFLG)
QUIT
+13 SET KVALUE=$SELECT(VREF'="":IENOLD_VREF,1:IENOLD)
SET ZGLOB=GLOBPCS(1)_XREF_","_""""_KVALUE_""""_")"
IF $DATA(@ZGLOB)
SET DAIENS=""
SET YGLOB=GLOBPCS(1)
SET NCNT=0
DO FINDXREF(NMAX,XDRXX,ZGLOB,NCNT,DAIENS,YGLOB)
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 ; DEBUG STATEMENT
KILL XDRAA,XDRZZ
IF $DATA(XDRTESTK)
MERGE XDRAA=@XDRXX
+17 IF $DATA(@XDRXX)
DO FILE^DIE("",XDRXX)
+18 ; DEBUG STATEMENT
IF $DATA(XDRZZ)
IF $DATA(XDRTESTK)
SET XDRTESTK=XDRTESTK+1
MERGE ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ
KILL XDRAA,XDRZZ
+19 QUIT
+20 ;
FINDXREF(NMAX,XDRXX,ZGLOB,NCNT,DAIENS,YGLOB) ;
+1 NEW LVAL,NVAL
+2 SET NVAL=NCNT+1
+3 IF NVAL=NMAX
Begin DoDot:1
+4 FOR LVAL=0:0
SET LVAL=$ORDER(@ZGLOB@(LVAL))
if LVAL'>0!(LVAL'=+LVAL)
QUIT
DO SETXREF((YGLOB_LVAL_","),(LVAL_","_DAIENS))
+5 QUIT
End DoDot:1
QUIT
+6 FOR LVAL=0:0
SET LVAL=$ORDER(@ZGLOB@(LVAL))
if LVAL'>0!(LVAL'=+LVAL)
QUIT
DO FINDXREF(NMAX,XDRXX,$NAME(@ZGLOB@(LVAL)),NVAL,(LVAL_","_DAIENS),(YGLOB_LVAL_","_GLOBPCS(NVAL+1)))
+7 QUIT
+8 ;
SETXREF(YGLOB,DAIENS) ;
+1 IF $EXTRACT($PIECE($GET(@(YGLOB_NODE_")")),U,PIECE),1,30)'=KVALUE
QUIT
+2 ; POINTER WAS FOUND, MARK ENTRY FOR FILE
IF $DATA(XDRXFLG)
SET @FROM@(IENOLD,"R",FILEI)=$GET(@FROM@(IENOLD,"R",FILEI))+1
QUIT
+3 SET @XDRXX@(FILEI,DAIENS,FLDJ)=IENNEW_VREF
+4 DO SAVEPNTR^XDRMERGB(+IENOLD,+IENNEW,FILEI,DAIENS,FLDJ,(IENOLD_VREF))
+5 QUIT
