source: WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGUTSTX0.m@ 1685

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1RGUTSTX0 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
2 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
3 ;=================================================================
4CMD(RGLBL) ;
5 D:RGLBL'="" @RGLBL
6 Q
7 ; Postconditional
8PC D:$$NEXT(":") EXP()
9 Q:RGERR
10 I " "'[$E(RGM,RGPSN) S RGERR=2
11 E S RGPSN=RGPSN+1
12 Q
13 ; No postconditional
14NPC I $$NEXT(":") S RGERR=5
15 E I " "'[$E(RGM,RGPSN) S RGERR=2
16 E S RGPSN=RGPSN+1
17 Q
18 ; Arguments optional
19OPT S:" "[$E(RGM,RGPSN) RGRN=0
20 Q
21 ; Multiple arguments
22ARGS(RGEX) ;
23 S RGEX=$G(RGEX)
24 F D EXP(RGEX) Q:RGERR!'$$NEXT(",")
25 Q
26 ; Expression
27EXP(RGEX) ;
28 D EXP^RGUTSTX1(.RGEX)
29 Q
30 ; Label reference
31LBL(RGA) F D LBL1(.RGA) Q:RGERR!'$$NEXT(",")
32 Q
33LBL1(RGA) ;
34 S RGA=+$G(RGA)
35 D LBL2
36 Q:RGERR
37 D:$$NEXT("+") EXP(")")
38 Q:RGERR
39 D:$$NEXT(U) LBL2
40 I 'RGERR,RGA=2 D PARAMS(".;0-999")
41 I 'RGERR,RGA D EXP(")"):$$NEXT(":")
42 Q
43LBL2 I $$NEXT("@") D
44 .D EXP("=")
45 E S:$E(RGM,RGPSN)?.1AN.1"%" RGPSN=$$LABEL
46 Q
47 ; Write command
48WRITE F D Q:RGERR!'$$NEXT(",")
49 .I $$NEXT("!#") D Q:'$$NEXT("?",0)
50 ..F Q:'$$NEXT("!#")
51 .I $$NEXT("?*")
52 .D EXP()
53 Q
54 ; Read command
55READ N RGZ
56 F D Q:RGERR!'$$NEXT(",")
57 .I $$NEXT("!#") D Q:'$$NEXT("?",0)
58 ..F Q:'$$NEXT("!#")
59 .I $$NEXT("?") D EXP() Q
60 .I $$NEXT(RGQT) D QT2^RGUTSTX1 Q
61 .S RGZ=$$NEXT("*")
62 .D LVAL("LGS")
63 .I 'RGERR,'RGZ,$$NEXT("#") D EXP()
64 .I 'RGERR,$$NEXT(":") D EXP()
65 Q
66 ; Lock command
67LOCK D LIST("LG+:","LG")
68 Q
69 ; Set command
70SET D LIST("LGS=","LGS")
71 Q
72 ; New command
73NEW D LIST("N","")
74 Q
75 ; Kill command
76KILL D LIST("KGL","")
77 Q
78 ; Merge command
79MERGE D LIST("LG=")
80 Q
81 ; For command
82FOR D LVAL("LGS")
83 I '$$NEXT("=") S RGERR=2 Q
84 F D Q:" "[$E(RGM,RGPSN) I '$$NEXT(",") S RGERR=2 Q
85 .D EXP(),EXP():$$NEXT(":"),EXP():$$NEXT(":")
86 Q
87 ; Evaluate L-value
88 ; RGL: Allowed types:
89 ; L=Local array
90 ; G=Global arrays
91 ; S=Settable intrinsics/system variables
92 ; N=Newable system variables
93 ; K=Killable system variables
94LVAL(RGL) ;
95 I $$NEXT("@",0) D Q
96 .S RGL="="
97 .D EXP(.RGL)
98 S RGL=$G(RGL)
99 I RGL["G",$$NEXT(U) D Q
100 .N RGF
101 .D GLBL^RGUTSTX1
102 I $TR(RGL,"SNK")'=RGL,$$NEXT("$") D Q
103 .N RGZ
104 .S RGZ=$$INT(.RGPSN,RGL)
105 .D:'RGERR PARAMS(RGZ)
106 S RGPSN=$$NAME(RGPSN,"%")
107 I 'RGERR,RGL["L" D PARAMS()
108 Q
109 ; Evaluate parameters/subscripts
110PARAMS(RGX) ;
111 D:$$NEXT("(") PLIST^RGUTSTX1(.RGX)
112 Q
113 ; New/Kill/Set/Lock argument list
114LIST(RGL1,RGL2) ;
115 N RGP,RGI
116 S RGP=0
117 F D Q:RGERR!'$$NEXT(",")
118 .I 'RGP,RGL1["+",$$NEXT("+-")
119 .I $D(RGL2),$$NEXT("(") D Q:RGERR
120 ..I RGP S RGERR=2 Q
121 ..E S RGP=1
122 .S RGI=$S(RGP:RGL2,1:RGL1)
123 .D LVAL(.RGI)
124 .Q:RGERR
125 .I $$NEXT(")") D Q:RGERR
126 ..I RGP S RGP=0
127 ..E S RGERR=2
128 .I 'RGP,RGL1[":",$$NEXT(":") D EXP()
129 .I 'RGP,RGL1["=" D
130 ..I '$$NEXT("=") S:RGI'["@" RGERR=2
131 ..E D EXP():$D(RGL2),LVAL(RGL1):'$D(RGL2)
132 I 'RGERR,RGP S RGERR=3
133 Q
134 ; Check for validity of label name
135LABEL(RGP) ;
136 Q $$NAME(.RGP,"L%")
137 ; Check for validity of variable/label name
138NAME(RGP,RGF) ;
139 N RGP1
140 S (RGP,RGP1)=$G(RGP,RGPSN),RGF=$G(RGF)
141 I RGF["$",$E(RGM,RGP)="$" S RGP=RGP+1
142 I RGF["%",$E(RGM,RGP)="%" S RGP=RGP+1
143 F RGP=RGP:1 Q:$E(RGM,RGP)'?@$S(RGF["L":"1AN",RGP=RGP1:"1A",1:"1AN")
144 S:RGP=RGP1 RGERR=$S(RGF["L":11,1:1)
145 Q RGP
146 ; Instrinsic function/system variable
147INT(RGP,RGL) ;
148 N RGP2,RGINT,RGNM
149 S RGP=$G(RGP,RGPSN),RGP2=$$NAME(RGP),RGL=$G(RGL)
150 Q:RGERR ""
151 S RGNM=$E(RGM,RGP,RGP2-1)
152 I $E(RGM,RGP2)="(" S:$D(^TMP(RGPID,"FCN",RGNM)) RGINT=^(RGNM)
153 E S:$D(^TMP(RGPID,"SYS",RGNM)) RGINT=^(RGNM)
154 I '$D(RGINT),RGO["Z" S RGINT=";0-999"
155 I '$D(RGINT) S RGERR=7
156 E I RGL'="",$TR(RGL,$P(RGINT,";"))=RGL S RGERR=2,RGINT=""
157 E S RGP=RGP2
158 Q $G(RGINT)
159 ; Check next character
160NEXT(RGC,RGI) ;
161 I RGPSN'>RGLEN,RGC[$E(RGM,RGPSN) S RGPSN=RGPSN+$G(RGI,1)
162 Q $T
Note: See TracBrowser for help on using the repository browser.