RGUTSTX1.m

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 ---RGUTSTX1   4108     printed  Apr 23, 2025@18:52:04                                                                                                                                                                                                    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)