source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XINDX9.m@ 703

Last change on this file since 703 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1XINDX9 ;SF/RWF - XINDEX SYNTAX CHECKER ;11/07/2002 14:57
2 ;;7.3;TOOLKIT;**20,27,48,61,66,68**;Apr 25, 1995
3 N CH1,EC,OP
4 D PARSE S LI=0,AC=255 F %=0:0 S %=$O(LV(%)) Q:%'>0 S LI(%)=0
5 Q
6 ;LV is a set of Linked Values
7PARSE K LV,LI S (ERR,LI,I)=0,(LL,LV)=1,(OP,CH)="",Q=""""
8 ;
9PA2 S I=I+1,CH=$E(STR,I),CH1=$E(STR,I+1) G:CH="" PEND
10 G E:CH=";"!(CH'?1ANP) I """$()"[CH D QUOTE:CH=Q,FUNC:CH="$",DN:CH="(",UP:CH=")" G PA2
11 I CH="^",CH1="$" D SSVN G PA2
12 I CH="^",I=LL G PA2:CH1'="[" S I=I+1,X=$E(STR,LL,I) D ADD S LL=I+1 G PA2
13 I CH?1A!(CH="%") D VAR G PA2
14 I CH?1N D NUM G PA2
15 S:"+-#'/*_&![]<>?"[CH OP=CH I CH="?",",!#"'[$E(STR,I-1) D AR,PAT G PA2
16 I CH?1P D ;Check for dup operators
17 . D AR
18 . Q:(CH_CH1="]]")
19 . I ((CH=CH1)&(",_/\[]"[CH))&($$FNC()'="$$") D E^XINDX1(21)
20 G PA2
21 ;
22DN 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
23 Q
24UP I LV<2 D E^XINDX1(5) Q
25 D STR S EC=LI-LI(LV-1,1),X=$C(10) D ADD,NEW S LI(LV)=LI,LV=LV-1,LI=LI(LV)
26 S X=EC D ADD S X=CH D ADD I CH1]"",",_=+-*/\#'):<>[]?&!@"'[CH1 D E^XINDX1(43)
27 Q
28NEW S LL=I+1
29 Q
30AR D STR S X=CH D ADD,NEW Q
31STR S X=$E(STR,LL,I-1) Q:'$L(X) ;Drop into ADD
32ADD S LI=LI+1,LV(LV,LI)=X Q
33 ;
34FNC(NEW) ;Sets or returns the current function
35 I $D(NEW) S LV(LV+1,"FNC",$G(LI(LV))+1)=NEW Q
36 N W S W=+$S($D(LV(LV,"FNC",LI)):LI,1:$O(LV(LV,"FNC",LI),-1))
37 Q $G(LV(LV,"FNC",W))
38 ;
39OP(NEW) ;Sets or returns the current operator
40 I $D(NEW) S LV(LV,"OP",LI)=NEW Q
41 N W S W=+$S($D(LV(LV,"OP",LI)):LI,1:$O(LV(LV,"OP",LI),-1))
42 Q $G(LV(LV,"OP",W))
43 ;
44QUOTE F I=I+1:1 S CH=$E(STR,I) Q:CH=""!(CH=Q)
45 I $E(STR,I+1)=Q S I=I+1 G QUOTE
46 I OP'="?",$E(STR,I+1)]"","[]()<>\/+-=&!_#*,:'|"'[$E(STR,I+1) D E^XINDX1(46) Q
47 Q:CH]"" D E^XINDX1(6) Q
48GVAR() ;EF get var
49 N % D VAR S %=$E(STR,LL,I),LL=I+1 Q %
50VAR F J=I+1:1 S CH=$E(STR,J) Q:CH'?1AN
51 S I=J-1 D SUM("V") Q
52NUM F J=I+1:1 S CH=$E(STR,J) Q:"0123456789."'[CH!(CH="")
53 I CH="E" S CH=$E(STR,J+1) I CH?1N!("+-"[CH) S I=J G NUM
54 I CH]"",CH'?1P S ERR=53 D ^XINDX1
55 S I=J-1 D SUM("N") Q
56INC S I=I+1,CH=$E(STR,I)
57 Q
58FUNC D INC S X=CH,S=$$GVAR() G EXT:S["$$",PKG:S["$&",SPV:CH'="("
59 S S=$E(S,2,11),F1=$G(IND("FNC",S)) I '$L(F1) D E^XINDX1(3) S F1=S G FX
60 I "ZV"[X S ERR=$S("Z"[X:31,1:27) D ^XINDX1
61FX S X="$"_F1,CH="" D FNC("$F"),ADD,SUM("F") Q
62SPV S X=S D FNC("$V"),ADD,SUM("V") S X=$E(S,2,9),CH=""
63 I $E(S,2)="Z" D E^XINDX1(28) Q
64 I '$D(IND("SVN",X)) D E^XINDX1(4)
65 Q
66EXT ;EXTRINSIC
67 S X=S,CH="" D FNC("$$"),ADD,SUM("V") Q
68SSVN ;Error 54 access for Kernel only
69 D INC S X=$$GVAR() I '$D(IND("SSVN",$E(X,3,99))) D E^XINDX1(4) Q ;Need new #
70 D E^XINDX1(54),ADD,SUM("V") Q
71PKG ;External Function
72 S J=$F(STR,"(",I),I=J-2,X=S_$E(STR,LL,I),LL=J-1,CH=""
73 D ADD,E^XINDX1(55) ;Not standard VA
74 Q
75E S ERR=11 D ^XINDX1 Q ;
76PAT F I=I+1:1 S CH=$E(STR,I) D PATQ:CH=Q,PAREN:CH="(" I CH=""!(CH'?1N&("ACELNPUacelnpu."'[CH)) Q
77 S I=I-1 I ":),@+-_*/\!&'"'[CH D E^XINDX1(16),SEP Q
78 Q
79PATQ F I=I+1:1 S CH=$E(STR,I) Q:CH=""!(CH=Q)
80 S ERR=6,I=I+1,CH=$E(STR,I) D:$E(STR,I-1)="" ^XINDX1 G:CH=Q PATQ
81 Q
82PAREN F I=I+1:1 S CH=$E(STR,I) Q:CH=""!(CH=")")
83 D:CH="" E^XINDX1(5) S CH="."
84 Q
85PEND D AR,E^XINDX1(5):LV>1,E^XINDX1(21):($G(LV(1,1))=",") ;LV>1 means mis-match ()
86 Q
87SEP ;Find sep
88 Q
89SUM(P) ;Build summry line
90 S LV(LV,"S")=$G(LV(LV,"S"))_P
91 Q
92TEST S STR="@^(0)" D XINDX9
Note: See TracBrowser for help on using the repository browser.