- 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 Feb 19, 2025@00:08:20 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
