- 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 Feb 18, 2025@23:26:21 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 ;