XTVGC1 ;ISC-SF/JLI - RECORD GLOBAL NODES FOR PACKAGE BEFORE MODIFICATION ;12/16/93 14:06 ; 01/16/89
;;7.3;TOOLKIT;;Apr 25, 1995
W !!,"Record Current Global Nodes for Package for Future Comparison",!!
ASK K DIC S DIC=8991.2,DIC(0)="AEQLM",DLAYGO=8991.2 D ^DIC Q:Y'>0 S XTVPT=+Y
S %DT("A")="Date current status is to be recorded as: ",%DT("B")="T",%DT="AEQXP" D ^%DT G:Y'>0 ASK S XTVDT=Y
ASK1 R !,"Current Version Number (optional): ",X:DTIME Q:'$T!(X[U) S XTVVN=X I X'="",X'>0 W !!,$C(7),"Enter a version number (beginning with a number at least) or RETURN",! G ASK1
S ZTRTN="DQ^XTVGC1",ZTDESC="Package Globals Record",ZTIO="",ZTSAVE("XTVPT")="",ZTSAVE("XTVDT")="",ZTSAVE("XTVVN")="" D ^%ZTLOAD
K DIC,XTVPT,XTVDT,XTVVN,%DT,ZTRTN,ZTIO,ZTDESC,ZTSAVE
Q
;
DQ ;
K ^TMP($J),X
S XTVPK=+^XTV(8991.2,XTVPT,0)
S:'$D(^XTV(8991.2,XTVPT,1,0)) ^(0)="^8991.21^" S DIC="^XTV(8991.2,XTVPT,1,",DA(1)=XTVPT,DIC(0)="ML",DLAYGO=8991.2,DIC("P")=8991.21,X=XTVDT D ^DIC Q:Y'>0 S XTVD=+Y
S:XTVVN'="" ^(0)=^XTV(8991.2,XTVPT,1,XTVD,0)_U_XTVVN
F I=0:0 S I=$O(^XTV(8991.19,XTVPK,1,I)) Q:I'>0 S GLBN=+^(I,0) I '$D(^TMP($J,GLBN)) S ^(GLBN)=GLBN,^TMP($J,"A",GLBN)="" K X D CHK
S XTVNF=0 F I=0:0 S I=$O(^TMP($J,"A",I)) Q:I'>0 S XTVNM=$O(^DD(I,0,"NM",0)),XTVNM=$S(XTVNM'="":XTVNM,1:I),^XTV(8991.2,XTVPT,1,XTVD,1,I,0)=XTVNM,^XTV(8991.2,XTVPT,1,XTVD,1,"B",XTVNM,I)="" D GETFIL S XTVNF=XTVNF+1,XTVNL=I
I XTVNF>0 S ^XTV(8991.2,XTVPT,1,XTVD,1,0)="^^"_XTVNL_U_XTVNF
D ^XTVGC1A
K A,DA,DIC,DLAYGO,GLBN,I,IX,J,K,L,M,X,X1,XTBAS1,XTBAS2,XTCNA,XTCNL,XTCNT,XTNOD,XTNS,XTNS1,XTNSI,XTNSL,XTNUM,XTTY,XTTYI,XTTYJ,XTVA,XTVAL,XTVAB,XTVB,XTVB1,XTVD,XTVF,XTVNAM,XTVNF,XTVNL,XTVNM,XTVPK,XTVPT,XTVTY,XTVVN,XTXNUM,Y
Q
;
CHK S L=0 F J=0:0 S J=$O(^DD(GLBN,"SB",J)) Q:J'>0 S X(L,J)=""
F L=0:1 Q:'$D(X(L)) S M=L+1 F K=0:0 S K=$O(X(L,K)) Q:K'>0 F J=0:0 S J=$O(^DD(K,"SB",J)) Q:J'>0 S X(M,J)=""
F L=-1:0 S L=$O(X(L)) Q:L="" F J=0:0 S J=$O(X(L,J)) Q:J'>0 S:'$D(^TMP($J,J)) ^(J)=GLBN,^TMP($J,"A",GLBN,J)=""
Q
;
GETFIL S XTVF=I D DD,DIC ;,DIE,DIBT,DIPT
Q
DD S XTVTY="D",XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",0)",XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",""B"",",XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",J,0)",XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",J,1,"
S (XTVF,J)=I S X="^DD("_XTVF_")",X1="^DD("_XTVF_",",XTVNAM=$S($O(^DD(I,0,"NM",0))'="":$O(^(0)),1:I),@XTVB1=XTVNAM,@(XTVAB_""""_XTVNAM_""","_J_")")="",XTCNA=1,XTCNL=I,XTCNT=0 D XPND
F J=0:0 S J=$O(^TMP($J,"A",I,J)) Q:J'>0 S XTCNT=0,X="^DD("_J_")",X1="^DD("_J_",",XTVNAM=$S($O(^DD(J,0,"NM",0))'="":$O(^(0)),1:J),@XTVB1=XTVNAM,@(XTVAB_""""_XTVNAM_""","_J_")")="" D XPND S XTCNA=XTCNA+1,XTCNL=J
I XTCNA>0 S @XTVA="^^"_XTCNL_U_XTCNA
Q
;
DIC S XTVTY="C",XTVF=I,X="^DIC("_I_")",X1="^DIC("_I_",0",XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""C"",",XTCNT=0 D XPND
I XTCNT>0 S @(XTVB_"0)")="^^"_XTCNT_U_XTCNT
Q
;
DIE ;
S XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",0)",XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",""B"",",XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",J,0)",XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",J,1,"
S (XTVF,J)="F"_I,A="",XTCNA=0,XTVTY="E"
F K=0:0 S A=$O(^DIE(XTVF,A)) Q:A="" F J=0:0 S J=$O(^DIE(XTVF,A,J)) Q:J'>0 S X="^DIE("_J_")",X1="^DIE("_J_",",XTVNAM=A,@XTVB1=XTVNAM,@(XTVAB_""""_XTVNAM_""","_J_")")="",XTCNA=XTCNA+1,XTCNL=J,XTCNT=0 D XPND
I XTCNA>0 S @XTVA="^^"_XTCNL_U_XTCNA
Q
;
DIPT ;
S XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",0)",XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",""B"",",XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",J,0)",XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",J,1,"
S (XTVF,J)="F"_I,A="",XTCNA=0,XTVTY="P"
F K=0:0 S A=$O(^DIPT(XTVF,A)) Q:A="" F J=0:0 S J=$O(^DIPT(XTVF,A,J)) Q:J'>0 S X="^DIPT("_J_")",X1="^DIPT("_J_",",XTVNAM=A,@XTVB1=XTVNAM,@(XTVAB_""""_XTVNAM_""","_J_")")="",XTCNA=XTCNA+1,XTCNL=J,XTCNT=0 D XPND
I XTCNA>0 S @XTVA="^^"_XTCNL_U_XTCNA
Q
;
DIBT ;
S XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",0)",XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",""B"",",XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",J,0)",XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",J,1,"
S (XTVF,J)="F"_I,A="",XTCNA=0,XTVTY="S"
F K=0:0 S A=$O(^DIBT(XTVF,A)) Q:A="" F J=0:0 S J=$O(^DIBT(XTVF,A,J)) Q:J'>0 S X="^DIBT("_J_")",X1="^DIBT("_J_",",XTVNAM=A,@XTVB1=XTVNAM,@(XTVAB_""""_XTVNAM_""","_J_")")="",XTCNA=XTCNA+1,XTCNL=J,XTCNT=0 D XPND
I XTCNA>0 S @XTVA="^^"_XTCNL_U_XTCNA
Q
;
XPND ;
F IX=0:0 S X=$Q(@X) S X=$S($E(X,1,2)="^|":U_$P(X,"|",3,99),$E(X,1,2)="^[":U_$P(X,"]",2,99),1:X) Q:X'[X1 I XTVTY'="E"!($P(X,",",2)'="""AB""") S XTCNT=XTCNT+1,@(XTVB_XTCNT_",0)")=$P(X,U,2,99),@(XTVB_XTCNT_",1)")=@X
I XTCNT>0 S @(XTVB_"0)")="^^"_XTCNT_U_XTCNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVGC1 4651 printed Dec 13, 2024@02:41:52 Page 2
XTVGC1 ;ISC-SF/JLI - RECORD GLOBAL NODES FOR PACKAGE BEFORE MODIFICATION ;12/16/93 14:06 ; 01/16/89
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
+2 WRITE !!,"Record Current Global Nodes for Package for Future Comparison",!!
ASK KILL DIC
SET DIC=8991.2
SET DIC(0)="AEQLM"
SET DLAYGO=8991.2
DO ^DIC
if Y'>0
QUIT
SET XTVPT=+Y
+1 SET %DT("A")="Date current status is to be recorded as: "
SET %DT("B")="T"
SET %DT="AEQXP"
DO ^%DT
if Y'>0
GOTO ASK
SET XTVDT=Y
ASK1 READ !,"Current Version Number (optional): ",X:DTIME
if '$TEST!(X[U)
QUIT
SET XTVVN=X
IF X'=""
IF X'>0
WRITE !!,$CHAR(7),"Enter a version number (beginning with a number at least) or RETURN",!
GOTO ASK1
+1 SET ZTRTN="DQ^XTVGC1"
SET ZTDESC="Package Globals Record"
SET ZTIO=""
SET ZTSAVE("XTVPT")=""
SET ZTSAVE("XTVDT")=""
SET ZTSAVE("XTVVN")=""
DO ^%ZTLOAD
+2 KILL DIC,XTVPT,XTVDT,XTVVN,%DT,ZTRTN,ZTIO,ZTDESC,ZTSAVE
+3 QUIT
+4 ;
DQ ;
+1 KILL ^TMP($JOB),X
+2 SET XTVPK=+^XTV(8991.2,XTVPT,0)
+3 if '$DATA(^XTV(8991.2,XTVPT,1,0))
SET ^(0)="^8991.21^"
SET DIC="^XTV(8991.2,XTVPT,1,"
SET DA(1)=XTVPT
SET DIC(0)="ML"
SET DLAYGO=8991.2
SET DIC("P")=8991.21
SET X=XTVDT
DO ^DIC
if Y'>0
QUIT
SET XTVD=+Y
+4 if XTVVN'=""
SET ^(0)=^XTV(8991.2,XTVPT,1,XTVD,0)_U_XTVVN
+5 FOR I=0:0
SET I=$ORDER(^XTV(8991.19,XTVPK,1,I))
if I'>0
QUIT
SET GLBN=+^(I,0)
IF '$DATA(^TMP($JOB,GLBN))
SET ^(GLBN)=GLBN
SET ^TMP($JOB,"A",GLBN)=""
KILL X
DO CHK
+6 SET XTVNF=0
FOR I=0:0
SET I=$ORDER(^TMP($JOB,"A",I))
if I'>0
QUIT
SET XTVNM=$ORDER(^DD(I,0,"NM",0))
SET XTVNM=$SELECT(XTVNM'="":XTVNM,1:I)
SET ^XTV(8991.2,XTVPT,1,XTVD,1,I,0)=XTVNM
SET ^XTV(8991.2,XTVPT,1,XTVD,1,"B",XTVNM,I)=""
DO GETFIL
SET XTVNF=XTVNF+1
SET XTVNL=I
+7 IF XTVNF>0
SET ^XTV(8991.2,XTVPT,1,XTVD,1,0)="^^"_XTVNL_U_XTVNF
+8 DO ^XTVGC1A
+9 KILL A,DA,DIC,DLAYGO,GLBN,I,IX,J,K,L,M,X,X1,XTBAS1,XTBAS2,XTCNA,XTCNL,XTCNT,XTNOD,XTNS,XTNS1,XTNSI,XTNSL,XTNUM,XTTY,XTTYI,XTTYJ,XTVA,XTVAL,XTVAB,XTVB,XTVB1,XTVD,XTVF,XTVNAM,XTVNF,XTVNL,XTVNM,XTVPK,XTVPT,XTVTY,XTVVN,XTXNUM,Y
+10 QUIT
+11 ;
CHK SET L=0
FOR J=0:0
SET J=$ORDER(^DD(GLBN,"SB",J))
if J'>0
QUIT
SET X(L,J)=""
+1 FOR L=0:1
if '$DATA(X(L))
QUIT
SET M=L+1
FOR K=0:0
SET K=$ORDER(X(L,K))
if K'>0
QUIT
FOR J=0:0
SET J=$ORDER(^DD(K,"SB",J))
if J'>0
QUIT
SET X(M,J)=""
+2 FOR L=-1:0
SET L=$ORDER(X(L))
if L=""
QUIT
FOR J=0:0
SET J=$ORDER(X(L,J))
if J'>0
QUIT
if '$DATA(^TMP($JOB,J))
SET ^(J)=GLBN
SET ^TMP($JOB,"A",GLBN,J)=""
+3 QUIT
+4 ;
GETFIL ;,DIE,DIBT,DIPT
SET XTVF=I
DO DD
DO DIC
+1 QUIT
DD SET XTVTY="D"
SET XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",0)"
SET XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",""B"","
SET XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",J,0)"
SET XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""D"",J,1,"
+1 SET (XTVF,J)=I
SET X="^DD("_XTVF_")"
SET X1="^DD("_XTVF_","
SET XTVNAM=$SELECT($ORDER(^DD(I,0,"NM",0))'="":$ORDER(^(0)),1:I)
SET @XTVB1=XTVNAM
SET @(XTVAB_""""_XTVNAM_""","_J_")")=""
SET XTCNA=1
SET XTCNL=I
SET XTCNT=0
DO XPND
+2 FOR J=0:0
SET J=$ORDER(^TMP($JOB,"A",I,J))
if J'>0
QUIT
SET XTCNT=0
SET X="^DD("_J_")"
SET X1="^DD("_J_","
SET XTVNAM=$SELECT($ORDER(^DD(J,0,"NM",0))'="":$ORDER(^(0)),1:J)
SET @XTVB1=XTVNAM
SET @(XTVAB_""""_XTVNAM_""","_J_")")=""
DO XPND
SET XTCNA=XTCNA+1
SET XTCNL=J
+3 IF XTCNA>0
SET @XTVA="^^"_XTCNL_U_XTCNA
+4 QUIT
+5 ;
DIC SET XTVTY="C"
SET XTVF=I
SET X="^DIC("_I_")"
SET X1="^DIC("_I_",0"
SET XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""C"","
SET XTCNT=0
DO XPND
+1 IF XTCNT>0
SET @(XTVB_"0)")="^^"_XTCNT_U_XTCNT
+2 QUIT
+3 ;
DIE ;
+1 SET XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",0)"
SET XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",""B"","
SET XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",J,0)"
SET XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""E"",J,1,"
+2 SET (XTVF,J)="F"_I
SET A=""
SET XTCNA=0
SET XTVTY="E"
+3 FOR K=0:0
SET A=$ORDER(^DIE(XTVF,A))
if A=""
QUIT
FOR J=0:0
SET J=$ORDER(^DIE(XTVF,A,J))
if J'>0
QUIT
SET X="^DIE("_J_")"
SET X1="^DIE("_J_","
SET XTVNAM=A
SET @XTVB1=XTVNAM
SET @(XTVAB_""""_XTVNAM_""","_J_")")=""
SET XTCNA=XTCNA+1
SET XTCNL=J
SET XTCNT=0
DO XPND
+4 IF XTCNA>0
SET @XTVA="^^"_XTCNL_U_XTCNA
+5 QUIT
+6 ;
DIPT ;
+1 SET XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",0)"
SET XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",""B"","
SET XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",J,0)"
SET XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""P"",J,1,"
+2 SET (XTVF,J)="F"_I
SET A=""
SET XTCNA=0
SET XTVTY="P"
+3 FOR K=0:0
SET A=$ORDER(^DIPT(XTVF,A))
if A=""
QUIT
FOR J=0:0
SET J=$ORDER(^DIPT(XTVF,A,J))
if J'>0
QUIT
SET X="^DIPT("_J_")"
SET X1="^DIPT("_J_","
SET XTVNAM=A
SET @XTVB1=XTVNAM
SET @(XTVAB_""""_XTVNAM_""","_J_")")=""
SET XTCNA=XTCNA+1
SET XTCNL=J
SET XTCNT=0
DO XPND
+4 IF XTCNA>0
SET @XTVA="^^"_XTCNL_U_XTCNA
+5 QUIT
+6 ;
DIBT ;
+1 SET XTVA="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",0)"
SET XTVAB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",""B"","
SET XTVB1="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",J,0)"
SET XTVB="^XTV(8991.2,XTVPT,1,XTVD,1,I,""S"",J,1,"
+2 SET (XTVF,J)="F"_I
SET A=""
SET XTCNA=0
SET XTVTY="S"
+3 FOR K=0:0
SET A=$ORDER(^DIBT(XTVF,A))
if A=""
QUIT
FOR J=0:0
SET J=$ORDER(^DIBT(XTVF,A,J))
if J'>0
QUIT
SET X="^DIBT("_J_")"
SET X1="^DIBT("_J_","
SET XTVNAM=A
SET @XTVB1=XTVNAM
SET @(XTVAB_""""_XTVNAM_""","_J_")")=""
SET XTCNA=XTCNA+1
SET XTCNL=J
SET XTCNT=0
DO XPND
+4 IF XTCNA>0
SET @XTVA="^^"_XTCNL_U_XTCNA
+5 QUIT
+6 ;
XPND ;
+1 FOR IX=0:0
SET X=$QUERY(@X)
SET X=$SELECT($EXTRACT(X,1,2)="^|":U_$PIECE(X,"|",3,99),$EXTRACT(X,1,2)="^[":U_$PIECE(X,"]",2,99),1:X)
if X'[X1
QUIT
IF XTVTY'="E"!($PIECE(X,",",2)'="""AB""")
SET XTCNT=XTCNT+1
SET @(XTVB_XTCNT_",0)")=$PIECE(X,U,2,99)
SET @(XTVB_XTCNT_",1)")=@X
+2 IF XTCNT>0
SET @(XTVB_"0)")="^^"_XTCNT_U_XTCNT
+3 QUIT
