Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XINDX9

XINDX9.m

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