- XINDX9 ;SF/RWF - XINDEX SYNTAX CHECKER ;06/24/08 15:39
- ;;7.3;TOOLKIT;**20,27,48,61,66,68,110,121,132,133,140**;Apr 25, 1995;Build 40
- ; Per VHA Directive 2004-038, this routine should not be modified.
- N CH1,CHO,EC,OP
- D PARSE S LI=0,AC=255 F %=0:0 S %=$O(LV(%)) Q:%'>0 S LI(%)=0
- Q
- ;LV is a set of Linked Values
- PARSE K LV,LI S (ERR,LI,I)=0,(LL,LV)=1,(OP,CH)="",Q=""""
- ;CH=current, CH1=next, CHO=previous character
- PA2 S I=I+1,CHO=CH,CH=$E(STR,I),CH1=$E(STR,I+1) G:CH="" PEND
- G E:CH=";"!(CH'?1ANP) I """$()"[CH D QUOTE:CH=Q,FUNC:CH="$",DN:CH="(",UP:CH=")" G PA2
- I CH="^",CH1="$" D SSVN G PA2
- I CH="^",I=LL G PA2:CH1'="[" S I=I+1,X=$E(STR,LL,I) D ADD S LL=I+1 G PA2
- I CH?1A!(CH="%")!(CH=".") D VAR1 G PA2
- I CH?1N D NUM G PA2
- I CH="#",CH1="#" D OBJ G PA2
- S:"+-#'/*_&![]<>?"[CH OP=CH
- I CH="?",",!#"'[$E(STR,I-1) D AR,PAT G PA2
- I CH=",",CH1=":" D E^XINDX1(21) ;P121
- ;check if an open $S exists
- I $G(LV(LV,"SEL")) D
- . I '$P(LV(LV,"SEL"),U,2) S:CH="," $P(LV(LV,"SEL"),U,2)=1 Q ;arg is closed: open if comma
- . I CH=":" S $P(LV(LV,"SEL"),U,2)=0 Q ;arg open: close if colon
- . I CH="," D E^XINDX1(43) S LV(LV,"SEL")="0^0" ;arg open: error if comma, close this $S
- . Q
- I CH?1P D ;Check for dup operators
- . D AR
- . Q:(CH_CH1="]]")
- . I CH=CH1,(",_/\[]&|"[CH) D
- .. Q:CH=","&$$OBJF() ;quit if Object with open '(', good code
- .. I $$FNC()'="$$" D E^XINDX1(21) Q ; if not function, can't have empty parameters
- G PA2
- ;End of parse
- PEND D AR,E^XINDX1(5):LV>1,E^XINDX1(21):($G(LV(1,1))=",") ;LV>1 means mis-match ()
- Q
- ;
- DN D STR S X=CH D ADD,NEW S LI(LV)=LI,LV=LV+1 S:'$D(LI(LV)) LI(LV)=0 S LI=LI(LV),LI(LV-1,1)=LI
- Q
- UP I LV<2 D E^XINDX1(5) Q
- D STR S EC=LI-LI(LV-1,1),X=$C(10) D ADD,NEW
- ;$S function still open, check arg
- I $G(LV(LV,"SEL")) D:$P(LV(LV,"SEL"),U,2) E^XINDX1(43) K LV(LV,"SEL")
- S LI(LV)=LI,LV=LV-1,LI=LI(LV)
- S X=EC D ADD S X=CH D ADD
- I CH1]"",",._=+-*/\#'):<>[]?&!@^"'[CH1 D E^XINDX1(43)
- Q
- NEW S LL=I+1
- Q
- AR D STR S X=CH D ADD,NEW Q
- STR S X=$E(STR,LL,I-1) Q:'$L(X) ;Drop into ADD
- ADD S LI=LI+1,LV(LV,LI)=X Q
- ;
- FNC(NEW) ;Sets or returns the current function
- I $D(NEW) S LV(LV+1,"FNC",$G(LI(LV))+1)=NEW Q
- N W S W=+$S($D(LV(LV,"FNC",LI)):LI,$O(LV(LV,"FNC",LI)):$O(LV(LV,"FNC",LI)),1:$O(LV(LV,"FNC",LI),-1)) ;patch 119
- Q $G(LV(LV,"FNC",W))
- ;
- OP(NEW) ;Sets or returns the current operator
- I $D(NEW) S LV(LV,"OP",LI)=NEW Q
- N W S W=+$S($D(LV(LV,"OP",LI)):LI,1:$O(LV(LV,"OP",LI),-1))
- Q $G(LV(LV,"OP",W))
- ;
- QUOTE F I=I+1:1 S CH=$E(STR,I) Q:CH=""!(CH=Q)
- I $E(STR,I+1)=Q S I=I+1 G QUOTE
- I OP'="?",$E(STR,I+1)]"","[]()<>\/+-=&!_#*,:'|"'[$E(STR,I+1) D E^XINDX1(46) Q
- Q:CH]"" D E^XINDX1(6)
- Q
- ;
- GVAR() ;EF get var
- N % D VAR S %=$E(STR,LL,I),LL=I+1
- Q %
- ;
- OBJ ;check Cache Object
- S J=$E(STR,I,I+7),J=$$CASE(J) I J'="##CLASS(" D E^XINDX1(3) Q
- D E^XINDX1(65) ;vendor specific code
- S LL=I,I=I+7,CH=$E(STR,I) D SUM("F"),DN
- ;get the class
- S LL=I+1,I=$$CLS(LL),CH=$E(STR,I),CH1=$E(STR,I+1),LV(LV,"OBJ",LI+1)=""
- D SUM("O"),UP
- ;get the method, must start with "."
- Q:CH1'="."
- S LL=I+1,J=$$CLS(LL),I=J-1,LV(LV,"OBJ",LI+1)=""
- D SUM("O")
- Q
- ;
- CLS(I) ;return the position of the class
- N %
- F %=I:1 S CH=$E(STR,%) Q:"()"[CH
- Q %
- ;
- OBJF() ; return line where object has an open "(" for parameters
- N %
- Q:LV<2 0 ;must be down at least 1 level
- S %=$O(LV(LV-1,"OBJ",""),-1) ;find last object at previous level
- Q $S('%:0,LV(LV-1,%+1)="(":%,1:0) ; returns 0 if can't find object or object has no parameter
- ;
- VAR1 ;check if var is Object
- N % S %=0
- ;check of var is passed by ref.
- I CH=".",",("[CHO D AR Q
- F J=I+1:1 S CH=$E(STR,J) I CH'?1AN Q:CH'="." S %=1
- G:'% VAR
- ;save summary and ref. of Object/method
- D E^XINDX1(65) ;vendor specific code
- S LL=I,I=J-1,LV(LV,"OBJ",LI+1)=""
- D SUM("O")
- Q
- VAR ;find length of var. and reset I
- F J=I+1:1 S CH=$E(STR,J) Q:CH'?1AN
- S I=J-1 D SUM("V")
- Q
- NUM F J=I+1:1 S CH=$E(STR,J) Q:"0123456789."'[CH!(CH="")
- I CH="E" S CH=$E(STR,J+1) I CH?1N!("+-"[CH) S I=J G NUM
- I CH]"",CH'?1P S ERR=53 D ^XINDX1
- S I=J-1 D SUM("N")
- Q
- INC S I=I+1,CH=$E(STR,I)
- Q
- FUNC ;Functions and special var's.
- ;check if $SYSTEM
- I $$CASE($E(STR,I,I+6))="$SYSTEM" G SYS
- D INC S X=CH,S=$$GVAR()
- G EXT:S["$$",PKG:S["$&",SPV:CH'="("
- I "ZV"[X S ERR=$S("Z"[X:31,1:27) D ^XINDX1
- S S=$$CASE($E(S,2,11)),F1=$G(IND("FNC",S)) I '$L(F1) D E^XINDX1(3) S F1=S G FX
- ;$S only function that must contain a colon in each argument
- I F1["SELECT" S LV(LV+1,"SEL")="1^1"
- FX S X="$"_F1,CH="" D FNC("$F"),ADD,SUM("F")
- Q
- SPV S X=S D FNC("$V"),ADD,SUM("V") S X=$E(S,2,10),CH="" ;P132 support of $PRINCIPAL, 10 characters
- I $E(S,2)="Z" D E^XINDX1(28) Q
- I '$D(IND("SVN",X)) D E^XINDX1(4)
- Q
- EXT ;EXTRINSIC
- S X=S,CH="" D FNC("$$"),ADD,SUM("V")
- Q
- SYS ;$SYSTEM class or SVN
- S LL=I,I=I+6 D INC
- I CH'="." D SUM("V") Q ;SVN
- S I=LL,CH="" D VAR1
- ;Error 54 access for Kernel only
- S CH="" D E^XINDX1(54)
- Q
- SSVN ;
- D INC S X=$$GVAR() I '$D(IND("SSVN",$E(X,3,99))) D E^XINDX1(4) Q
- ;Error 54 access for Kernel only
- D E^XINDX1(54),ADD,SUM("V")
- Q
- PKG ;External Function
- S J=$F(STR,"(",I),I=J-2,X=S_$E(STR,LL,I),LL=J-1,CH=""
- D ADD,E^XINDX1(55) ;Not standard VA
- Q
- E D E^XINDX1(11)
- Q
- PAT N PC S PC=0
- F I=I+1:1 S CH=$E(STR,I) D PATQ:CH=Q,PATD:CH="(",PATU:CH=")",PATC:CH="," I CH=""!(CH'?1N&("ACELNPUacelnpu."'[CH)) Q
- I PC D E^XINDX1(5)
- S I=I-1 I ":),@+-_*/\!&'"'[CH D E^XINDX1(16),SEP Q
- Q
- ;Quote in Pattern
- PATQ F I=I+1:1 S CH=$E(STR,I) Q:CH=""!(CH=Q)
- D:CH="" E^XINDX1(6) S I=I+1,CH=$E(STR,I) G:CH=Q PATQ
- Q
- PATD S PC=PC+1,CH="." ;p110 Start Alt.
- Q
- PATU I 'PC,LV>1 S CH="" Q ;End
- S PC=PC-1,CH="." ;p110 End Alt.
- Q
- PATC I PC<1 Q ;
- S CH="." ;p110 Comma in Alt.
- Q
- PAREN F I=I+1:1 S CH=$E(STR,I) Q:CH=""!(CH=")")
- D:CH="" E^XINDX1(5) S CH="."
- Q
- SEP ;Find sep
- Q
- ;
- SUM(P) ;Build summary line
- S LV(LV,"S")=$G(LV(LV,"S"))_P
- Q
- CASE(%) ;UpperCase
- Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- ;
- TEST S STR=$E($T(TEST+2),4,999) D XINDX9
- Q
- ;;NUMVAL?.1(1"+",1"-")1(1.N.1".".N,.N.1"."1.N).1(1"E".1(1"+",1"-")1.N)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXINDX9 6342 printed Jan 18, 2025@03:41:17 Page 2
- XINDX9 ;SF/RWF - XINDEX SYNTAX CHECKER ;2018-03-01 10:00 AM
- +1 ;;7.3;TOOLKIT;**20,27,48,61,66,68,110,121,132,133,10001**;Apr 25, 1995;Build 4
- +2 ; Original routine authored by Department of Veterans Affairs
- +3 ; Modifications in *10001* made by Sam Habiel: GVAR+2,OBJ+2,VAR1+7 in 2018
- +4 NEW CH1,CHO,EC,OP
- +5 DO PARSE
- SET LI=0
- SET AC=255
- FOR %=0:0
- SET %=$ORDER(LV(%))
- if %'>0
- QUIT
- SET LI(%)=0
- +6 QUIT
- +7 ;LV is a set of Linked Values
- PARSE KILL LV,LI
- SET (ERR,LI,I)=0
- SET (LL,LV)=1
- SET (OP,CH)=""
- SET Q=""""
- +1 ;CH=current, CH1=next, CHO=previous character
- PA2 SET I=I+1
- SET CHO=CH
- SET CH=$EXTRACT(STR,I)
- SET CH1=$EXTRACT(STR,I+1)
- if CH=""
- GOTO PEND
- +1 if CH=";"!(CH'?1ANP)
- GOTO E
- IF """$()"[CH
- if CH=Q
- DO QUOTE
- if CH="$"
- DO FUNC
- if CH="("
- DO DN
- if CH=")"
- DO UP
- GOTO PA2
- +2 IF CH="^"
- IF CH1="$"
- DO SSVN
- GOTO PA2
- +3 IF CH="^"
- IF I=LL
- if CH1'="["
- GOTO PA2
- SET I=I+1
- SET X=$EXTRACT(STR,LL,I)
- DO ADD
- SET LL=I+1
- GOTO PA2
- +4 IF CH?1A!(CH="%")!(CH=".")
- DO VAR1
- GOTO PA2
- +5 IF CH?1N
- DO NUM
- GOTO PA2
- +6 IF CH="#"
- IF CH1="#"
- DO OBJ
- GOTO PA2
- +7 if "+-#'/*_&![]<>?"[CH
- SET OP=CH
- +8 IF CH="?"
- IF ",!#"'[$EXTRACT(STR,I-1)
- DO AR
- DO PAT
- GOTO PA2
- +9 ;P121
- IF CH=","
- IF CH1=":"
- DO E^XINDX1(21)
- +10 ;check if an open $S exists
- +11 IF $GET(LV(LV,"SEL"))
- Begin DoDot:1
- +12 ;arg is closed: open if comma
- IF '$PIECE(LV(LV,"SEL"),U,2)
- if CH=","
- SET $PIECE(LV(LV,"SEL"),U,2)=1
- QUIT
- +13 ;arg open: close if colon
- IF CH=":"
- SET $PIECE(LV(LV,"SEL"),U,2)=0
- QUIT
- +14 ;arg open: error if comma, close this $S
- IF CH=","
- DO E^XINDX1(43)
- SET LV(LV,"SEL")="0^0"
- +15 QUIT
- End DoDot:1
- +16 ;Check for dup operators
- IF CH?1P
- Begin DoDot:1
- +17 DO AR
- +18 if (CH_CH1="]]")
- QUIT
- +19 IF CH=CH1
- IF (",_/\[]&|"[CH)
- Begin DoDot:2
- +20 ;quit if Object with open '(', good code
- if CH=","&$$OBJF()
- QUIT
- +21 ; if not function, can't have empty parameters
- IF $$FNC()'="$$"
- DO E^XINDX1(21)
- QUIT
- End DoDot:2
- End DoDot:1
- +22 GOTO PA2
- +23 ;End of parse
- PEND ;LV>1 means mis-match ()
- DO AR
- if LV>1
- DO E^XINDX1(5)
- if ($GET(LV(1,1))=",")
- DO E^XINDX1(21)
- +1 QUIT
- +2 ;
- DN DO STR
- SET X=CH
- DO ADD
- DO NEW
- SET LI(LV)=LI
- SET LV=LV+1
- if '$DATA(LI(LV))
- SET LI(LV)=0
- SET LI=LI(LV)
- SET LI(LV-1,1)=LI
- +1 QUIT
- UP IF LV<2
- DO E^XINDX1(5)
- QUIT
- +1 DO STR
- SET EC=LI-LI(LV-1,1)
- SET X=$CHAR(10)
- DO ADD
- DO NEW
- +2 ;$S function still open, check arg
- +3 IF $GET(LV(LV,"SEL"))
- if $PIECE(LV(LV,"SEL"),U,2)
- DO E^XINDX1(43)
- KILL LV(LV,"SEL")
- +4 SET LI(LV)=LI
- SET LV=LV-1
- SET LI=LI(LV)
- +5 SET X=EC
- DO ADD
- SET X=CH
- DO ADD
- +6 IF CH1]""
- IF ",._=+-*/\#'):<>[]?&!@^"'[CH1
- DO E^XINDX1(43)
- +7 QUIT
- NEW SET LL=I+1
- +1 QUIT
- AR DO STR
- SET X=CH
- DO ADD
- DO NEW
- QUIT
- STR ;Drop into ADD
- SET X=$EXTRACT(STR,LL,I-1)
- if '$LENGTH(X)
- QUIT
- ADD SET LI=LI+1
- SET LV(LV,LI)=X
- QUIT
- +1 ;
- FNC(NEW) ;Sets or returns the current function
- +1 IF $DATA(NEW)
- SET LV(LV+1,"FNC",$GET(LI(LV))+1)=NEW
- QUIT
- +2 ;patch 119
- NEW W
- SET W=+$SELECT($DATA(LV(LV,"FNC",LI)):LI,$ORDER(LV(LV,"FNC",LI)):$ORDER(LV(LV,"FNC",LI)),1:$ORDER(LV(LV,"FNC",LI),-1))
- +3 QUIT $GET(LV(LV,"FNC",W))
- +4 ;
- OP(NEW) ;Sets or returns the current operator
- +1 IF $DATA(NEW)
- SET LV(LV,"OP",LI)=NEW
- QUIT
- +2 NEW W
- SET W=+$SELECT($DATA(LV(LV,"OP",LI)):LI,1:$ORDER(LV(LV,"OP",LI),-1))
- +3 QUIT $GET(LV(LV,"OP",W))
- +4 ;
- QUOTE FOR I=I+1:1
- SET CH=$EXTRACT(STR,I)
- if CH=""!(CH=Q)
- QUIT
- +1 IF $EXTRACT(STR,I+1)=Q
- SET I=I+1
- GOTO QUOTE
- +2 IF OP'="?"
- IF $EXTRACT(STR,I+1)]""
- IF "[]()<>\/+-=&!_#*,:'|"'[$EXTRACT(STR,I+1)
- DO E^XINDX1(46)
- QUIT
- +3 if CH]""
- QUIT
- DO E^XINDX1(6)
- +4 QUIT
- +5 ;
- GVAR() ;EF get var
- +1 NEW %
- DO VAR
- SET %=$EXTRACT(STR,LL,I)
- SET LL=I+1
- +2 QUIT $$CASE(%)
- +3 ;
- OBJ ;check Cache Object
- +1 SET J=$EXTRACT(STR,I,I+7)
- SET J=$$CASE(J)
- IF J'="##CLASS("
- DO E^XINDX1(3)
- QUIT
- +2 ; ** OSE/SMH - Vendor specific code error (suppressed for Kernel)**
- DO E^XINDX1(65)
- +3 SET LL=I
- SET I=I+7
- SET CH=$EXTRACT(STR,I)
- DO SUM("F")
- DO DN
- +4 ;get the class
- +5 SET LL=I+1
- SET I=$$CLS(LL)
- SET CH=$EXTRACT(STR,I)
- SET CH1=$EXTRACT(STR,I+1)
- SET LV(LV,"OBJ",LI+1)=""
- +6 DO SUM("O")
- DO UP
- +7 ;get the method, must start with "."
- +8 if CH1'="."
- QUIT
- +9 SET LL=I+1
- SET J=$$CLS(LL)
- SET I=J-1
- SET LV(LV,"OBJ",LI+1)=""
- +10 DO SUM("O")
- +11 QUIT
- +12 ;
- CLS(I) ;return the position of the class
- +1 NEW %
- +2 FOR %=I:1
- SET CH=$EXTRACT(STR,%)
- if "()"[CH
- QUIT
- +3 QUIT %
- +4 ;
- OBJF() ; return line where object has an open "(" for parameters
- +1 NEW %
- +2 ;must be down at least 1 level
- if LV<2
- QUIT 0
- +3 ;find last object at previous level
- SET %=$ORDER(LV(LV-1,"OBJ",""),-1)
- +4 ; returns 0 if can't find object or object has no parameter
- QUIT $SELECT('%:0,LV(LV-1,%+1)="(":%,1:0)
- +5 ;
- VAR1 ;check if var is Object
- +1 NEW %
- SET %=0
- +2 ;check of var is passed by ref.
- +3 IF CH="."
- IF ",("[CHO
- DO AR
- QUIT
- +4 FOR J=I+1:1
- SET CH=$EXTRACT(STR,J)
- IF CH'?1AN
- if CH'="."
- QUIT
- SET %=1
- +5 if '%
- GOTO VAR
- +6 ;save summary and ref. of Object/method
- +7 ; ** OSE/SMH - Vendor specific code error (suppressed for Kernel)**
- DO E^XINDX1(65)
- +8 SET LL=I
- SET I=J-1
- SET LV(LV,"OBJ",LI+1)=""
- +9 DO SUM("O")
- +10 QUIT
- VAR ;find length of var. and reset I
- +1 FOR J=I+1:1
- SET CH=$EXTRACT(STR,J)
- if CH'?1AN
- QUIT
- +2 SET I=J-1
- DO SUM("V")
- +3 QUIT
- NUM FOR J=I+1:1
- SET CH=$EXTRACT(STR,J)
- if "0123456789."'[CH!(CH="")
- QUIT
- +1 IF CH="E"
- SET CH=$EXTRACT(STR,J+1)
- IF CH?1N!("+-"[CH)
- SET I=J
- GOTO NUM
- +2 IF CH]""
- IF CH'?1P
- SET ERR=53
- DO ^XINDX1
- +3 SET I=J-1
- DO SUM("N")
- +4 QUIT
- INC SET I=I+1
- SET CH=$EXTRACT(STR,I)
- +1 QUIT
- FUNC ;Functions and special var's.
- +1 ;check if $SYSTEM
- +2 IF $$CASE($EXTRACT(STR,I,I+6))="$SYSTEM"
- GOTO SYS
- +3 DO INC
- SET X=CH
- SET S=$$GVAR()
- +4 if S["$$"
- GOTO EXT
- if S["$&"
- GOTO PKG
- if CH'="("
- GOTO SPV
- +5 IF "ZV"[X
- SET ERR=$SELECT("Z"[X:31,1:27)
- DO ^XINDX1
- +6 SET S=$$CASE($EXTRACT(S,2,11))
- SET F1=$GET(IND("FNC",S))
- IF '$LENGTH(F1)
- DO E^XINDX1(3)
- SET F1=S
- GOTO FX
- +7 ;$S only function that must contain a colon in each argument
- +8 IF F1["SELECT"
- SET LV(LV+1,"SEL")="1^1"
- FX SET X="$"_F1
- SET CH=""
- DO FNC("$F")
- DO ADD
- DO SUM("F")
- +1 QUIT
- SPV ;P132 support of $PRINCIPAL, 10 characters
- SET X=S
- DO FNC("$V")
- DO ADD
- DO SUM("V")
- SET X=$EXTRACT(S,2,10)
- SET CH=""
- +1 IF $EXTRACT(S,2)="Z"
- DO E^XINDX1(28)
- QUIT
- +2 IF '$DATA(IND("SVN",X))
- DO E^XINDX1(4)
- +3 QUIT
- EXT ;EXTRINSIC
- +1 SET X=S
- SET CH=""
- DO FNC("$$")
- DO ADD
- DO SUM("V")
- +2 QUIT
- SYS ;$SYSTEM class or SVN
- +1 SET LL=I
- SET I=I+6
- DO INC
- +2 ;SVN
- IF CH'="."
- DO SUM("V")
- QUIT
- +3 SET I=LL
- SET CH=""
- DO VAR1
- +4 ;Error 54 access for Kernel only
- +5 SET CH=""
- DO E^XINDX1(54)
- +6 QUIT
- SSVN ;
- +1 DO INC
- SET X=$$GVAR()
- IF '$DATA(IND("SSVN",$EXTRACT(X,3,99)))
- DO E^XINDX1(4)
- QUIT
- +2 ;Error 54 access for Kernel only
- +3 DO E^XINDX1(54)
- DO ADD
- DO SUM("V")
- +4 QUIT
- PKG ;External Function
- +1 SET J=$FIND(STR,"(",I)
- SET I=J-2
- SET X=S_$EXTRACT(STR,LL,I)
- SET LL=J-1
- SET CH=""
- +2 ;Not standard VA
- DO ADD
- DO E^XINDX1(55)
- +3 QUIT
- E DO E^XINDX1(11)
- +1 QUIT
- PAT NEW PC
- SET PC=0
- +1 FOR I=I+1:1
- SET CH=$EXTRACT(STR,I)
- if CH=Q
- DO PATQ
- if CH="("
- DO PATD
- if CH=")"
- DO PATU
- if CH=","
- DO PATC
- IF CH=""!(CH'?1N&("ACELNPUacelnpu."'[CH))
- QUIT
- +2 IF PC
- DO E^XINDX1(5)
- +3 SET I=I-1
- IF ":),@+-_*/\!&'"'[CH
- DO E^XINDX1(16)
- DO SEP
- QUIT
- +4 QUIT
- +5 ;Quote in Pattern
- PATQ FOR I=I+1:1
- SET CH=$EXTRACT(STR,I)
- if CH=""!(CH=Q)
- QUIT
- +1 if CH=""
- DO E^XINDX1(6)
- SET I=I+1
- SET CH=$EXTRACT(STR,I)
- if CH=Q
- GOTO PATQ
- +2 QUIT
- PATD ;p110 Start Alt.
- SET PC=PC+1
- SET CH="."
- +1 QUIT
- PATU ;End
- IF 'PC
- IF LV>1
- SET CH=""
- QUIT
- +1 ;p110 End Alt.
- SET PC=PC-1
- SET CH="."
- +2 QUIT
- PATC ;
- IF PC<1
- QUIT
- +1 ;p110 Comma in Alt.
- SET CH="."
- +2 QUIT
- PAREN FOR I=I+1:1
- SET CH=$EXTRACT(STR,I)
- if CH=""!(CH=")")
- QUIT
- +1 if CH=""
- DO E^XINDX1(5)
- SET CH="."
- +2 QUIT
- SEP ;Find sep
- +1 QUIT
- +2 ;
- SUM(P) ;Build summary line
- +1 SET LV(LV,"S")=$GET(LV(LV,"S"))_P
- +2 QUIT
- CASE(%) ;UpperCase
- +1 QUIT $TRANSLATE(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +2 ;
- TEST SET STR=$EXTRACT($TEXT(TEST+2),4,999)
- DO XINDX9
- +1 QUIT
- +2 ;;NUMVAL?.1(1"+",1"-")1(1.N.1".".N,.N.1"."1.N).1(1"E".1(1"+",1"-")1.N)