CIAUSTX1 ;MSC/IND/DKM - Continuation of CIAUSTX;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Parse an expression
EXP(CIAEX) ;
N CIAF,CIAC,CIAPN
S (CIAF,CIAPN)=0,CIAEX=$G(CIAEX)
F D Q:CIAF<0!CIAERR
.S CIAC=$E(CIAM,CIAPSN),CIAPSN=CIAPSN+1
.D @("OP"_CIAF)
I 'CIAERR,CIAPN S CIAERR=3
S CIAEX=$S($G(CIAPN(CIAPN,"@")):"@",1:"")_CIAEX
Q
; Operands
OP0 I CIAC'=".",CIAEX["." S CIAEX=$TR(CIAEX,".")
G:CIAC'="" COLON2:CIAC=":",GLBL:CIAC=U,DOT:CIAC=".",INDIR:CIAC="@",FCN:CIAC="$",UNARY:"'+-"[CIAC,QT:CIAC=CIAQT,NUM:CIAC?1N,OPNPAR:CIAC="(",VAR:CIAC?1A,VAR:CIAC="%"
S CIAERR=6
Q
; Operators
OP1 G END:CIAC="",INDIR2:CIAC="@",DONE:CIAEX["="&'CIAPN!(CIAC=" ")
K CIAPN(CIAPN,"@")
I CIAC="*",$$NEXT(CIAC)
G COLON:CIAC=":",CLSPAR:CIAC=")",RBRKT:CIAC="]",BINARY:"!#&*-_+=\/<>["[CIAC,NOT:CIAC="'",PTRN:CIAC="?"
DONE S CIAPSN=CIAPSN-1
END S CIAF=-1
Q
; Negated operator
NOT S:'$$NEXT("=<>[]?&!",0) CIAERR=2
Q
; Parse a global reference
GLBL D:$$NEXT("[") PLIST(";1-2","]")
Q:CIAERR
S:'$$NEXT("(",0) CIAPSN=$$NAME^CIAUSTX0(CIAPSN,"$%")
I 'CIAERR,$$NEXT("(") D PLIST(";1-999")
S CIAF=1
Q
; Indirection (prefix)
INDIR S CIAPN(CIAPN,"@")=$G(CIAPN(CIAPN,"@"))+1
Q
; Indirection (suffix)
INDIR2 I +$G(CIAPN(CIAPN,"@"))'>0 S CIAERR=2
E I '$$NEXT("(") S CIAERR=2
E D
.S CIAPN(CIAPN,"@")=-(CIAPN(CIAPN,"@")>1)
.D PLIST()
Q
; Intrinsic function/system variable
FCN G:$$NEXT("$") EXT
INT N CIAZ,CIAZ1
S CIAZ1=$E(CIAM,CIAPSN),CIAZ=$$INT^CIAUSTX0(.CIAPSN),CIAF=1
I 'CIAERR,$$NEXT("(") D PLIST(CIAZ)
Q
; Extrinsic function
EXT S:'$$NEXT(U,0) CIAPSN=$$LABEL^CIAUSTX0
Q:CIAERR
S:$$NEXT(U) CIAPSN=$$LABEL^CIAUSTX0
Q:CIAERR
D:$$NEXT("(") PLIST(".;0-999")
S CIAF=1
Q
; Unary operator
UNARY Q
; String literal
QT D QT2
S CIAF=1
Q
; Find matching quote
QT2 F CIAPSN=CIAPSN:1:CIALEN I $$NEXT(CIAQT),'$$NEXT(CIAQT,0) Q
S:$E(CIAM,CIAPSN-1)'=CIAQT CIAERR=9
Q
; Numeric constant
NUM N CIAZ,CIAZ1
S CIAZ=0,CIAF=1
F CIAPSN=CIAPSN-1:1 S CIAZ1=$E(CIAM,CIAPSN) D @("NUM"_CIAZ) Q:CIAZ<0
S:CIAZ=-2 CIAERR=2
Q
NUM0 S CIAZ=$S(CIAZ1?1N:1,CIAZ1=".":2,1:-2)
Q
NUM1 S CIAZ=$S(CIAZ1?1N:1,CIAZ1=".":3,1:-1)
Q
NUM2 S CIAZ=$S(CIAZ1?1N:3,1:-2)
Q
NUM3 S CIAZ=$S(CIAZ1?1N:3,CIAZ1="E":4,1:-1)
Q
NUM4 S CIAZ=$S(CIAZ1="+":5,CIAZ1="-":5,CIAZ1=".":7,CIAZ1?1N:6,1:-2)
Q
NUM5 S CIAZ=$S(CIAZ1?1N:6,CIAZ1=".":7,1:-2)
Q
NUM6 S CIAZ=$S(CIAZ1?1N:6,CIAZ1=".":8,1:-1)
Q
NUM7 S CIAZ=$S(CIAZ1?1N:8,1:-2)
Q
NUM8 S CIAZ=$S(CIAZ1?1N:8,1:-1)
Q
; Open parenthesis
OPNPAR S CIAPN=CIAPN+1
K CIAPN(CIAPN)
Q
; Period (variable by reference or FP number)
DOT I CIAEX[".",$E(CIAM,CIAPSN)'?1N D
.I '$$NEXT("@") S CIAPSN=$$NAME^CIAUSTX0(CIAPSN,"%"),CIAF=-1
.E D INDIR
E D NUM
Q
; Variable name
VAR S CIAPSN=$$NAME^CIAUSTX0(CIAPSN-1,"%"),CIAF=1
D:$$NEXT("(") PLIST()
Q
; Closing parenthesis
CLSPAR I 'CIAPN,CIAEX[")" G DONE
I CIAPN S CIAPN=CIAPN-1
E S CIAERR=3
Q
; Right bracket (] or ]])
RBRKT I 'CIAPN,CIAEX["]" G DONE
I $$NEXT(CIAC)
; Binary operator
BINARY S CIAF=0
Q
; Colon operand
COLON2 S:CIAEX'["M" CIAERR=6
Q
; Colon operator
COLON G:CIAEX'[":" DONE
S CIAF=0
S:CIAEX'["M" CIAEX=$TR(CIAEX,":")
Q
; Pattern match
PTRN N CIAZ,CIAZ1
I $$NEXT("@") S CIAF=0 Q
S CIAZ=CIAPSN,@$$TRAP^CIAUOS("PERR^CIAUSTX1"),CIAZ1=0
F D Q:CIAZ1<0!CIAERR
.D QT2:$$NEXT(CIAQT),PTRN1:$$NEXT("("),PTRN2:$$NEXT(")")
.I CIAZ1,$$NEXT(",")
.S:'$$NEXT("ACELNPU.0123456789") CIAZ1=-1
S:'CIAERR CIAZ=CIAZ?@$E(CIAM,CIAZ,CIAPSN-1)
Q
PTRN1 S CIAZ1=CIAZ1+1
Q
PTRN2 S CIAZ1=CIAZ1-1
S:CIAZ1<0 CIAPSN=CIAPSN-1
Q
PERR S CIAERR=10
Q
; Process a parameter list
PLIST(CIAP,CIAT) ;
N CIAC,CIAP1,CIAP2,CIAZ
S CIAT=$G(CIAT,")"),CIAP=$G(CIAP,";0-999"),CIAP2=$P(CIAP,";",2),CIAP1=+CIAP2,CIAP2=+$P(CIAP2,"-",2),CIAC=0,CIAZ=$P(CIAP,";")
I '$$NEXT(CIAT,0) D
.F CIAC=1:1 D Q:CIAERR!'$$NEXT(",")
..D @("PL"_$P(CIAP,";",CIAC+2))
I 'CIAERR,CIAC<CIAP1!(CIAC>CIAP2) S CIAERR=8
I 'CIAERR,'$$NEXT(CIAT) S CIAERR=3
Q
PL N CIAEX
I CIAZ=".",$$NEXT(",",0) Q
S CIAEX=CIAT_CIAZ
D EXP(.CIAEX)
I CIAZ[":",CIAEX[":" S CIAERR=2
Q
PLV D LVAL^CIAUSTX0("LG")
Q
PLL D LBL1^CIAUSTX0()
Q
; Get next character
NEXT(CIAC,CIAI) ;
Q $$NEXT^CIAUSTX0(CIAC,.CIAI)
CIAUSTX1 ;MSC/IND/DKM - Continuation of CIAUSTX;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Parse an expression
EXP(CIAEX) ;
+1 NEW CIAF,CIAC,CIAPN
+2 SET (CIAF,CIAPN)=0
SET CIAEX=$GET(CIAEX)
+3 FOR
Begin DoDot:1
+4 SET CIAC=$EXTRACT(CIAM,CIAPSN)
SET CIAPSN=CIAPSN+1
+5 DO @("OP"_CIAF)
End DoDot:1
IF CIAF<0!CIAERR
QUIT
+6 IF 'CIAERR
IF CIAPN
SET CIAERR=3
+7 SET CIAEX=$SELECT($GET(CIAPN(CIAPN,"@")):"@",1:"")_CIAEX
+8 QUIT
+9 ; Operands
OP0 IF CIAC'="."
IF CIAEX["."
SET CIAEX=$TRANSLATE(CIAEX,".")
+1 IF CIAC'=""
IF CIAC=":"
GOTO COLON2
IF CIAC=U
GOTO GLBL
IF CIAC="."
GOTO DOT
IF CIAC="@"
GOTO INDIR
IF CIAC="$"
GOTO FCN
IF "'+-"[CIAC
GOTO UNARY
IF CIAC=CIAQT
GOTO QT
IF CIAC?1N
GOTO NUM
IF CIAC="("
GOTO OPNPAR
IF CIAC?1A
GOTO VAR
IF CIAC="%"
GOTO VAR
+2 SET CIAERR=6
+3 QUIT
+4 ; Operators
OP1 IF CIAC=""
GOTO END
IF CIAC="@"
GOTO INDIR2
IF CIAEX["="&'CIAPN!(CIAC=" ")
GOTO DONE
+1 KILL CIAPN(CIAPN,"@")
+2 IF CIAC="*"
IF $$NEXT(CIAC)
+3 IF CIAC=":"
GOTO COLON
IF CIAC=")"
GOTO CLSPAR
IF CIAC="]"
GOTO RBRKT
IF "!#&*-_+=\/<>["[CIAC
GOTO BINARY
IF CIAC="'"
GOTO NOT
IF CIAC="?"
GOTO PTRN
DONE SET CIAPSN=CIAPSN-1
END SET CIAF=-1
+1 QUIT
+2 ; Negated operator
NOT IF '$$NEXT("=<>[]?&!",0)
SET CIAERR=2
+1 QUIT
+2 ; Parse a global reference
GLBL IF $$NEXT("[")
DO PLIST(";1-2","]")
+1 IF CIAERR
QUIT
+2 IF '$$NEXT("(",0)
SET CIAPSN=$$NAME^CIAUSTX0(CIAPSN,"$%")
+3 IF 'CIAERR
IF $$NEXT("(")
DO PLIST(";1-999")
+4 SET CIAF=1
+5 QUIT
+6 ; Indirection (prefix)
INDIR SET CIAPN(CIAPN,"@")=$GET(CIAPN(CIAPN,"@"))+1
+1 QUIT
+2 ; Indirection (suffix)
INDIR2 IF +$GET(CIAPN(CIAPN,"@"))'>0
SET CIAERR=2
+1 IF '$TEST
IF '$$NEXT("(")
SET CIAERR=2
+2 IF '$TEST
Begin DoDot:1
+3 SET CIAPN(CIAPN,"@")=-(CIAPN(CIAPN,"@")>1)
+4 DO PLIST()
End DoDot:1
+5 QUIT
+6 ; Intrinsic function/system variable
FCN IF $$NEXT("$")
GOTO EXT
INT NEW CIAZ,CIAZ1
+1 SET CIAZ1=$EXTRACT(CIAM,CIAPSN)
SET CIAZ=$$INT^CIAUSTX0(.CIAPSN)
SET CIAF=1
+2 IF 'CIAERR
IF $$NEXT("(")
DO PLIST(CIAZ)
+3 QUIT
+4 ; Extrinsic function
EXT IF '$$NEXT(U,0)
SET CIAPSN=$$LABEL^CIAUSTX0
+1 IF CIAERR
QUIT
+2 IF $$NEXT(U)
SET CIAPSN=$$LABEL^CIAUSTX0
+3 IF CIAERR
QUIT
+4 IF $$NEXT("(")
DO PLIST(".;0-999")
+5 SET CIAF=1
+6 QUIT
+7 ; Unary operator
UNARY QUIT
+1 ; String literal
QT DO QT2
+1 SET CIAF=1
+2 QUIT
+3 ; Find matching quote
QT2 FOR CIAPSN=CIAPSN:1:CIALEN
IF $$NEXT(CIAQT)
IF '$$NEXT(CIAQT,0)
QUIT
+1 IF $EXTRACT(CIAM,CIAPSN-1)'=CIAQT
SET CIAERR=9
+2 QUIT
+3 ; Numeric constant
NUM NEW CIAZ,CIAZ1
+1 SET CIAZ=0
SET CIAF=1
+2 FOR CIAPSN=CIAPSN-1:1
SET CIAZ1=$EXTRACT(CIAM,CIAPSN)
DO @("NUM"_CIAZ)
IF CIAZ<0
QUIT
+3 IF CIAZ=-2
SET CIAERR=2
+4 QUIT
NUM0 SET CIAZ=$SELECT(CIAZ1?1N:1,CIAZ1=".":2,1:-2)
+1 QUIT
NUM1 SET CIAZ=$SELECT(CIAZ1?1N:1,CIAZ1=".":3,1:-1)
+1 QUIT
NUM2 SET CIAZ=$SELECT(CIAZ1?1N:3,1:-2)
+1 QUIT
NUM3 SET CIAZ=$SELECT(CIAZ1?1N:3,CIAZ1="E":4,1:-1)
+1 QUIT
NUM4 SET CIAZ=$SELECT(CIAZ1="+":5,CIAZ1="-":5,CIAZ1=".":7,CIAZ1?1N:6,1:-2)
+1 QUIT
NUM5 SET CIAZ=$SELECT(CIAZ1?1N:6,CIAZ1=".":7,1:-2)
+1 QUIT
NUM6 SET CIAZ=$SELECT(CIAZ1?1N:6,CIAZ1=".":8,1:-1)
+1 QUIT
NUM7 SET CIAZ=$SELECT(CIAZ1?1N:8,1:-2)
+1 QUIT
NUM8 SET CIAZ=$SELECT(CIAZ1?1N:8,1:-1)
+1 QUIT
+2 ; Open parenthesis
OPNPAR SET CIAPN=CIAPN+1
+1 KILL CIAPN(CIAPN)
+2 QUIT
+3 ; Period (variable by reference or FP number)
DOT IF CIAEX["."
IF $EXTRACT(CIAM,CIAPSN)'?1N
Begin DoDot:1
+1 IF '$$NEXT("@")
SET CIAPSN=$$NAME^CIAUSTX0(CIAPSN,"%")
SET CIAF=-1
+2 IF '$TEST
DO INDIR
End DoDot:1
+3 IF '$TEST
DO NUM
+4 QUIT
+5 ; Variable name
VAR SET CIAPSN=$$NAME^CIAUSTX0(CIAPSN-1,"%")
SET CIAF=1
+1 IF $$NEXT("(")
DO PLIST()
+2 QUIT
+3 ; Closing parenthesis
CLSPAR IF 'CIAPN
IF CIAEX[")"
GOTO DONE
+1 IF CIAPN
SET CIAPN=CIAPN-1
+2 IF '$TEST
SET CIAERR=3
+3 QUIT
+4 ; Right bracket (] or ]])
RBRKT IF 'CIAPN
IF CIAEX["]"
GOTO DONE
+1 IF $$NEXT(CIAC)
+2 ; Binary operator
BINARY SET CIAF=0
+1 QUIT
+2 ; Colon operand
COLON2 IF CIAEX'["M"
SET CIAERR=6
+1 QUIT
+2 ; Colon operator
COLON IF CIAEX'["
GOTO DONE
+1 SET CIAF=0
+2 IF CIAEX'["M"
SET CIAEX=$TRANSLATE(CIAEX,":")
+3 QUIT
+4 ; Pattern match
PTRN NEW CIAZ,CIAZ1
+1 IF $$NEXT("@")
SET CIAF=0
QUIT
+2 SET CIAZ=CIAPSN
SET @$$TRAP^CIAUOS("PERR^CIAUSTX1")
SET CIAZ1=0
+3 FOR
Begin DoDot:1
+4 IF $$NEXT(CIAQT)
DO QT2
IF $$NEXT("(")
DO PTRN1
IF $$NEXT(")")
DO PTRN2
+5 IF CIAZ1
IF $$NEXT(",")
+6 IF '$$NEXT("ACELNPU.0123456789")
SET CIAZ1=-1
End DoDot:1
IF CIAZ1<0!CIAERR
QUIT
+7 IF 'CIAERR
SET CIAZ=CIAZ?@$EXTRACT(CIAM,CIAZ,CIAPSN-1)
+8 QUIT
PTRN1 SET CIAZ1=CIAZ1+1
+1 QUIT
PTRN2 SET CIAZ1=CIAZ1-1
+1 IF CIAZ1<0
SET CIAPSN=CIAPSN-1
+2 QUIT
PERR SET CIAERR=10
+1 QUIT
+2 ; Process a parameter list
PLIST(CIAP,CIAT) ;
+1 NEW CIAC,CIAP1,CIAP2,CIAZ
+2 SET CIAT=$GET(CIAT,")")
SET CIAP=$GET(CIAP,";0-999")
SET CIAP2=$PIECE(CIAP,";",2)
SET CIAP1=+CIAP2
SET CIAP2=+$PIECE(CIAP2,"-",2)
SET CIAC=0
SET CIAZ=$PIECE(CIAP,";")
+3 IF '$$NEXT(CIAT,0)
Begin DoDot:1
+4 FOR CIAC=1:1
Begin DoDot:2
+5 DO @("PL"_$PIECE(CIAP,";",CIAC+2))
End DoDot:2
IF CIAERR!'$$NEXT(",")
QUIT
End DoDot:1
+6 IF 'CIAERR
IF CIAC<CIAP1!(CIAC>CIAP2)
SET CIAERR=8
+7 IF 'CIAERR
IF '$$NEXT(CIAT)
SET CIAERR=3
+8 QUIT
PL NEW CIAEX
+1 IF CIAZ="."
IF $$NEXT(",",0)
QUIT
+2 SET CIAEX=CIAT_CIAZ
+3 DO EXP(.CIAEX)
+4 IF CIAZ[":"
IF CIAEX[":"
SET CIAERR=2
+5 QUIT
PLV DO LVAL^CIAUSTX0("LG")
+1 QUIT
PLL DO LBL1^CIAUSTX0()
+1 QUIT
+2 ; Get next character
NEXT(CIAC,CIAI) ;
+1 QUIT $$NEXT^CIAUSTX0(CIAC,.CIAI)
