RGUTSTX0 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
;=================================================================
CMD(RGLBL) ;
D:RGLBL'="" @RGLBL
Q
; Postconditional
PC D:$$NEXT(":") EXP()
Q:RGERR
I " "'[$E(RGM,RGPSN) S RGERR=2
E S RGPSN=RGPSN+1
Q
; No postconditional
NPC I $$NEXT(":") S RGERR=5
E I " "'[$E(RGM,RGPSN) S RGERR=2
E S RGPSN=RGPSN+1
Q
; Arguments optional
OPT S:" "[$E(RGM,RGPSN) RGRN=0
Q
; Multiple arguments
ARGS(RGEX) ;
S RGEX=$G(RGEX)
F D EXP(RGEX) Q:RGERR!'$$NEXT(",")
Q
; Expression
EXP(RGEX) ;
D EXP^RGUTSTX1(.RGEX)
Q
; Label reference
LBL(RGA) F D LBL1(.RGA) Q:RGERR!'$$NEXT(",")
Q
LBL1(RGA) ;
S RGA=+$G(RGA)
D LBL2
Q:RGERR
D:$$NEXT("+") EXP(")")
Q:RGERR
D:$$NEXT(U) LBL2
I 'RGERR,RGA=2 D PARAMS(".;0-999")
I 'RGERR,RGA D EXP(")"):$$NEXT(":")
Q
LBL2 I $$NEXT("@") D
.D EXP("=")
E S:$E(RGM,RGPSN)?.1AN.1"%" RGPSN=$$LABEL
Q
; Write command
WRITE F D Q:RGERR!'$$NEXT(",")
.I $$NEXT("!#") D Q:'$$NEXT("?",0)
..F Q:'$$NEXT("!#")
.I $$NEXT("?*")
.D EXP()
Q
; Read command
READ N RGZ
F D Q:RGERR!'$$NEXT(",")
.I $$NEXT("!#") D Q:'$$NEXT("?",0)
..F Q:'$$NEXT("!#")
.I $$NEXT("?") D EXP() Q
.I $$NEXT(RGQT) D QT2^RGUTSTX1 Q
.S RGZ=$$NEXT("*")
.D LVAL("LGS")
.I 'RGERR,'RGZ,$$NEXT("#") D EXP()
.I 'RGERR,$$NEXT(":") D EXP()
Q
; Lock command
LOCK D LIST("LG+:","LG")
Q
; Set command
SET D LIST("LGS=","LGS")
Q
; New command
NEW D LIST("N","")
Q
; Kill command
KILL D LIST("KGL","")
Q
; Merge command
MERGE D LIST("LG=")
Q
; For command
FOR D LVAL("LGS")
I '$$NEXT("=") S RGERR=2 Q
F D Q:" "[$E(RGM,RGPSN) I '$$NEXT(",") S RGERR=2 Q
.D EXP(),EXP():$$NEXT(":"),EXP():$$NEXT(":")
Q
; Evaluate L-value
; RGL: Allowed types:
; L=Local array
; G=Global arrays
; S=Settable intrinsics/system variables
; N=Newable system variables
; K=Killable system variables
LVAL(RGL) ;
I $$NEXT("@",0) D Q
.S RGL="="
.D EXP(.RGL)
S RGL=$G(RGL)
I RGL["G",$$NEXT(U) D Q
.N RGF
.D GLBL^RGUTSTX1
I $TR(RGL,"SNK")'=RGL,$$NEXT("$") D Q
.N RGZ
.S RGZ=$$INT(.RGPSN,RGL)
.D:'RGERR PARAMS(RGZ)
S RGPSN=$$NAME(RGPSN,"%")
I 'RGERR,RGL["L" D PARAMS()
Q
; Evaluate parameters/subscripts
PARAMS(RGX) ;
D:$$NEXT("(") PLIST^RGUTSTX1(.RGX)
Q
; New/Kill/Set/Lock argument list
LIST(RGL1,RGL2) ;
N RGP,RGI
S RGP=0
F D Q:RGERR!'$$NEXT(",")
.I 'RGP,RGL1["+",$$NEXT("+-")
.I $D(RGL2),$$NEXT("(") D Q:RGERR
..I RGP S RGERR=2 Q
..E S RGP=1
.S RGI=$S(RGP:RGL2,1:RGL1)
.D LVAL(.RGI)
.Q:RGERR
.I $$NEXT(")") D Q:RGERR
..I RGP S RGP=0
..E S RGERR=2
.I 'RGP,RGL1[":",$$NEXT(":") D EXP()
.I 'RGP,RGL1["=" D
..I '$$NEXT("=") S:RGI'["@" RGERR=2
..E D EXP():$D(RGL2),LVAL(RGL1):'$D(RGL2)
I 'RGERR,RGP S RGERR=3
Q
; Check for validity of label name
LABEL(RGP) ;
Q $$NAME(.RGP,"L%")
; Check for validity of variable/label name
NAME(RGP,RGF) ;
N RGP1
S (RGP,RGP1)=$G(RGP,RGPSN),RGF=$G(RGF)
I RGF["$",$E(RGM,RGP)="$" S RGP=RGP+1
I RGF["%",$E(RGM,RGP)="%" S RGP=RGP+1
F RGP=RGP:1 Q:$E(RGM,RGP)'?@$S(RGF["L":"1AN",RGP=RGP1:"1A",1:"1AN")
S:RGP=RGP1 RGERR=$S(RGF["L":11,1:1)
Q RGP
; Instrinsic function/system variable
INT(RGP,RGL) ;
N RGP2,RGINT,RGNM
S RGP=$G(RGP,RGPSN),RGP2=$$NAME(RGP),RGL=$G(RGL)
Q:RGERR ""
S RGNM=$E(RGM,RGP,RGP2-1)
I $E(RGM,RGP2)="(" S:$D(^TMP(RGPID,"FCN",RGNM)) RGINT=^(RGNM)
E S:$D(^TMP(RGPID,"SYS",RGNM)) RGINT=^(RGNM)
I '$D(RGINT),RGO["Z" S RGINT=";0-999"
I '$D(RGINT) S RGERR=7
E I RGL'="",$TR(RGL,$P(RGINT,";"))=RGL S RGERR=2,RGINT=""
E S RGP=RGP2
Q $G(RGINT)
; Check next character
NEXT(RGC,RGI) ;
I RGPSN'>RGLEN,RGC[$E(RGM,RGPSN) S RGPSN=RGPSN+$G(RGI,1)
Q $T
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGUTSTX0 3847 printed Oct 16, 2024@18:38:14 Page 2
RGUTSTX0 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
+1 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
+2 ;=================================================================
CMD(RGLBL) ;
+1 if RGLBL'=""
DO @RGLBL
+2 QUIT
+3 ; Postconditional
PC if $$NEXT("
DO EXP()
+1 if RGERR
QUIT
+2 IF " "'[$EXTRACT(RGM,RGPSN)
SET RGERR=2
+3 IF '$TEST
SET RGPSN=RGPSN+1
+4 QUIT
+5 ; No postconditional
NPC IF $$NEXT(":")
SET RGERR=5
+1 IF '$TEST
IF " "'[$EXTRACT(RGM,RGPSN)
SET RGERR=2
+2 IF '$TEST
SET RGPSN=RGPSN+1
+3 QUIT
+4 ; Arguments optional
OPT if " "[$EXTRACT(RGM,RGPSN)
SET RGRN=0
+1 QUIT
+2 ; Multiple arguments
ARGS(RGEX) ;
+1 SET RGEX=$GET(RGEX)
+2 FOR
DO EXP(RGEX)
if RGERR!'$$NEXT(",")
QUIT
+3 QUIT
+4 ; Expression
EXP(RGEX) ;
+1 DO EXP^RGUTSTX1(.RGEX)
+2 QUIT
+3 ; Label reference
LBL(RGA) FOR
DO LBL1(.RGA)
if RGERR!'$$NEXT(",")
QUIT
+1 QUIT
LBL1(RGA) ;
+1 SET RGA=+$GET(RGA)
+2 DO LBL2
+3 if RGERR
QUIT
+4 if $$NEXT("+")
DO EXP(")")
+5 if RGERR
QUIT
+6 if $$NEXT(U)
DO LBL2
+7 IF 'RGERR
IF RGA=2
DO PARAMS(".;0-999")
+8 IF 'RGERR
IF RGA
if $$NEXT(":")
DO EXP(")")
+9 QUIT
LBL2 IF $$NEXT("@")
Begin DoDot:1
+1 DO EXP("=")
End DoDot:1
+2 IF '$TEST
if $EXTRACT(RGM,RGPSN)?.1AN.1"%"
SET RGPSN=$$LABEL
+3 QUIT
+4 ; Write command
WRITE FOR
Begin DoDot:1
+1 IF $$NEXT("!#")
Begin DoDot:2
+2 FOR
if '$$NEXT("!#")
QUIT
End DoDot:2
if '$$NEXT("?",0)
QUIT
+3 IF $$NEXT("?*")
+4 DO EXP()
End DoDot:1
if RGERR!'$$NEXT(",")
QUIT
+5 QUIT
+6 ; Read command
READ NEW RGZ
+1 FOR
Begin DoDot:1
+2 IF $$NEXT("!#")
Begin DoDot:2
+3 FOR
if '$$NEXT("!#")
QUIT
End DoDot:2
if '$$NEXT("?",0)
QUIT
+4 IF $$NEXT("?")
DO EXP()
QUIT
+5 IF $$NEXT(RGQT)
DO QT2^RGUTSTX1
QUIT
+6 SET RGZ=$$NEXT("*")
+7 DO LVAL("LGS")
+8 IF 'RGERR
IF 'RGZ
IF $$NEXT("#")
DO EXP()
+9 IF 'RGERR
IF $$NEXT(":")
DO EXP()
End DoDot:1
if RGERR!'$$NEXT(",")
QUIT
+10 QUIT
+11 ; Lock command
LOCK DO LIST("LG+:","LG")
+1 QUIT
+2 ; Set command
SET DO LIST("LGS=","LGS")
+1 QUIT
+2 ; New command
NEW DO LIST("N","")
+1 QUIT
+2 ; Kill command
KILL DO LIST("KGL","")
+1 QUIT
+2 ; Merge command
MERGE DO LIST("LG=")
+1 QUIT
+2 ; For command
FOR DO LVAL("LGS")
+1 IF '$$NEXT("=")
SET RGERR=2
QUIT
+2 FOR
Begin DoDot:1
+3 DO EXP()
if $$NEXT(":")
DO EXP()
if $$NEXT(":")
DO EXP()
End DoDot:1
if " "[$EXTRACT(RGM,RGPSN)
QUIT
IF '$$NEXT(",")
SET RGERR=2
QUIT
+4 QUIT
+5 ; Evaluate L-value
+6 ; RGL: Allowed types:
+7 ; L=Local array
+8 ; G=Global arrays
+9 ; S=Settable intrinsics/system variables
+10 ; N=Newable system variables
+11 ; K=Killable system variables
LVAL(RGL) ;
+1 IF $$NEXT("@",0)
Begin DoDot:1
+2 SET RGL="="
+3 DO EXP(.RGL)
End DoDot:1
QUIT
+4 SET RGL=$GET(RGL)
+5 IF RGL["G"
IF $$NEXT(U)
Begin DoDot:1
+6 NEW RGF
+7 DO GLBL^RGUTSTX1
End DoDot:1
QUIT
+8 IF $TRANSLATE(RGL,"SNK")'=RGL
IF $$NEXT("$")
Begin DoDot:1
+9 NEW RGZ
+10 SET RGZ=$$INT(.RGPSN,RGL)
+11 if 'RGERR
DO PARAMS(RGZ)
End DoDot:1
QUIT
+12 SET RGPSN=$$NAME(RGPSN,"%")
+13 IF 'RGERR
IF RGL["L"
DO PARAMS()
+14 QUIT
+15 ; Evaluate parameters/subscripts
PARAMS(RGX) ;
+1 if $$NEXT("(")
DO PLIST^RGUTSTX1(.RGX)
+2 QUIT
+3 ; New/Kill/Set/Lock argument list
LIST(RGL1,RGL2) ;
+1 NEW RGP,RGI
+2 SET RGP=0
+3 FOR
Begin DoDot:1
+4 IF 'RGP
IF RGL1["+"
IF $$NEXT("+-")
+5 IF $DATA(RGL2)
IF $$NEXT("(")
Begin DoDot:2
+6 IF RGP
SET RGERR=2
QUIT
+7 IF '$TEST
SET RGP=1
End DoDot:2
if RGERR
QUIT
+8 SET RGI=$SELECT(RGP:RGL2,1:RGL1)
+9 DO LVAL(.RGI)
+10 if RGERR
QUIT
+11 IF $$NEXT(")")
Begin DoDot:2
+12 IF RGP
SET RGP=0
+13 IF '$TEST
SET RGERR=2
End DoDot:2
if RGERR
QUIT
+14 IF 'RGP
IF RGL1[":"
IF $$NEXT(":")
DO EXP()
+15 IF 'RGP
IF RGL1["="
Begin DoDot:2
+16 IF '$$NEXT("=")
if RGI'["@"
SET RGERR=2
+17 IF '$TEST
if $DATA(RGL2)
DO EXP()
if '$DATA(RGL2)
DO LVAL(RGL1)
End DoDot:2
End DoDot:1
if RGERR!'$$NEXT(",")
QUIT
+18 IF 'RGERR
IF RGP
SET RGERR=3
+19 QUIT
+20 ; Check for validity of label name
LABEL(RGP) ;
+1 QUIT $$NAME(.RGP,"L%")
+2 ; Check for validity of variable/label name
NAME(RGP,RGF) ;
+1 NEW RGP1
+2 SET (RGP,RGP1)=$GET(RGP,RGPSN)
SET RGF=$GET(RGF)
+3 IF RGF["$"
IF $EXTRACT(RGM,RGP)="$"
SET RGP=RGP+1
+4 IF RGF["%"
IF $EXTRACT(RGM,RGP)="%"
SET RGP=RGP+1
+5 FOR RGP=RGP:1
if $EXTRACT(RGM,RGP)'?@$SELECT(RGF["L"
QUIT
+6 if RGP=RGP1
SET RGERR=$SELECT(RGF["L":11,1:1)
+7 QUIT RGP
+8 ; Instrinsic function/system variable
INT(RGP,RGL) ;
+1 NEW RGP2,RGINT,RGNM
+2 SET RGP=$GET(RGP,RGPSN)
SET RGP2=$$NAME(RGP)
SET RGL=$GET(RGL)
+3 if RGERR
QUIT ""
+4 SET RGNM=$EXTRACT(RGM,RGP,RGP2-1)
+5 IF $EXTRACT(RGM,RGP2)="("
if $DATA(^TMP(RGPID,"FCN",RGNM))
SET RGINT=^(RGNM)
+6 IF '$TEST
if $DATA(^TMP(RGPID,"SYS",RGNM))
SET RGINT=^(RGNM)
+7 IF '$DATA(RGINT)
IF RGO["Z"
SET RGINT=";0-999"
+8 IF '$DATA(RGINT)
SET RGERR=7
+9 IF '$TEST
IF RGL'=""
IF $TRANSLATE(RGL,$PIECE(RGINT,";"))=RGL
SET RGERR=2
SET RGINT=""
+10 IF '$TEST
SET RGP=RGP2
+11 QUIT $GET(RGINT)
+12 ; Check next character
NEXT(RGC,RGI) ;
+1 IF RGPSN'>RGLEN
IF RGC[$EXTRACT(RGM,RGPSN)
SET RGPSN=RGPSN+$GET(RGI,1)
+2 QUIT $TEST
