| [613] | 1 | RGUTSTX0 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
|
|---|
| 2 | ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
|
|---|
| 3 | ;=================================================================
|
|---|
| 4 | CMD(RGLBL) ;
|
|---|
| 5 | D:RGLBL'="" @RGLBL
|
|---|
| 6 | Q
|
|---|
| 7 | ; Postconditional
|
|---|
| 8 | PC 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
|
|---|
| 14 | NPC 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
|
|---|
| 19 | OPT S:" "[$E(RGM,RGPSN) RGRN=0
|
|---|
| 20 | Q
|
|---|
| 21 | ; Multiple arguments
|
|---|
| 22 | ARGS(RGEX) ;
|
|---|
| 23 | S RGEX=$G(RGEX)
|
|---|
| 24 | F D EXP(RGEX) Q:RGERR!'$$NEXT(",")
|
|---|
| 25 | Q
|
|---|
| 26 | ; Expression
|
|---|
| 27 | EXP(RGEX) ;
|
|---|
| 28 | D EXP^RGUTSTX1(.RGEX)
|
|---|
| 29 | Q
|
|---|
| 30 | ; Label reference
|
|---|
| 31 | LBL(RGA) F D LBL1(.RGA) Q:RGERR!'$$NEXT(",")
|
|---|
| 32 | Q
|
|---|
| 33 | LBL1(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
|
|---|
| 43 | LBL2 I $$NEXT("@") D
|
|---|
| 44 | .D EXP("=")
|
|---|
| 45 | E S:$E(RGM,RGPSN)?.1AN.1"%" RGPSN=$$LABEL
|
|---|
| 46 | Q
|
|---|
| 47 | ; Write command
|
|---|
| 48 | WRITE 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
|
|---|
| 55 | READ 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
|
|---|
| 67 | LOCK D LIST("LG+:","LG")
|
|---|
| 68 | Q
|
|---|
| 69 | ; Set command
|
|---|
| 70 | SET D LIST("LGS=","LGS")
|
|---|
| 71 | Q
|
|---|
| 72 | ; New command
|
|---|
| 73 | NEW D LIST("N","")
|
|---|
| 74 | Q
|
|---|
| 75 | ; Kill command
|
|---|
| 76 | KILL D LIST("KGL","")
|
|---|
| 77 | Q
|
|---|
| 78 | ; Merge command
|
|---|
| 79 | MERGE D LIST("LG=")
|
|---|
| 80 | Q
|
|---|
| 81 | ; For command
|
|---|
| 82 | FOR 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
|
|---|
| 94 | LVAL(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
|
|---|
| 110 | PARAMS(RGX) ;
|
|---|
| 111 | D:$$NEXT("(") PLIST^RGUTSTX1(.RGX)
|
|---|
| 112 | Q
|
|---|
| 113 | ; New/Kill/Set/Lock argument list
|
|---|
| 114 | LIST(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
|
|---|
| 135 | LABEL(RGP) ;
|
|---|
| 136 | Q $$NAME(.RGP,"L%")
|
|---|
| 137 | ; Check for validity of variable/label name
|
|---|
| 138 | NAME(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
|
|---|
| 147 | INT(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
|
|---|
| 160 | NEXT(RGC,RGI) ;
|
|---|
| 161 | I RGPSN'>RGLEN,RGC[$E(RGM,RGPSN) S RGPSN=RGPSN+$G(RGI,1)
|
|---|
| 162 | Q $T
|
|---|
