- 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 Feb 19, 2025@00:05:57 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
