RGUTSTX1 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
;=================================================================
; Parse an expression
EXP(RGEX) ;
N RGF,RGC,RGPN
S (RGF,RGPN)=0,RGEX=$G(RGEX)
F D Q:RGF<0!RGERR
.S RGC=$E(RGM,RGPSN),RGPSN=RGPSN+1
.D @("OP"_RGF)
I 'RGERR,RGPN S RGERR=3
S RGEX=$S($G(RGPN(RGPN,"@")):"@",1:"")_RGEX
Q
; Operands
OP0 I RGC'=".",RGEX["." S RGEX=$TR(RGEX,".")
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="%"
S RGERR=6
Q
; Operators
OP1 G END:RGC="",INDIR2:RGC="@",DONE:RGEX["="&'RGPN!(RGC=" ")
K RGPN(RGPN,"@")
G COLON:RGC=":",CLSPAR:RGC=")",RBRKT:RGC="]",BINARY:"!#&*-_+=\/<>["[RGC,NOT:RGC="'",PTRN:RGC="?"
DONE S RGPSN=RGPSN-1
END S RGF=-1
Q
; Negated operator
NOT S:'$$NEXT("=<>[]?&!",0) RGERR=2
Q
; Parse a global reference
GLBL D:$$NEXT("[") PLIST(";1-2","]")
Q:RGERR
S:'$$NEXT("(",0) RGPSN=$$NAME^RGUTSTX0(RGPSN,"$%")
I 'RGERR,$$NEXT("(") D PLIST(";1-999")
S RGF=1
Q
; Indirection (prefix)
INDIR S RGPN(RGPN,"@")=$G(RGPN(RGPN,"@"))+1
Q
; Indirection (suffix)
INDIR2 I +$G(RGPN(RGPN,"@"))'>0 S RGERR=2
E I '$$NEXT("(") S RGERR=2
E D
.S RGPN(RGPN,"@")=-(RGPN(RGPN,"@")>1)
.D PLIST()
Q
; Intrinsic function/system variable
FCN G:$$NEXT("$") EXT
INT N RGZ,RGZ1
S RGZ1=$E(RGM,RGPSN),RGZ=$$INT^RGUTSTX0(.RGPSN),RGF=1
I 'RGERR,$$NEXT("(") D PLIST(RGZ)
Q
; Extrinsic function
EXT S:'$$NEXT(U,0) RGPSN=$$LABEL^RGUTSTX0
Q:RGERR
S:$$NEXT(U) RGPSN=$$LABEL^RGUTSTX0
Q:RGERR
D:$$NEXT("(") PLIST(".;0-999")
S RGF=1
Q
; Unary operator
UNARY Q
; String literal
QT D QT2
S RGF=1
Q
; Find matching quote
QT2 F RGPSN=RGPSN:1:RGLEN I $$NEXT(RGQT),'$$NEXT(RGQT,0) Q
S:$E(RGM,RGPSN-1)'=RGQT RGERR=9
Q
; Numeric constant
NUM N RGZ,RGZ1
S RGZ=0,RGF=1
F RGPSN=RGPSN-1:1 S RGZ1=$E(RGM,RGPSN) D @("NUM"_RGZ) Q:RGZ<0
S:RGZ=-2 RGERR=2
Q
NUM0 S RGZ=$S(RGZ1?1N:1,RGZ1=".":2,1:-2)
Q
NUM1 S RGZ=$S(RGZ1?1N:1,RGZ1=".":3,1:-1)
Q
NUM2 S RGZ=$S(RGZ1?1N:3,1:-2)
Q
NUM3 S RGZ=$S(RGZ1?1N:3,RGZ1="E":4,1:-1)
Q
NUM4 S RGZ=$S(RGZ1="+":5,RGZ1="-":5,RGZ1=".":7,RGZ1?1N:6,1:-2)
Q
NUM5 S RGZ=$S(RGZ1?1N:6,RGZ1=".":7,1:-2)
Q
NUM6 S RGZ=$S(RGZ1?1N:6,RGZ1=".":8,1:-1)
Q
NUM7 S RGZ=$S(RGZ1?1N:8,1:-2)
Q
NUM8 S RGZ=$S(RGZ1?1N:8,1:-1)
Q
; Open parenthesis
OPNPAR S RGPN=RGPN+1
K RGPN(RGPN)
Q
; Period (variable by reference or FP number)
DOT I RGEX[".",$E(RGM,RGPSN)'?1N D
.I '$$NEXT("@") S RGPSN=$$NAME^RGUTSTX0(RGPSN,"%"),RGF=-1
.E D INDIR
E D NUM
Q
; Variable name
VAR S RGPSN=$$NAME^RGUTSTX0(RGPSN-1,"%"),RGF=1
D:$$NEXT("(") PLIST()
Q
; Closing parenthesis
CLSPAR I 'RGPN,RGEX[")" G DONE
I RGPN S RGPN=RGPN-1
E S RGERR=3
Q
; Right bracket (] or ]])
RBRKT I 'RGPN,RGEX["]" G DONE
I $$NEXT(RGC)
; Binary operator
BINARY S RGF=0
Q
; Colon operand
COLON2 S:RGEX'["M" RGERR=6
Q
; Colon operator
COLON G:RGEX'[":" DONE
S RGF=0
S:RGEX'["M" RGEX=$TR(RGEX,":")
Q
; Pattern match
PTRN N RGZ,RGZ1
I $$NEXT("@") S RGF=0 Q
S RGZ=RGPSN,@$$TRAP^RGZOSF("PERR^RGUTSTX1"),RGZ1=0
F D Q:RGZ1<0!RGERR
.D QT2:$$NEXT(RGQT),PTRN1:$$NEXT("("),PTRN2:$$NEXT(")")
.I RGZ1,$$NEXT(",")
.S:'$$NEXT("ACELNPU.0123456789") RGZ1=-1
S:'RGERR RGZ=RGZ?@$E(RGM,RGZ,RGPSN-1)
Q
PTRN1 S RGZ1=RGZ1+1
Q
PTRN2 S RGZ1=RGZ1-1
S:RGZ1<0 RGPSN=RGPSN-1
Q
PERR S RGERR=10
Q
; Process a parameter list
PLIST(RGP,RGT) ;
N RGC,RGP1,RGP2,RGZ
S RGT=$G(RGT,")"),RGP=$G(RGP,";0-999"),RGP2=$P(RGP,";",2),RGP1=+RGP2,RGP2=+$P(RGP2,"-",2),RGC=0,RGZ=$P(RGP,";")
I '$$NEXT(RGT,0) D
.F RGC=1:1 D Q:RGERR!'$$NEXT(",")
..D @("PL"_$P(RGP,";",RGC+2))
I 'RGERR,RGC<RGP1!(RGC>RGP2) S RGERR=8
I 'RGERR,'$$NEXT(RGT) S RGERR=3
Q
PL N RGEX
I RGZ=".",$$NEXT(",",0) Q
S RGEX=RGT_RGZ
D EXP(.RGEX)
I RGZ[":",RGEX[":" S RGERR=2
Q
PLV D LVAL^RGUTSTX0("LG")
Q
PLL D LBL1^RGUTSTX0()
Q
; Get next character
NEXT(RGC,RGI) ;
Q $$NEXT^RGUTSTX0(RGC,.RGI)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGUTSTX1 4108 printed Dec 13, 2024@02:37:32 Page 2
RGUTSTX1 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
+1 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
+2 ;=================================================================
+3 ; Parse an expression
EXP(RGEX) ;
+1 NEW RGF,RGC,RGPN
+2 SET (RGF,RGPN)=0
SET RGEX=$GET(RGEX)
+3 FOR
Begin DoDot:1
+4 SET RGC=$EXTRACT(RGM,RGPSN)
SET RGPSN=RGPSN+1
+5 DO @("OP"_RGF)
End DoDot:1
if RGF<0!RGERR
QUIT
+6 IF 'RGERR
IF RGPN
SET RGERR=3
+7 SET RGEX=$SELECT($GET(RGPN(RGPN,"@")):"@",1:"")_RGEX
+8 QUIT
+9 ; Operands
OP0 IF RGC'="."
IF RGEX["."
SET RGEX=$TRANSLATE(RGEX,".")
+1 if RGC'=""
if RGC=":"
GOTO COLON2
if RGC=U
GOTO GLBL
if RGC="."
GOTO DOT
if RGC="@"
GOTO INDIR
if RGC="$"
GOTO FCN
if "'+-"[RGC
GOTO UNARY
if RGC=RGQT
GOTO QT
if RGC?1N
GOTO NUM
if RGC="("
GOTO OPNPAR
if RGC?1A
GOTO VAR
if RGC="%"
GOTO VAR
+2 SET RGERR=6
+3 QUIT
+4 ; Operators
OP1 if RGC=""
GOTO END
if RGC="@"
GOTO INDIR2
if RGEX["="&'RGPN!(RGC=" ")
GOTO DONE
+1 KILL RGPN(RGPN,"@")
+2 if RGC=":"
GOTO COLON
if RGC=")"
GOTO CLSPAR
if RGC="]"
GOTO RBRKT
if "!#&*-_+=\/<>["[RGC
GOTO BINARY
if RGC="'"
GOTO NOT
if RGC="?"
GOTO PTRN
DONE SET RGPSN=RGPSN-1
END SET RGF=-1
+1 QUIT
+2 ; Negated operator
NOT if '$$NEXT("=<>[]?&!",0)
SET RGERR=2
+1 QUIT
+2 ; Parse a global reference
GLBL if $$NEXT("[")
DO PLIST(";1-2","]")
+1 if RGERR
QUIT
+2 if '$$NEXT("(",0)
SET RGPSN=$$NAME^RGUTSTX0(RGPSN,"$%")
+3 IF 'RGERR
IF $$NEXT("(")
DO PLIST(";1-999")
+4 SET RGF=1
+5 QUIT
+6 ; Indirection (prefix)
INDIR SET RGPN(RGPN,"@")=$GET(RGPN(RGPN,"@"))+1
+1 QUIT
+2 ; Indirection (suffix)
INDIR2 IF +$GET(RGPN(RGPN,"@"))'>0
SET RGERR=2
+1 IF '$TEST
IF '$$NEXT("(")
SET RGERR=2
+2 IF '$TEST
Begin DoDot:1
+3 SET RGPN(RGPN,"@")=-(RGPN(RGPN,"@")>1)
+4 DO PLIST()
End DoDot:1
+5 QUIT
+6 ; Intrinsic function/system variable
FCN if $$NEXT("$")
GOTO EXT
INT NEW RGZ,RGZ1
+1 SET RGZ1=$EXTRACT(RGM,RGPSN)
SET RGZ=$$INT^RGUTSTX0(.RGPSN)
SET RGF=1
+2 IF 'RGERR
IF $$NEXT("(")
DO PLIST(RGZ)
+3 QUIT
+4 ; Extrinsic function
EXT if '$$NEXT(U,0)
SET RGPSN=$$LABEL^RGUTSTX0
+1 if RGERR
QUIT
+2 if $$NEXT(U)
SET RGPSN=$$LABEL^RGUTSTX0
+3 if RGERR
QUIT
+4 if $$NEXT("(")
DO PLIST(".;0-999")
+5 SET RGF=1
+6 QUIT
+7 ; Unary operator
UNARY QUIT
+1 ; String literal
QT DO QT2
+1 SET RGF=1
+2 QUIT
+3 ; Find matching quote
QT2 FOR RGPSN=RGPSN:1:RGLEN
IF $$NEXT(RGQT)
IF '$$NEXT(RGQT,0)
QUIT
+1 if $EXTRACT(RGM,RGPSN-1)'=RGQT
SET RGERR=9
+2 QUIT
+3 ; Numeric constant
NUM NEW RGZ,RGZ1
+1 SET RGZ=0
SET RGF=1
+2 FOR RGPSN=RGPSN-1:1
SET RGZ1=$EXTRACT(RGM,RGPSN)
DO @("NUM"_RGZ)
if RGZ<0
QUIT
+3 if RGZ=-2
SET RGERR=2
+4 QUIT
NUM0 SET RGZ=$SELECT(RGZ1?1N:1,RGZ1=".":2,1:-2)
+1 QUIT
NUM1 SET RGZ=$SELECT(RGZ1?1N:1,RGZ1=".":3,1:-1)
+1 QUIT
NUM2 SET RGZ=$SELECT(RGZ1?1N:3,1:-2)
+1 QUIT
NUM3 SET RGZ=$SELECT(RGZ1?1N:3,RGZ1="E":4,1:-1)
+1 QUIT
NUM4 SET RGZ=$SELECT(RGZ1="+":5,RGZ1="-":5,RGZ1=".":7,RGZ1?1N:6,1:-2)
+1 QUIT
NUM5 SET RGZ=$SELECT(RGZ1?1N:6,RGZ1=".":7,1:-2)
+1 QUIT
NUM6 SET RGZ=$SELECT(RGZ1?1N:6,RGZ1=".":8,1:-1)
+1 QUIT
NUM7 SET RGZ=$SELECT(RGZ1?1N:8,1:-2)
+1 QUIT
NUM8 SET RGZ=$SELECT(RGZ1?1N:8,1:-1)
+1 QUIT
+2 ; Open parenthesis
OPNPAR SET RGPN=RGPN+1
+1 KILL RGPN(RGPN)
+2 QUIT
+3 ; Period (variable by reference or FP number)
DOT IF RGEX["."
IF $EXTRACT(RGM,RGPSN)'?1N
Begin DoDot:1
+1 IF '$$NEXT("@")
SET RGPSN=$$NAME^RGUTSTX0(RGPSN,"%")
SET RGF=-1
+2 IF '$TEST
DO INDIR
End DoDot:1
+3 IF '$TEST
DO NUM
+4 QUIT
+5 ; Variable name
VAR SET RGPSN=$$NAME^RGUTSTX0(RGPSN-1,"%")
SET RGF=1
+1 if $$NEXT("(")
DO PLIST()
+2 QUIT
+3 ; Closing parenthesis
CLSPAR IF 'RGPN
IF RGEX[")"
GOTO DONE
+1 IF RGPN
SET RGPN=RGPN-1
+2 IF '$TEST
SET RGERR=3
+3 QUIT
+4 ; Right bracket (] or ]])
RBRKT IF 'RGPN
IF RGEX["]"
GOTO DONE
+1 IF $$NEXT(RGC)
+2 ; Binary operator
BINARY SET RGF=0
+1 QUIT
+2 ; Colon operand
COLON2 if RGEX'["M"
SET RGERR=6
+1 QUIT
+2 ; Colon operator
COLON if RGEX'["
GOTO DONE
+1 SET RGF=0
+2 if RGEX'["M"
SET RGEX=$TRANSLATE(RGEX,":")
+3 QUIT
+4 ; Pattern match
PTRN NEW RGZ,RGZ1
+1 IF $$NEXT("@")
SET RGF=0
QUIT
+2 SET RGZ=RGPSN
SET @$$TRAP^RGZOSF("PERR^RGUTSTX1")
SET RGZ1=0
+3 FOR
Begin DoDot:1
+4 if $$NEXT(RGQT)
DO QT2
if $$NEXT("(")
DO PTRN1
if $$NEXT(")")
DO PTRN2
+5 IF RGZ1
IF $$NEXT(",")
+6 if '$$NEXT("ACELNPU.0123456789")
SET RGZ1=-1
End DoDot:1
if RGZ1<0!RGERR
QUIT
+7 if 'RGERR
SET RGZ=RGZ?@$EXTRACT(RGM,RGZ,RGPSN-1)
+8 QUIT
PTRN1 SET RGZ1=RGZ1+1
+1 QUIT
PTRN2 SET RGZ1=RGZ1-1
+1 if RGZ1<0
SET RGPSN=RGPSN-1
+2 QUIT
PERR SET RGERR=10
+1 QUIT
+2 ; Process a parameter list
PLIST(RGP,RGT) ;
+1 NEW RGC,RGP1,RGP2,RGZ
+2 SET RGT=$GET(RGT,")")
SET RGP=$GET(RGP,";0-999")
SET RGP2=$PIECE(RGP,";",2)
SET RGP1=+RGP2
SET RGP2=+$PIECE(RGP2,"-",2)
SET RGC=0
SET RGZ=$PIECE(RGP,";")
+3 IF '$$NEXT(RGT,0)
Begin DoDot:1
+4 FOR RGC=1:1
Begin DoDot:2
+5 DO @("PL"_$PIECE(RGP,";",RGC+2))
End DoDot:2
if RGERR!'$$NEXT(",")
QUIT
End DoDot:1
+6 IF 'RGERR
IF RGC<RGP1!(RGC>RGP2)
SET RGERR=8
+7 IF 'RGERR
IF '$$NEXT(RGT)
SET RGERR=3
+8 QUIT
PL NEW RGEX
+1 IF RGZ="."
IF $$NEXT(",",0)
QUIT
+2 SET RGEX=RGT_RGZ
+3 DO EXP(.RGEX)
+4 IF RGZ[":"
IF RGEX[":"
SET RGERR=2
+5 QUIT
PLV DO LVAL^RGUTSTX0("LG")
+1 QUIT
PLL DO LBL1^RGUTSTX0()
+1 QUIT
+2 ; Get next character
NEXT(RGC,RGI) ;
+1 QUIT $$NEXT^RGUTSTX0(RGC,.RGI)
