source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDGL.m@ 1297

Last change on this file since 1297 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.5 KB
Line 
1MAGDGL ;WOIFO/EdM - Global Lister ; 05/27/2005 09:23
2 ;;3.0;IMAGING;**11,51**;26-August-2005
3 ;; +---------------------------------------------------------------+
4 ;; | Property of the US Government. |
5 ;; | No permission to copy or redistribute this software is given. |
6 ;; | Use of unreleased versions of this software requires the user |
7 ;; | to execute a written test agreement with the VistA Imaging |
8 ;; | Development Office of the Department of Veterans Affairs, |
9 ;; | telephone (301) 734-0100. |
10 ;; | |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 ; Call Global Variable Lister
19 N DTIME,I,MAX,N,WILD,OUT,T,X
20 S DTIME=$G(DTIME,300),MAX=20
21 F D Q:WILD=""
22 . W !,"Global Variable name: ^" R WILD:DTIME E S WILD=""
23 . S:WILD="^" WILD=""
24 . Q:WILD=""
25 . S:$E(WILD,1)'="^" WILD="^"_WILD
26 . S (N,START)=0 F D Q:N<MAX Q:X["^"
27 . . K OUT
28 . . D LIST(.OUT,WILD,MAX,START)
29 . . I OUT(1)<0 D Q
30 . . . W !,"Error in processing:",!,OUT(1),!
31 . . . W !,"Enter a ""wildcard"" that indicates what part of which"
32 . . . W !,"global variable is to be displayed."
33 . . . W !,"The following examples show the options:"
34 . . . W !," ^MAG(2005,0) - one single node"
35 . . . W !," ^MAG(2005,,100) - 2nd subscript may have any value"
36 . . . W !," ^MAG(2005,50:200,100) - 2nd subscript must be between 50 and 200"
37 . . . W !," ^MAG(2005,""B"",::%S[""JOHN"" - third subscript must contain specific text"
38 . . . W !," ^MAG(2005,,0:0:%D[""JOHN"" - data must contain specific text"
39 . . . S X="^"
40 . . . Q
41 . . S I=1,N=0 F S I=$O(OUT(I)) Q:I="" D
42 . . . S N=N+2
43 . . . W !,OUT(I) S T=$O(OUT(I)) Q:T=""
44 . . . W " = ",OUT(T) S I=T
45 . . . F D Q:T=""
46 . . . . S T=$O(OUT(T)) Q:T="" I OUT(T)'="" S T="" Q
47 . . . . S T=$O(OUT(T)) Q:T="" W OUT(T) S I=T
48 . . . . Q
49 . . . Q
50 . . I N<MAX S X="^" Q
51 . . W !!,"More? YES// " R X:DTIME E S X="^"
52 . . I X="" S X="YES" W X
53 . . I "Yy"'[$E(X_"^",1) S X="^" Q
54 . . S START=OUT(1)
55 . . Q
56 . Q
57 Q
58 ;
59LIST(OUT,WILD,MAX,START) ; RPC = MAG DICOM LIST GLOBAL VARIABLE
60 N %D,E,I,L,M,N,NODE,OK,Q,REF,X
61 I $D(RPC0) D Q:'OK
62 . N KEY,LIST,RET
63 . S KEY="MAG SYSTEM",LIST(1)=KEY D OWNSKEY^XUSRB(.RET,.LIST,DUZ)
64 . S OK=$G(RET(1))
65 . S:'OK OUT(1)="-13,Calling user does not have security key "_KEY
66 . Q
67 I $E($G(WILD),1)'="^" S OUT(1)="-1,Invalid wild-card: "_WILD Q
68 S NODE=0,START=$G(START)\1 S:START<1 START=0
69 S (N,M)=1,Q=0,REF(1,1,1)="" F I=1:1:$L(WILD) D
70 . S E=$E(WILD,I)
71 . I Q S REF(1,N,M)=REF(1,N,M)_E S:E="""" Q=0 Q
72 . I E="""" S Q=1,REF(1,N,M)=REF(1,N,M)_E Q
73 . I "()"[E S N=N+1,REF(1,N)=E,N=N+1,M=1,REF(1,N,1)="" Q
74 . I E="," D Q
75 . . I N=1 S M=M+1,REF(1,1,M)=E,M=M+1,REF(1,1,M)="" Q
76 . . S N=N+1,REF(1,N)=E,N=N+1,M=1,REF(1,N,1)=""
77 . . Q
78 . I N=1,"[|]"[E S M=M+1,REF(1,N,M)=E,M=M+1,REF(1,N,M)="" Q
79 . I " :"[E S M=M+1,REF(1,N,M)=E,M=M+1,REF(1,N,M)="" Q
80 . S REF(1,N,M)=REF(1,N,M)_E
81 . Q
82 K:REF(1,N,M)="" REF(1,N,M)
83 S REF="",I="" F S I=$O(REF(1,1,I)) Q:I="" S REF=REF_REF(1,1,I)
84 S X="-2,Invalid Global Variable Name "_REF D
85 . N $ET
86 . S $ET="S X=X_$EC,$EC="""" Q"
87 . S X=$D(@REF)
88 . Q
89 I X<0 S OUT(1)=X Q
90 S N=0 D TRAVERSE(3,REF_"(")
91 S OUT(1)=NODE
92 Q
93 ;
94TRAVERSE(LEV,ROOT) N FROM,IF,NAME,%S,SEP,TO
95 S NAME=ROOT_"%S)",(FROM,TO,IF)=""
96 I $O(REF(1,LEV,1))="",$G(REF(1,LEV,1))="" D Q
97 . S %S="" F S %S=$O(@NAME) Q:%S="" D SHOW Q:N'<MAX
98 . Q
99 I $O(REF(1,LEV,1))="" D Q
100 . S %S=REF(1,LEV,1)
101 . D:%S'=""
102 . . N $ET
103 . . S $ET="S OK=""-6,Error in subscript-value ""_%S_"": ""_$EC,$EC="""" Q"
104 . . X "S %S="_%S
105 . . Q
106 . D SHOW
107 . Q
108 F SEP=2:2 D Q:'SEP
109 . I '$O(REF(1,LEV,SEP-2)) S SEP=0 Q
110 . S (FROM,TO,IF)=""
111 . I $G(REF(1,LEV,SEP)," ")=" " S %S=REF(1,LEV,SEP-1) D SHOW Q
112 . S FROM=$G(REF(1,LEV,SEP-1)),TO=$G(REF(1,LEV,SEP+1)),SEP=SEP+2
113 . S IF="" I $G(REF(1,LEV,SEP))=":" S IF=$G(REF(1,LEV,SEP+1)),SEP=SEP+2
114 . D:FROM'=""
115 . . N $ET
116 . . S $ET="S OK=""-4,Error in from-value ""_FROM_"": ""_$EC,$EC="""" Q"
117 . . X "S FROM="_FROM
118 . . Q
119 . D:TO'=""
120 . . N $ET
121 . . S $ET="S OK=""-5,Error in to-value ""_TO_"": ""_$EC,$EC="""" Q"
122 . . X "S TO="_TO
123 . . Q
124 . S %S=FROM F D SHOW S %S=$O(@NAME) Q:%S="" I TO'="" Q:%S]]TO
125 . Q
126 Q
127 ;
128Q(X) I +X=X Q X
129 N E,I,R
130 S R="" F I=1:1:$L(X) S E=$E(X,I),R=R_E S:E="""" R=R_E
131 Q """"_R_""""
132 ;
133SHOW N A,C,I,NM,OK,X
134 Q:%S=""
135 S OK='$L(IF)
136 I IF["%S",IF'["%D" D Q:'OK
137 . N $ET
138 . S $ET="S OK=""-3,Error in ""_IF_"": ""_$EC,$EC="""" Q"
139 . X "I "_IF_" S OK=1"
140 . Q
141 D:$D(@NAME)#2
142 . S %D=@NAME I IF'="" D Q:'OK
143 . . N $ET
144 . . S $ET="S OK=""-3,Error in ""_IF_"": ""_$EC,$EC="""" Q"
145 . . X "I "_IF_" S OK=1"
146 . . Q
147 . I OK<0 W !,OK Q
148 . S NODE=NODE+1 I START>0 S START=START-1 Q
149 . S NM=$NA(@NAME)
150 . S X="""",C=0 F I=1:1:$L(%D) D
151 . . S A=$A(%D,I)
152 . . I A>31,A<127,'C S X=X_$C(A) S:A=34 X=X_$C(A) Q
153 . . I A>31,A<127 S C=0,X=X_")_"""_$C(A) S:A=34 X=X_$C(A) Q
154 . . I X="""" S X="$C("_A,C=1 Q
155 . . I C S X=X_","_A Q
156 . . S X=X_"""_$C("_A,C=1
157 . . Q
158 . S X=X_$S(C:")",1:"""")
159 . F D Q:X=""
160 . . S N=N+1,OUT(N+1)=NM,NM=""
161 . . S N=N+1,OUT(N+1)=$E(X,1,250),X=$E(X,251,$L(X))
162 . . Q
163 . Q
164 Q:N'<MAX
165 Q:$G(REF(1,LEV+1))=")"
166 D:OK TRAVERSE(LEV+2,ROOT_$$Q(%S)_",")
167 Q
168 ;
Note: See TracBrowser for help on using the repository browser.