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

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

initial load of WorldVistAEHR

File size: 3.8 KB
RevLine 
[613]1RGUTSTX1 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
2 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
3 ;=================================================================
4 ; Parse an expression
5EXP(RGEX) ;
6 N RGF,RGC,RGPN
7 S (RGF,RGPN)=0,RGEX=$G(RGEX)
8 F D Q:RGF<0!RGERR
9 .S RGC=$E(RGM,RGPSN),RGPSN=RGPSN+1
10 .D @("OP"_RGF)
11 I 'RGERR,RGPN S RGERR=3
12 S RGEX=$S($G(RGPN(RGPN,"@")):"@",1:"")_RGEX
13 Q
14 ; Operands
15OP0 I RGC'=".",RGEX["." S RGEX=$TR(RGEX,".")
16 G:RGC'="" COLON2:RGC=":",GLBL:RGC=U,DOT:RGC=".",INDIR:RGC="@",FCN:RGC="$",UNARY:"'+-"[RGC,QT:RGC=RGQT,NUM:RGC?1N,OPNPAR:RGC="(",VAR:RGC?1A,VAR:RGC="%"
17 S RGERR=6
18 Q
19 ; Operators
20OP1 G END:RGC="",INDIR2:RGC="@",DONE:RGEX["="&'RGPN!(RGC=" ")
21 K RGPN(RGPN,"@")
22 G COLON:RGC=":",CLSPAR:RGC=")",RBRKT:RGC="]",BINARY:"!#&*-_+=\/<>["[RGC,NOT:RGC="'",PTRN:RGC="?"
23DONE S RGPSN=RGPSN-1
24END S RGF=-1
25 Q
26 ; Negated operator
27NOT S:'$$NEXT("=<>[]?&!",0) RGERR=2
28 Q
29 ; Parse a global reference
30GLBL D:$$NEXT("[") PLIST(";1-2","]")
31 Q:RGERR
32 S:'$$NEXT("(",0) RGPSN=$$NAME^RGUTSTX0(RGPSN,"$%")
33 I 'RGERR,$$NEXT("(") D PLIST(";1-999")
34 S RGF=1
35 Q
36 ; Indirection (prefix)
37INDIR S RGPN(RGPN,"@")=$G(RGPN(RGPN,"@"))+1
38 Q
39 ; Indirection (suffix)
40INDIR2 I +$G(RGPN(RGPN,"@"))'>0 S RGERR=2
41 E I '$$NEXT("(") S RGERR=2
42 E D
43 .S RGPN(RGPN,"@")=-(RGPN(RGPN,"@")>1)
44 .D PLIST()
45 Q
46 ; Intrinsic function/system variable
47FCN G:$$NEXT("$") EXT
48INT N RGZ,RGZ1
49 S RGZ1=$E(RGM,RGPSN),RGZ=$$INT^RGUTSTX0(.RGPSN),RGF=1
50 I 'RGERR,$$NEXT("(") D PLIST(RGZ)
51 Q
52 ; Extrinsic function
53EXT S:'$$NEXT(U,0) RGPSN=$$LABEL^RGUTSTX0
54 Q:RGERR
55 S:$$NEXT(U) RGPSN=$$LABEL^RGUTSTX0
56 Q:RGERR
57 D:$$NEXT("(") PLIST(".;0-999")
58 S RGF=1
59 Q
60 ; Unary operator
61UNARY Q
62 ; String literal
63QT D QT2
64 S RGF=1
65 Q
66 ; Find matching quote
67QT2 F RGPSN=RGPSN:1:RGLEN I $$NEXT(RGQT),'$$NEXT(RGQT,0) Q
68 S:$E(RGM,RGPSN-1)'=RGQT RGERR=9
69 Q
70 ; Numeric constant
71NUM N RGZ,RGZ1
72 S RGZ=0,RGF=1
73 F RGPSN=RGPSN-1:1 S RGZ1=$E(RGM,RGPSN) D @("NUM"_RGZ) Q:RGZ<0
74 S:RGZ=-2 RGERR=2
75 Q
76NUM0 S RGZ=$S(RGZ1?1N:1,RGZ1=".":2,1:-2)
77 Q
78NUM1 S RGZ=$S(RGZ1?1N:1,RGZ1=".":3,1:-1)
79 Q
80NUM2 S RGZ=$S(RGZ1?1N:3,1:-2)
81 Q
82NUM3 S RGZ=$S(RGZ1?1N:3,RGZ1="E":4,1:-1)
83 Q
84NUM4 S RGZ=$S(RGZ1="+":5,RGZ1="-":5,RGZ1=".":7,RGZ1?1N:6,1:-2)
85 Q
86NUM5 S RGZ=$S(RGZ1?1N:6,RGZ1=".":7,1:-2)
87 Q
88NUM6 S RGZ=$S(RGZ1?1N:6,RGZ1=".":8,1:-1)
89 Q
90NUM7 S RGZ=$S(RGZ1?1N:8,1:-2)
91 Q
92NUM8 S RGZ=$S(RGZ1?1N:8,1:-1)
93 Q
94 ; Open parenthesis
95OPNPAR S RGPN=RGPN+1
96 K RGPN(RGPN)
97 Q
98 ; Period (variable by reference or FP number)
99DOT I RGEX[".",$E(RGM,RGPSN)'?1N D
100 .I '$$NEXT("@") S RGPSN=$$NAME^RGUTSTX0(RGPSN,"%"),RGF=-1
101 .E D INDIR
102 E D NUM
103 Q
104 ; Variable name
105VAR S RGPSN=$$NAME^RGUTSTX0(RGPSN-1,"%"),RGF=1
106 D:$$NEXT("(") PLIST()
107 Q
108 ; Closing parenthesis
109CLSPAR I 'RGPN,RGEX[")" G DONE
110 I RGPN S RGPN=RGPN-1
111 E S RGERR=3
112 Q
113 ; Right bracket (] or ]])
114RBRKT I 'RGPN,RGEX["]" G DONE
115 I $$NEXT(RGC)
116 ; Binary operator
117BINARY S RGF=0
118 Q
119 ; Colon operand
120COLON2 S:RGEX'["M" RGERR=6
121 Q
122 ; Colon operator
123COLON G:RGEX'[":" DONE
124 S RGF=0
125 S:RGEX'["M" RGEX=$TR(RGEX,":")
126 Q
127 ; Pattern match
128PTRN N RGZ,RGZ1
129 I $$NEXT("@") S RGF=0 Q
130 S RGZ=RGPSN,@$$TRAP^RGZOSF("PERR^RGUTSTX1"),RGZ1=0
131 F D Q:RGZ1<0!RGERR
132 .D QT2:$$NEXT(RGQT),PTRN1:$$NEXT("("),PTRN2:$$NEXT(")")
133 .I RGZ1,$$NEXT(",")
134 .S:'$$NEXT("ACELNPU.0123456789") RGZ1=-1
135 S:'RGERR RGZ=RGZ?@$E(RGM,RGZ,RGPSN-1)
136 Q
137PTRN1 S RGZ1=RGZ1+1
138 Q
139PTRN2 S RGZ1=RGZ1-1
140 S:RGZ1<0 RGPSN=RGPSN-1
141 Q
142PERR S RGERR=10
143 Q
144 ; Process a parameter list
145PLIST(RGP,RGT) ;
146 N RGC,RGP1,RGP2,RGZ
147 S RGT=$G(RGT,")"),RGP=$G(RGP,";0-999"),RGP2=$P(RGP,";",2),RGP1=+RGP2,RGP2=+$P(RGP2,"-",2),RGC=0,RGZ=$P(RGP,";")
148 I '$$NEXT(RGT,0) D
149 .F RGC=1:1 D Q:RGERR!'$$NEXT(",")
150 ..D @("PL"_$P(RGP,";",RGC+2))
151 I 'RGERR,RGC<RGP1!(RGC>RGP2) S RGERR=8
152 I 'RGERR,'$$NEXT(RGT) S RGERR=3
153 Q
154PL N RGEX
155 I RGZ=".",$$NEXT(",",0) Q
156 S RGEX=RGT_RGZ
157 D EXP(.RGEX)
158 I RGZ[":",RGEX[":" S RGERR=2
159 Q
160PLV D LVAL^RGUTSTX0("LG")
161 Q
162PLL D LBL1^RGUTSTX0()
163 Q
164 ; Get next character
165NEXT(RGC,RGI) ;
166 Q $$NEXT^RGUTSTX0(RGC,.RGI)
Note: See TracBrowser for help on using the repository browser.