MAGDGL ;WOIFO/EdM - Global Lister ; 05/27/2005 09:23
;;3.0;IMAGING;**11,51**;26-August-2005
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
; Call Global Variable Lister
N DTIME,I,MAX,N,WILD,OUT,T,X
S DTIME=$G(DTIME,300),MAX=20
F D Q:WILD=""
. W !,"Global Variable name: ^" R WILD:DTIME E S WILD=""
. S:WILD="^" WILD=""
. Q:WILD=""
. S:$E(WILD,1)'="^" WILD="^"_WILD
. S (N,START)=0 F D Q:N<MAX Q:X["^"
. . K OUT
. . D LIST(.OUT,WILD,MAX,START)
. . I OUT(1)<0 D Q
. . . W !,"Error in processing:",!,OUT(1),!
. . . W !,"Enter a ""wildcard"" that indicates what part of which"
. . . W !,"global variable is to be displayed."
. . . W !,"The following examples show the options:"
. . . W !," ^MAG(2005,0) - one single node"
. . . W !," ^MAG(2005,,100) - 2nd subscript may have any value"
. . . W !," ^MAG(2005,50:200,100) - 2nd subscript must be between 50 and 200"
. . . W !," ^MAG(2005,""B"",::%S[""JOHN"" - third subscript must contain specific text"
. . . W !," ^MAG(2005,,0:0:%D[""JOHN"" - data must contain specific text"
. . . S X="^"
. . . Q
. . S I=1,N=0 F S I=$O(OUT(I)) Q:I="" D
. . . S N=N+2
. . . W !,OUT(I) S T=$O(OUT(I)) Q:T=""
. . . W " = ",OUT(T) S I=T
. . . F D Q:T=""
. . . . S T=$O(OUT(T)) Q:T="" I OUT(T)'="" S T="" Q
. . . . S T=$O(OUT(T)) Q:T="" W OUT(T) S I=T
. . . . Q
. . . Q
. . I N<MAX S X="^" Q
. . W !!,"More? YES// " R X:DTIME E S X="^"
. . I X="" S X="YES" W X
. . I "Yy"'[$E(X_"^",1) S X="^" Q
. . S START=OUT(1)
. . Q
. Q
Q
;
LIST(OUT,WILD,MAX,START) ; RPC = MAG DICOM LIST GLOBAL VARIABLE
N %D,E,I,L,M,N,NODE,OK,Q,REF,X
I $D(RPC0) D Q:'OK
. N KEY,LIST,RET
. S KEY="MAG SYSTEM",LIST(1)=KEY D OWNSKEY^XUSRB(.RET,.LIST,DUZ)
. S OK=$G(RET(1))
. S:'OK OUT(1)="-13,Calling user does not have security key "_KEY
. Q
I $E($G(WILD),1)'="^" S OUT(1)="-1,Invalid wild-card: "_WILD Q
S NODE=0,START=$G(START)\1 S:START<1 START=0
S (N,M)=1,Q=0,REF(1,1,1)="" F I=1:1:$L(WILD) D
. S E=$E(WILD,I)
. I Q S REF(1,N,M)=REF(1,N,M)_E S:E="""" Q=0 Q
. I E="""" S Q=1,REF(1,N,M)=REF(1,N,M)_E Q
. I "()"[E S N=N+1,REF(1,N)=E,N=N+1,M=1,REF(1,N,1)="" Q
. I E="," D Q
. . I N=1 S M=M+1,REF(1,1,M)=E,M=M+1,REF(1,1,M)="" Q
. . S N=N+1,REF(1,N)=E,N=N+1,M=1,REF(1,N,1)=""
. . Q
. I N=1,"[|]"[E S M=M+1,REF(1,N,M)=E,M=M+1,REF(1,N,M)="" Q
. I " :"[E S M=M+1,REF(1,N,M)=E,M=M+1,REF(1,N,M)="" Q
. S REF(1,N,M)=REF(1,N,M)_E
. Q
K:REF(1,N,M)="" REF(1,N,M)
S REF="",I="" F S I=$O(REF(1,1,I)) Q:I="" S REF=REF_REF(1,1,I)
S X="-2,Invalid Global Variable Name "_REF D
. N $ET
. S $ET="S X=X_$EC,$EC="""" Q"
. S X=$D(@REF)
. Q
I X<0 S OUT(1)=X Q
S N=0 D TRAVERSE(3,REF_"(")
S OUT(1)=NODE
Q
;
TRAVERSE(LEV,ROOT) N FROM,IF,NAME,%S,SEP,TO
S NAME=ROOT_"%S)",(FROM,TO,IF)=""
I $O(REF(1,LEV,1))="",$G(REF(1,LEV,1))="" D Q
. S %S="" F S %S=$O(@NAME) Q:%S="" D SHOW Q:N'<MAX
. Q
I $O(REF(1,LEV,1))="" D Q
. S %S=REF(1,LEV,1)
. D:%S'=""
. . N $ET
. . S $ET="S OK=""-6,Error in subscript-value ""_%S_"": ""_$EC,$EC="""" Q"
. . X "S %S="_%S
. . Q
. D SHOW
. Q
F SEP=2:2 D Q:'SEP
. I '$O(REF(1,LEV,SEP-2)) S SEP=0 Q
. S (FROM,TO,IF)=""
. I $G(REF(1,LEV,SEP)," ")=" " S %S=REF(1,LEV,SEP-1) D SHOW Q
. S FROM=$G(REF(1,LEV,SEP-1)),TO=$G(REF(1,LEV,SEP+1)),SEP=SEP+2
. S IF="" I $G(REF(1,LEV,SEP))=":" S IF=$G(REF(1,LEV,SEP+1)),SEP=SEP+2
. D:FROM'=""
. . N $ET
. . S $ET="S OK=""-4,Error in from-value ""_FROM_"": ""_$EC,$EC="""" Q"
. . X "S FROM="_FROM
. . Q
. D:TO'=""
. . N $ET
. . S $ET="S OK=""-5,Error in to-value ""_TO_"": ""_$EC,$EC="""" Q"
. . X "S TO="_TO
. . Q
. S %S=FROM F D SHOW S %S=$O(@NAME) Q:%S="" I TO'="" Q:%S]]TO
. Q
Q
;
Q(X) I +X=X Q X
N E,I,R
S R="" F I=1:1:$L(X) S E=$E(X,I),R=R_E S:E="""" R=R_E
Q """"_R_""""
;
SHOW N A,C,I,NM,OK,X
Q:%S=""
S OK='$L(IF)
I IF["%S",IF'["%D" D Q:'OK
. N $ET
. S $ET="S OK=""-3,Error in ""_IF_"": ""_$EC,$EC="""" Q"
. X "I "_IF_" S OK=1"
. Q
D:$D(@NAME)#2
. S %D=@NAME I IF'="" D Q:'OK
. . N $ET
. . S $ET="S OK=""-3,Error in ""_IF_"": ""_$EC,$EC="""" Q"
. . X "I "_IF_" S OK=1"
. . Q
. I OK<0 W !,OK Q
. S NODE=NODE+1 I START>0 S START=START-1 Q
. S NM=$NA(@NAME)
. S X="""",C=0 F I=1:1:$L(%D) D
. . S A=$A(%D,I)
. . I A>31,A<127,'C S X=X_$C(A) S:A=34 X=X_$C(A) Q
. . I A>31,A<127 S C=0,X=X_")_"""_$C(A) S:A=34 X=X_$C(A) Q
. . I X="""" S X="$C("_A,C=1 Q
. . I C S X=X_","_A Q
. . S X=X_"""_$C("_A,C=1
. . Q
. S X=X_$S(C:")",1:"""")
. F D Q:X=""
. . S N=N+1,OUT(N+1)=NM,NM=""
. . S N=N+1,OUT(N+1)=$E(X,1,250),X=$E(X,251,$L(X))
. . Q
. Q
Q:N'<MAX
Q:$G(REF(1,LEV+1))=")"
D:OK TRAVERSE(LEV+2,ROOT_$$Q(%S)_",")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDGL 5751 printed Apr 09, 2024@21:07:37 Page 2
MAGDGL ;WOIFO/EdM - Global Lister ; 05/27/2005 09:23
+1 ;;3.0;IMAGING;**11,51**;26-August-2005
+2 ;; +---------------------------------------------------------------+
+3 ;; | Property of the US Government. |
+4 ;; | No permission to copy or redistribute this software is given. |
+5 ;; | Use of unreleased versions of this software requires the user |
+6 ;; | to execute a written test agreement with the VistA Imaging |
+7 ;; | Development Office of the Department of Veterans Affairs, |
+8 ;; | telephone (301) 734-0100. |
+9 ;; | |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ; Call Global Variable Lister
+18 NEW DTIME,I,MAX,N,WILD,OUT,T,X
+19 SET DTIME=$GET(DTIME,300)
SET MAX=20
+20 FOR
Begin DoDot:1
+21 WRITE !,"Global Variable name: ^"
READ WILD:DTIME
IF '$TEST
SET WILD=""
+22 if WILD="^"
SET WILD=""
+23 if WILD=""
QUIT
+24 if $EXTRACT(WILD,1)'="^"
SET WILD="^"_WILD
+25 SET (N,START)=0
FOR
Begin DoDot:2
+26 KILL OUT
+27 DO LIST(.OUT,WILD,MAX,START)
+28 IF OUT(1)<0
Begin DoDot:3
+29 WRITE !,"Error in processing:",!,OUT(1),!
+30 WRITE !,"Enter a ""wildcard"" that indicates what part of which"
+31 WRITE !,"global variable is to be displayed."
+32 WRITE !,"The following examples show the options:"
+33 WRITE !," ^MAG(2005,0) - one single node"
+34 WRITE !," ^MAG(2005,,100) - 2nd subscript may have any value"
+35 WRITE !," ^MAG(2005,50:200,100) - 2nd subscript must be between 50 and 200"
+36 WRITE !," ^MAG(2005,""B"",::%S[""JOHN"" - third subscript must contain specific text"
+37 WRITE !," ^MAG(2005,,0:0:%D[""JOHN"" - data must contain specific text"
+38 SET X="^"
+39 QUIT
End DoDot:3
QUIT
+40 SET I=1
SET N=0
FOR
SET I=$ORDER(OUT(I))
if I=""
QUIT
Begin DoDot:3
+41 SET N=N+2
+42 WRITE !,OUT(I)
SET T=$ORDER(OUT(I))
if T=""
QUIT
+43 WRITE " = ",OUT(T)
SET I=T
+44 FOR
Begin DoDot:4
+45 SET T=$ORDER(OUT(T))
if T=""
QUIT
IF OUT(T)'=""
SET T=""
QUIT
+46 SET T=$ORDER(OUT(T))
if T=""
QUIT
WRITE OUT(T)
SET I=T
+47 QUIT
End DoDot:4
if T=""
QUIT
+48 QUIT
End DoDot:3
+49 IF N<MAX
SET X="^"
QUIT
+50 WRITE !!,"More? YES// "
READ X:DTIME
IF '$TEST
SET X="^"
+51 IF X=""
SET X="YES"
WRITE X
+52 IF "Yy"'[$EXTRACT(X_"^",1)
SET X="^"
QUIT
+53 SET START=OUT(1)
+54 QUIT
End DoDot:2
if N<MAX
QUIT
if X["^"
QUIT
+55 QUIT
End DoDot:1
if WILD=""
QUIT
+56 QUIT
+57 ;
LIST(OUT,WILD,MAX,START) ; RPC = MAG DICOM LIST GLOBAL VARIABLE
+1 NEW %D,E,I,L,M,N,NODE,OK,Q,REF,X
+2 IF $DATA(RPC0)
Begin DoDot:1
+3 NEW KEY,LIST,RET
+4 SET KEY="MAG SYSTEM"
SET LIST(1)=KEY
DO OWNSKEY^XUSRB(.RET,.LIST,DUZ)
+5 SET OK=$GET(RET(1))
+6 if 'OK
SET OUT(1)="-13,Calling user does not have security key "_KEY
+7 QUIT
End DoDot:1
if 'OK
QUIT
+8 IF $EXTRACT($GET(WILD),1)'="^"
SET OUT(1)="-1,Invalid wild-card: "_WILD
QUIT
+9 SET NODE=0
SET START=$GET(START)\1
if START<1
SET START=0
+10 SET (N,M)=1
SET Q=0
SET REF(1,1,1)=""
FOR I=1:1:$LENGTH(WILD)
Begin DoDot:1
+11 SET E=$EXTRACT(WILD,I)
+12 IF Q
SET REF(1,N,M)=REF(1,N,M)_E
if E=""""
SET Q=0
QUIT
+13 IF E=""""
SET Q=1
SET REF(1,N,M)=REF(1,N,M)_E
QUIT
+14 IF "()"[E
SET N=N+1
SET REF(1,N)=E
SET N=N+1
SET M=1
SET REF(1,N,1)=""
QUIT
+15 IF E=","
Begin DoDot:2
+16 IF N=1
SET M=M+1
SET REF(1,1,M)=E
SET M=M+1
SET REF(1,1,M)=""
QUIT
+17 SET N=N+1
SET REF(1,N)=E
SET N=N+1
SET M=1
SET REF(1,N,1)=""
+18 QUIT
End DoDot:2
QUIT
+19 IF N=1
IF "[|]"[E
SET M=M+1
SET REF(1,N,M)=E
SET M=M+1
SET REF(1,N,M)=""
QUIT
+20 IF " :"[E
SET M=M+1
SET REF(1,N,M)=E
SET M=M+1
SET REF(1,N,M)=""
QUIT
+21 SET REF(1,N,M)=REF(1,N,M)_E
+22 QUIT
End DoDot:1
+23 if REF(1,N,M)=""
KILL REF(1,N,M)
+24 SET REF=""
SET I=""
FOR
SET I=$ORDER(REF(1,1,I))
if I=""
QUIT
SET REF=REF_REF(1,1,I)
+25 SET X="-2,Invalid Global Variable Name "_REF
Begin DoDot:1
+26 NEW $ETRAP
+27 SET $ETRAP="S X=X_$EC,$EC="""" Q"
+28 SET X=$DATA(@REF)
+29 QUIT
End DoDot:1
+30 IF X<0
SET OUT(1)=X
QUIT
+31 SET N=0
DO TRAVERSE(3,REF_"(")
+32 SET OUT(1)=NODE
+33 QUIT
+34 ;
TRAVERSE(LEV,ROOT) NEW FROM,IF,NAME,%S,SEP,TO
+1 SET NAME=ROOT_"%S)"
SET (FROM,TO,IF)=""
+2 IF $ORDER(REF(1,LEV,1))=""
IF $GET(REF(1,LEV,1))=""
Begin DoDot:1
+3 SET %S=""
FOR
SET %S=$ORDER(@NAME)
if %S=""
QUIT
DO SHOW
if N'<MAX
QUIT
+4 QUIT
End DoDot:1
QUIT
+5 IF $ORDER(REF(1,LEV,1))=""
Begin DoDot:1
+6 SET %S=REF(1,LEV,1)
+7 if %S'=""
Begin DoDot:2
+8 NEW $ETRAP
+9 SET $ETRAP="S OK=""-6,Error in subscript-value ""_%S_"": ""_$EC,$EC="""" Q"
+10 XECUTE "S %S="_%S
+11 QUIT
End DoDot:2
+12 DO SHOW
+13 QUIT
End DoDot:1
QUIT
+14 FOR SEP=2:2
Begin DoDot:1
+15 IF '$ORDER(REF(1,LEV,SEP-2))
SET SEP=0
QUIT
+16 SET (FROM,TO,IF)=""
+17 IF $GET(REF(1,LEV,SEP)," ")=" "
SET %S=REF(1,LEV,SEP-1)
DO SHOW
QUIT
+18 SET FROM=$GET(REF(1,LEV,SEP-1))
SET TO=$GET(REF(1,LEV,SEP+1))
SET SEP=SEP+2
+19 SET IF=""
IF $GET(REF(1,LEV,SEP))=":"
SET IF=$GET(REF(1,LEV,SEP+1))
SET SEP=SEP+2
+20 if FROM'=""
Begin DoDot:2
+21 NEW $ETRAP
+22 SET $ETRAP="S OK=""-4,Error in from-value ""_FROM_"": ""_$EC,$EC="""" Q"
+23 XECUTE "S FROM="_FROM
+24 QUIT
End DoDot:2
+25 if TO'=""
Begin DoDot:2
+26 NEW $ETRAP
+27 SET $ETRAP="S OK=""-5,Error in to-value ""_TO_"": ""_$EC,$EC="""" Q"
+28 XECUTE "S TO="_TO
+29 QUIT
End DoDot:2
+30 SET %S=FROM
FOR
DO SHOW
SET %S=$ORDER(@NAME)
if %S=""
QUIT
IF TO'=""
if %S]]TO
QUIT
+31 QUIT
End DoDot:1
if 'SEP
QUIT
+32 QUIT
+33 ;
Q(X) IF +X=X
QUIT X
+1 NEW E,I,R
+2 SET R=""
FOR I=1:1:$LENGTH(X)
SET E=$EXTRACT(X,I)
SET R=R_E
if E=""""
SET R=R_E
+3 QUIT """"_R_""""
+4 ;
SHOW NEW A,C,I,NM,OK,X
+1 if %S=""
QUIT
+2 SET OK='$LENGTH(IF)
+3 IF IF["%S"
IF IF'["%D"
Begin DoDot:1
+4 NEW $ETRAP
+5 SET $ETRAP="S OK=""-3,Error in ""_IF_"": ""_$EC,$EC="""" Q"
+6 XECUTE "I "_IF_" S OK=1"
+7 QUIT
End DoDot:1
if 'OK
QUIT
+8 if $DATA(@NAME)#2
Begin DoDot:1
+9 SET %D=@NAME
IF IF'=""
Begin DoDot:2
+10 NEW $ETRAP
+11 SET $ETRAP="S OK=""-3,Error in ""_IF_"": ""_$EC,$EC="""" Q"
+12 XECUTE "I "_IF_" S OK=1"
+13 QUIT
End DoDot:2
if 'OK
QUIT
+14 IF OK<0
WRITE !,OK
QUIT
+15 SET NODE=NODE+1
IF START>0
SET START=START-1
QUIT
+16 SET NM=$NAME(@NAME)
+17 SET X=""""
SET C=0
FOR I=1:1:$LENGTH(%D)
Begin DoDot:2
+18 SET A=$ASCII(%D,I)
+19 IF A>31
IF A<127
IF 'C
SET X=X_$CHAR(A)
if A=34
SET X=X_$CHAR(A)
QUIT
+20 IF A>31
IF A<127
SET C=0
SET X=X_")_"""_$CHAR(A)
if A=34
SET X=X_$CHAR(A)
QUIT
+21 IF X=""""
SET X="$C("_A
SET C=1
QUIT
+22 IF C
SET X=X_","_A
QUIT
+23 SET X=X_"""_$C("_A
SET C=1
+24 QUIT
End DoDot:2
+25 SET X=X_$SELECT(C:")",1:"""")
+26 FOR
Begin DoDot:2
+27 SET N=N+1
SET OUT(N+1)=NM
SET NM=""
+28 SET N=N+1
SET OUT(N+1)=$EXTRACT(X,1,250)
SET X=$EXTRACT(X,251,$LENGTH(X))
+29 QUIT
End DoDot:2
if X=""
QUIT
+30 QUIT
End DoDot:1
+31 if N'<MAX
QUIT
+32 if $GET(REF(1,LEV+1))=")"
QUIT
+33 if OK
DO TRAVERSE(LEV+2,ROOT_$$Q(%S)_",")
+34 QUIT
+35 ;
