-
Notifications
You must be signed in to change notification settings - Fork 1
/
XINDEX.m
134 lines (134 loc) · 5.42 KB
/
XINDEX.m
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
XINDEX ;ISC/REL,GFT,GRK,RWF - INDEX & CROSS-REFERENCE ;08/04/08 13:19
;;7.3;TOOLKIT;**20,27,48,61,66,68,110,121**;Apr 25, 1995;Build 7
; Per VHA Directive 2004-038, this routine should not be modified.
G ^XINDX6
SEP F I=1:1 S CH=$E(LIN,I) D QUOTE:CH=Q Q:" "[CH
S ARG=$E(LIN,1,I-1) S:CH=" " I=I+1 S LIN=$E(LIN,I,999) Q
QUOTE F I=I+1:1 S CH=$E(LIN,I) Q:CH=""!(CH=Q)
Q:CH]"" S ERR=6 G ^XINDX1
ALIVE ;enter here from taskman
D SETUP^XINDX7 ;Get ready to process
A2 S RTN=$O(^UTILITY($J,RTN)) G ^XINDX5:RTN=""
S INDLC=(RTN?1"|"1.4L.NP) D LOAD:'INDLC
I $D(ZTQUEUED),$$S^%ZTLOAD S RTN="~",IND("QUIT")=1,ZTSTOP=1 G A2
I 'INDDS,INDLC W !!?10,"Data Dictionaries",! S INDDS=1
D BEG
G A2
;
LOAD S X=RTN,XCNP=0,DIF="^UTILITY("_$J_",1,RTN,0," X ^%ZOSF("TEST") Q:'$T X ^%ZOSF("LOAD") S ^UTILITY($J,1,RTN,0,0)=XCNP-1
I $D(^UTILITY($J,1,RTN,0,0)) S ^UTILITY($J,1,RTN,"RSUM")="B"_$$SUMB^XPDRSUM($NA(^UTILITY($J,1,RTN,0)))
Q
BEG ;
S %=INDLC*5 W:$X+10+%>IOM ! W RTN,$J("",10+%-$L(RTN))
S (IND("DO"),IND("SZT"),IND("SZC"),LABO)=0,LC=$G(^UTILITY($J,1,RTN,0,0))
I LC="" W !,">>>Routine '",RTN,"' not found <<<",! Q
S TXT="",LAB=$P(^UTILITY($J,1,RTN,0,1,0)," ") I RTN'=$P(LAB,"(") D E^XINDX1(17)
I 'INDLC,LAB["(" D E^XINDX1(55) S LAB=$P(LAB,"(")
I 'INDLC,LC>2 S LIN=$G(^UTILITY($J,1,RTN,0,2,0)),TXT=2 D
. N LABO S LABO=1
. I $P(LIN,";",3,99)'?1.2N1"."1.2N.1(1"T",1"V").2N1";".E D E^XINDX1(44) ;patch 121
. I $L(INP(11)) X INP(11) ;Version number check
. I $L(INP(12)) X INP(12) ;Patch number check
B5 F TXT=1:1:LC S LIN=^UTILITY($J,1,RTN,0,TXT,0),LN=$L(LIN),IND("SZT")=IND("SZT")+LN+2 D LN,ST ;Process Line
S LAB="",LABO=0,TXT=0,^UTILITY($J,1,RTN,0)=IND("SZT")_"^"_LC_"^"_IND("SZC")
I IND("SZT")>INP("MAX"),'INDLC S ERR=35,ERR(1)=IND("SZT") D ^XINDX1
I IND("SZT")-IND("SZC")>INP("CMAX"),'INDLC S ERR=58,ERR(1)=IND("SZT")-IND("SZC") D ^XINDX1
D POSTRTN
Q
;Proccess one line, LN = Length, LIN = Line.
LN K V S (ARG,GRB,IND("COM"))="",X=$P(LIN," ") I '$L(X) S LABO=LABO+1 G CD
S (IND("COM"),LAB)=$P(X,"("),ARG=$P($P(X,"(",2),")"),LABO=0,IND("PP")=X?1.8E1"(".E1")"
D:$L(ARG) NE^XINDX3 ;Process formal parameters as New list.
I 'INDLC,'$$VT^XINDX2(LAB) D E^XINDX1($S(LAB=$$CASE^XINDX52(LAB):37,1:55)) ;Check for bad labels
I $D(^UTILITY($J,1,RTN,"T",LAB)) D E^XINDX1(15) G CD ;DUP label
S ^UTILITY($J,1,RTN,"T",LAB)=""
CD I LN>245 D:'(LN=246&($E(RTN,1,3)="|dd")) E^XINDX1(19) ;patch 119
D:LIN'?1.ANP E^XINDX1(18)
S LIN=$P(LIN," ",2,999),IND("LCC")=1
I LIN="" D E^XINDX1(42) Q ;Blank line ;p110
S I=0 ;Watch the scope of I.
I " ."[$E(LIN) D S X=$L($E(LIN,1,I),".")-1,LIN=$E(LIN,I,999)
. F I=1:1:245 Q:". "'[$E(LIN,I)
. Q
D:'I&$G(IND("DO1")) E^XINDX1(51) S IND("DO1")=0 S:'I IND("DO")=0 I I D:X>IND("DO") E^XINDX1(51) S IND("DO")=X
;Count Comment lines, skip ;; lines
I $E(LIN)=";",$E(LIN,2)'=";" S IND("SZC")=IND("SZC")+$L(LIN) ;p110
;Process commands on line.
EE I LIN="" D ^XINDX2 Q
S COM=$E(LIN),GK="",ARG=""
I COM=";" S LIN="" G EE ;p110
I COM=" " S ERR=$S(LIN?1." ":13,1:0),LIN=$S(ERR:"",1:$E(LIN,2,999)) D:ERR ^XINDX1 G EE
D SEP
S CM=$P(ARG,":",1),POST=$P(ARG,":",2,999),IND("COM")=IND("COM")_$C(9)_COM,ERR=48 D:ARG[":"&(POST']"") ^XINDX1 S:POST]"" GRB=GRB_$C(9)_POST,IND("COM")=IND("COM")_":"
;SAC now allows lowercase commands
I CM?.E1L.E S CM=$$CASE^XINDX52(CM),COM=$E(CM) ;I IND("LCC") S IND("LCC")=0 D E^XINDX1(47)
I CM="" D E^XINDX1(21) G EE ;Missing command
S CX=$G(IND("CMD",CM)) I CX="" D G:CX="" EE
. I $E(CM)="Z" S CX="^Z" Q ;Proccess Z commands
. D E^XINDX1(1) S LIN="" Q
S CX=$P(CX,"^",2,9)
D SEP I '$L(LIN),CH=" " D E^XINDX1(13) ;trailing space
I ARG="","CGJMORSUWX"[COM S ERR=49 G ^XINDX1
I CX>0 D E^XINDX1(CX) S CX=""
D:$L(CX) @CX S:ARG'="" GRB=GRB_$C(9)_ARG G EE
B S ERR=25 G ^XINDX1
C S ERR=29 G ^XINDX1
D G DG1^XINDX4
E Q:ARG="" S ERR=7 G ^XINDX1
F G:ARG]"" FR^XINDX4 Q
G G DG^XINDX4
H Q:ARG'="" S ERR=32 G ^XINDX1
J S ERR=36,ARG="" G ^XINDX1
K S ERR=$S(ARG?1"(".E:22,ARG?." ":23,1:0) D:ERR ^XINDX1
G KL^XINDX3
L G LO^XINDX4
M G S^XINDX3
N G NE^XINDX3
O S ERR=34 D ^XINDX1,O^XINDX3 Q
Q Q:ARG="" G Q^XINDX4
R S RDTIME=0 G RD^XINDX3
S G S^XINDX3
TR Q ;What to process. p110
U S ARG=$P(ARG,":") Q
V S ARG="",ERR=20 G ^XINDX1
W G WR^XINDX4
X G XE^XINDX4
Z S ERR=2 D ^XINDX1 G ZC^XINDX4
;
;Save off items from line.
ST S R=LAB_$S(LABO:"+"_LABO,1:"")
;Local variable, Global, Marked Items, Naked global, Internal ref, eXternal ref., Tag ref.
S LOC="" F S LOC=$O(V(LOC)),S="" Q:LOC="" F S S=$O(V(LOC,S)) Q:S="" D SET
S ^UTILITY($J,1,RTN,"COM",TXT)=IND("COM")
Q
;
SET I V(LOC,S)]"" F %="!","~" I V(LOC,S)[%,$G(^UTILITY($J,1,RTN,LOC,S))'[% S ^(S)=$G(^(S))_%
S %=0
SE2 S ARG=$G(^UTILITY($J,1,RTN,LOC,S,%)) I $L(ARG)>230 S %=%+1 G SE2
S ^UTILITY($J,1,RTN,LOC,S,%)=ARG_R_V(LOC,S)_","
Q
;
POSTRTN ;Do more overall checking
N V,E,T,T1,T2
S T="" ;Check for missing Labels
F S T=$O(^UTILITY($J,1,RTN,"I",T)),T2=T Q:T="" S T1=$G(^(T,0)) D
. Q:$E(T2,1,2)="@("
. S:$E(T2,1,2)="$$" T2=$E(T2,3,99)
. I T2]"",'$D(^UTILITY($J,1,RTN,"T",$P(T2,"+",1))) D
. . F I=1:1:$L(T1,",")-1 S LAB=$P(T1,",",I),LABO=+$P(LAB,"+",2),LAB=$P(LAB,"+"),E=14,E(1)=T D E^XINDX1(.E)
. . Q
. Q
S LAB="",LABO=0 ;Check for valid label names
I 'INDLC F S LAB=$O(^UTILITY($J,1,RTN,"T",LAB)) Q:LAB="" D
. I '$$VA^XINDX2(LAB) D E^XINDX1(55) Q
. D:'$$VT^XINDX2(LAB) E^XINDX1(37)
. Q
S LAB="",LABO=0 ;Check for valid variable names.
F S LAB=$O(^UTILITY($J,1,RTN,"L",LAB)) Q:LAB="" D
. D VLNF^XINDX3($P(LAB,"("))
. Q
Q
;
QUICK ;Quick, Just get a routine an print the results
D QUICK^XINDX6()
Q