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 Nov 22, 2024@17:50:05 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)
