CIAUSTX1.m

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)