source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/m/BMXSQL6.m@ 645

Last change on this file since 645 was 645, checked in by Sam Habiel, 14 years ago

Initial Import of BMX.net code
File size: 11.1 KB
Line 
1BMXSQL6 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 7/20/2009
2 ;;2.1;BMX;;Jul 26, 2009
3 ; Line EOR+3 used a 2 argument form of $Q which is not
4 ; in the M 95 standard. Replaced this with a call to $$LAST,
5 ; a new Extrinsic in this routine.
6 ;
7 ;
8WRITE ;EP
9 N BMXFN,C,BMXN,BMXGF,BMXA,BMXFLDF,N,A,IEN0,I
10 N BMXCNT,BMXCNTB,BMXLEN,BMXLTMP,BMXNUM,BMXORD,BMXTYP
11 N BMXCFN,BMXCFNX,F,BMXROOT,BMXCID,BMXZ ;From MAKEC
12 N BMXREC,BMXCHAIN ;TODO: COMMENT AFTER TESTING
13 N BMXIENS
14 ;Set up FIELD value for GETS^DIQ call
15 ; BMXFLD("NAME")="FILE#^FIELD#"
16 ; Need: BMXFLDN(FieldNumber)
17 ; and : BMXFLDO(SelectOrder)
18 ; Get file number -- for now just use first file in array
19 ; TODO: Set up same main file and related files here and in enumerator
20 S C=0,BMXN=""
21 N F
22 S BMXGF=0
23 S F=0 F S F=$O(BMXF(F)) Q:F="" S BMXFN=BMXF(F) D
24 . S C=0,BMXN=-1 F S BMXN=$O(BMXFLDO(BMXN)) Q:BMXN="" D
25 . . Q:$P(BMXFLDO(BMXN),U)'=BMXFN
26 . . I $P(BMXFLDO(BMXN),U,2)=".001" S BMXGF=BMXGF+1 Q
27 . . S C=C+1
28 . . S $P(BMXGF(BMXFN),";",C)=$P(BMXFLDO(BMXN),U,2)
29 . . S:'$D(BMXGF(BMXFN,"INTERNAL")) BMXGF(BMXFN,"INTERNAL")="E"
30 . . I $P(BMXFLDO(BMXN),U,3)="I" S BMXGF(BMXFN,"INTERNAL")="IE"
31 . . S BMXGF=BMXGF+1
32 . . Q
33 . Q
34 ;
35 I BMXGF>1 K BMXTK("DISTINCT") ;Distinct supported for only one field
36 S N=0,BMXFLDF=0,I=1,BMXNUM=0
37 D FIELDS
38 D MAKEC
39 ;
40 ;
41 I BMXCOL D COLTYPE^BMXSQL,ERRTACK^BMXSQL(I) Q ;Column info only
42 ;
43 S BMXA="A"
44 N G,R
45 ;---> Loop through results global
46 F S N=$O(^BMXTMP($J,N)) Q:'+N D
47 . K A
48 . S R=0 F S R=$O(BMXFO(R)) Q:'+R D ;For each file in ORDER array
49 . . S IEN0=0
50 . . S BMXFN=BMXFO(R)
51 . . Q:$D(BMXMFL(BMXFN,"MULT"))
52 . . I R=1 S IEN0=^BMXTMP($J,N) ;Primary file
53 . . I R>1,$D(BMXFJ("JOIN",BMXFN)) D ;Joined file
54 . . . S IEN0=0
55 . . . S G=BMXFJ("JOIN",BMXFN)
56 . . . S V=BMXFF(G,"JOIN","IEN")
57 . . . S @V=^BMXTMP($J,N)
58 . . . X BMXFF(G,"JOIN")
59 . . I +IEN0 D ;Removed $D(BMXGF(BMXFN)) for mult fld on extdnd ptr
60 . . . D SUBFILE(BMXFN)
61 . . I +IEN0,$D(BMXFLDN(BMXFN,.001)) D SETIEN(IEN0,BMXFN)
62 . . ;
63 . . I 0,R>1,$D(BMXMFL(BMXFN,"MULT")) D ;Multiple field
64 . . . Q:'+IEN0
65 . . . Q:'$D(BMXGF(BMXFN)) ;Intervening multiple
66 . . . ;Call GETS for each subentry in multiple
67 . . . X BMXMFL(BMXFN,"EXEC")
68 . S F=0,BMXCNT=0
69 . ;
70 . D RECORD
71 . D OUT
72 ;
73 ;
74 ;---> Tack on Error Delimiter and any error.
75 S I=I+1
76 D ERRTACK^BMXSQL(I)
77 D COLTYPE^BMXSQL
78 Q
79 ;
80SETIEN(BMXIEN,BMXFN) ;
81 ;B ;SETIEN
82 Q:'$D(BMXFLDN(BMXFN,.001))
83 Q:'+BMXIEN
84 S A(BMXFN,BMXIEN_",",.001,"E")=BMXIEN
85 Q
86 ;
87SUBFILE(BMXFN) ;
88 ;Execute GETS for Any fields in BMXGF(SUBFILE)
89 ;
90 ;If the subfile itself has subfiles, call SUBFILE(BMXSUBFN)
91 ; (Loop through BMXMFL(BMXFN,"SUBFILE",BMXSUBFN))
92 I $D(BMXMFL(BMXFN,"SUBFILE")) D
93 . N BMXSUBFN
94 . S BMXSUBFN=0
95 . F S BMXSUBFN=$O(BMXMFL(BMXFN,"SUBFILE",BMXSUBFN)) Q:'+BMXSUBFN D SUBFILE(BMXSUBFN)
96 . Q
97 ;
98 I $D(BMXGF(BMXFN)) D
99 . I '$D(BMXMFL(BMXFN,"MULT")) S BMXMSCR=1 D GETS^DIQ(BMXFN,IEN0_",",BMXGF(BMXFN),BMXGF(BMXFN,"INTERNAL"),BMXA) Q
100 . E X BMXMFL(BMXFN,"EXEC") Q
101 ;
102 ;
103 Q
104 ;
105FIELDS ;---> Write Field Names
106 ;Field name is TAAAAANAME
107 ;Where T is the field type (T=Text; D=Date)
108 ; AAAAA is the field size (see NUMCHAR routine)
109 ; NAME is the field name
110 N BMXNUM,BMXFNUM,BMXFNAM,R
111 K BMXLEN,BMXTYP
112 S BMXFLDF=1
113 S BMXNUM=0
114 ;B ;In FIELDS sub
115 D ;:$D(A)
116 . I BMXNUM S ^BMXTEMP($J,I)="IEN^",BMXLEN(I)=10,BMXTYP(I)="T",I=I+1 ;TODO: Change from text to number
117 . S BMXFNUM=0
118 . S BMXFNAM=0
119 . F R=0:1:(BMXFLDO-1) S BMXFN=$P(BMXFLDO(R),U),BMXFNUM=$P(BMXFLDO(R),U,2) D
120 . . ;S BMXFNAM=$P(^DD(BMXFN,BMXFNUM,0),"^") ;Get type here
121 . . S BMXFNAM=BMXFLDN(BMXFN,BMXFNUM)
122 . . I $P(BMXFLDO(R),U,3)="I" S BMXFNAM="INTERNAL["_BMXFNAM_"]"
123 . . S BMXFNAM=$TR(BMXFNAM," ","_")
124 . . I BMXF>1 S BMXFNAM=$TR($P(BMXFNX(BMXFN),".")," ","_")_"."_BMXFNAM
125 . . S BMXTYP(I)="T"
126 . . S:$P(BMXFLDO(R),U,5)="D" BMXTYP(I)="D"
127 . . S:$P(BMXFLDO(R),U,5)="I" BMXTYP(I)="I"
128 . . S BMXLEN(I)=0 ;Start with length zero
129 . . ;I $D(BMXFLDA(BMXFN,BMXFNUM)) S BMXFNAM=BMXFLDA(BMXFN,BMXFNUM)
130 . . I $P(BMXFLDO(R),U,6)]"" S BMXFNAM=$P(BMXFLDO(R),U,6)
131 . . S ^BMXTEMP($J,I)=BMXFNAM_"^"
132 . . S I=I+1
133 . S ^BMXTEMP($J,I-1)=$E(^BMXTEMP($J,I-1),1,$L(^BMXTEMP($J,I-1))-1)_$C(30)
134 Q
135 ;
136OUT ;
137 ;Output to BMXTEMP($J
138 Q:'$D(BMXREC)
139 N J,K,L,BMXLENT
140 S J=0 F S J=$O(BMXREC(J)) Q:'+J D
141 . S K=0 F S K=$O(BMXREC(J,K)) Q:'+K D
142 . . I +$O(BMXREC(J,K,0)) D Q ;WP
143 . . . S L=0,BMXLENT=0 F S L=$O(BMXREC(J,K,L)) Q:'+L D
144 . . . . S:'$D(^BMXTEMP($J,I)) ^BMXTEMP($J,I)=""
145 . . . . S:$L(^BMXTEMP($J,I))>250 I=I+1,^BMXTEMP($J,I)=""
146 . . . . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K,L)
147 . . . . S BMXLENT=BMXLENT+$L(BMXREC(J,K,L))
148 . . . I BMXLEN(K)<BMXLENT S BMXLEN(K)=BMXLENT
149 . . S:'$D(^BMXTEMP($J,I)) ^BMXTEMP($J,I)=""
150 . . S:$L(^BMXTEMP($J,I))>250 I=I+1,^BMXTEMP($J,I)=""
151 . . I $G(BMXTK("DISTINCT"))="TRUE",BMXREC(J,K)]"" Q:$D(^BMXTEMP($J,"DISTINCT",BMXREC(J,K)))
152 . . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K)
153 . . S:$L(BMXREC(J,K))>BMXLEN(K) BMXLEN(K)=$L(BMXREC(J,K))
154 . . I $G(BMXTK("DISTINCT"))="TRUE" S ^BMXTEMP($J,"DISTINCT",BMXREC(J,K))=""
155 Q
156 ;
157RECORD ;
158 ;For each chain
159 N C,BMXCQ,BMXLCQ,BMXCQN,BMXLCQN,BMXTRACK,BMXNODE,BMXCNAME,BMXWP
160 K BMXREC,BMXCHAIN ;TODO: REMOVE AFTER TESTING
161 D BLDCHN
162 S BMXREC=0
163 D RECINI
164 S C=0 F S C=$O(BMXCHAIN(C)) Q:'+C D
165 . ;New chain
166 . ;Go to the end of the chain, writing record pieces as you go
167 . ;At the end of the chain, write end-of-record marker,increment record counter, copy previous record
168 . K BMXTRACK
169 . S BMXCNAME="BMXCHAIN("_C_")"
170 . S BMXCQN=""
171 . S BMXCQ=BMXCNAME F S BMXCQ=$Q(@BMXCQ) Q:BMXCQ="" Q:$P(BMXCQ,",")'=("BMXCHAIN("_C) D
172 . . S BMXNODE=@BMXCQ
173 . . I $P(BMXNODE,U,2)="" Q
174 . . S BMXWP=$P(BMXNODE,U,3)
175 . . S BMXLCQ=$L(BMXCQ,",")
176 . . S BMXCQN=$Q(@BMXCQ)
177 . . S BMXLCQN=$L(BMXCQN,",")
178 . . I BMXWP="W" D
179 . . . S BMXREC(BMXREC,$P(BMXNODE,U,2),$P(BMXNODE,U,4))=$P(BMXNODE,U)
180 . . . S BMXTRACK(BMXLCQ-1,$P(BMXNODE,U,2))=BMXNODE
181 . . E D
182 . . . S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U
183 . . . S BMXTRACK(BMXLCQ,$P(BMXNODE,U,2))=BMXNODE
184 . . I BMXCQN="" D EOR Q
185 . . I $P(BMXCQN,",")'=("BMXCHAIN("_C) D EOR Q
186 . . I BMXLCQN>BMXLCQ Q
187 . . I (BMXLCQN>$S(BMXWP="W":7,1:6)) D Q
188 . . . I ($P(BMXCQ,",",1,BMXLCQ-2)=$P(BMXCQN,",",1,BMXLCQN-2)) Q
189 . . . D EOR ;End of chain
190 Q
191 ;
192RECINI ;
193 N J
194 S BMXREC=BMXREC+1
195 F J=1:1:BMXFLDO D
196 . I $P(BMXFLDO(J-1),U,4)="W" S BMXREC(BMXREC,J,999999)="^" Q
197 . S BMXREC(BMXREC,J)="^"
198 Q
199 ;
200EOR ;
201 ;B ;EOR
202 N J,K,L,M,I,N
203 ; S M=$Q(BMXREC(9999999),-1) //SMH - Another Cacheism
204 S M=$$LAST("BMXREC")
205 S @M=$TR(@M,"^",$C(30))
206 Q:BMXCQN=""
207 I BMXCQN'="" D RECINI
208 ;K BMXTRACK(BMXLCQ) ;Also kill all track levels between current and next level
209 F K BMXTRACK($O(BMXTRACK(999999),-1)) Q:$O(BMXTRACK(9999999),-1)'>BMXLCQN
210 S J=0 F S J=$O(BMXTRACK(J)) Q:'+J D ;Level
211 . S K=0 F S K=$O(BMXTRACK(J,K)) Q:'+K D ;Order
212 . . I $D(BMXTRACK(J,K)) S BMXNODE=BMXTRACK(J,K) S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U
213 . . S L=0 F S L=$O(BMXTRACK(J,K,L)) Q:'+L D ;wp node
214 . . . I $D(BMXTRACK(J,K,L)) S BMXNODE=BMXTRACK(J,K,L) S BMXREC(BMXREC,$P(BMXNODE,U,2),L)=$P(BMXNODE,U)
215 Q
216 ;
217BLDCHN ;
218 N B
219 D MAKEB
220 ;D MAKEC
221 D BUILD
222 Q
223 ;
224MAKEC ;
225 ;MAKE Chain
226 ;How many chains are there?
227 S BMXZ=0 S BMXCID=1 K BMXCFN
228 ;
229 ;
230 ;Create BMXCHNP(BMXCID)
231 S F=0 F S F=$O(BMXMFL(F)) Q:'+F I '$D(BMXMFL("SUBFILE",F)),$D(BMXMFL("PARENT",F)) S BMXMFL("BOTTOM",F)=""
232 N BMXCB,BMXCHNP,BMXP
233 S BMXCID=0,BMXCB=0,BMXCHNP=0
234 I $D(BMXMFL("BOTTOM")) F S BMXCB=$O(BMXMFL("BOTTOM",BMXCB)) Q:'BMXCB D
235 . S BMXCID=BMXCID+1,BMXCHNP=BMXCID
236 . S BMXCHNP(BMXCID)=BMXCB
237 . S BMXP=BMXCB
238 . F Q:'$D(BMXMFL("PARENT",BMXP)) S BMXP=BMXMFL("PARENT",BMXP) S BMXCHNP(BMXCID)=BMXP_U_BMXCHNP(BMXCID)
239 ;
240 N J,K,L,M
241 ;Create BMXMFL("BASE")="FILE1^FILE2^...^FILEN"
242 S F=0,M=0,BMXMFL("BASE")="" F S F=$O(BMXMFL(F)) Q:'+F I (('$D(BMXMFL("PARENT",F)))&('$D(BMXMFL(F,"SUBFILE"))))!(BMXFO(1)=F) S M=M+1,$P(BMXMFL("BASE"),U,M)=F ;Changed to make BMXFO(1) always a member of the base
243 ;
244 ;Create BMXCFN(BMXCID,BMXZ,FILE)
245 I BMXCID=0 S BMXCID=1
246 S J=0,BMXZ=0 F J=1:1:BMXCID D
247 . I BMXMFL("BASE")]"" F L=1:1:$L(BMXMFL("BASE"),"^") S F=$P(BMXMFL("BASE"),"^",L) D
248 . . S BMXZ=BMXZ+100
249 . . S BMXCFN(J,BMXZ,F)=""
250 . I +BMXCHNP F K=1:1:$L(BMXCHNP(J),"^") S F=$P(BMXCHNP(J),"^",K) D
251 . . Q:F=BMXFO(1) ;BMXFO(1) Is always a member of the base
252 . . S BMXZ=BMXZ+100
253 . . S BMXCFN(J,BMXZ,F)=""
254 ;
255 ;
256 ;B ;FIXCFN
257 D FIXCFN
258 Q
259 ;
260BUILD ;Building BMXCHAIN(
261 N BMXIEN,BMXCID,BMXFLD,BMXCS,BMXINT,BMXCFNC,BMXCFIEN
262 S BMXCID=0,BMXIEN=0
263 F S BMXCID=$O(BMXCFN(BMXCID)) Q:'+BMXCID D
264 . S BMXCFNC=0 F S BMXCFNC=$O(BMXCFN(BMXCID,BMXCFNC)) Q:'+BMXCFNC S BMXCFN=+BMXCFN(BMXCID,BMXCFNC) D
265 . . S BMXIEN=0 F S BMXIEN=$O(B(BMXCFN,BMXIEN)) Q:BMXIEN="" D
266 . . . S $P(BMXCFN(BMXCID,BMXCFNC),U,2)=BMXIEN
267 . . . S BMXFLD=0 F S BMXFLD=$O(B(BMXCFN,BMXIEN,BMXFLD)) Q:'+BMXFLD D
268 . . . . S BMXINT="D" F S BMXINT=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D
269 . . . . . Q:'$D(BMXFLDOX(BMXCFN,BMXFLD,BMXINT))
270 . . . . . I $P(BMXFLDO(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)),U,4)="W" D MCWP Q
271 . . . . . D FIXIEN
272 . . . . . S BMXCS="BMXCHAIN("_BMXCID_","_$S($L(BMXIEN,",")=2:1,1:2)_","_BMXCFIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")"
273 . . . . . S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXINT)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)
274 Q
275 ;
276FIXIEN ;
277 N BMXC,BMXCFN1,BMXOFF
278 S BMXC=BMXCFNC
279 S BMXCFIEN=BMXCFN_","_$P(BMXIEN,",",$L(BMXIEN,","))
280 S BMXOFF=1
281 F S BMXC=$O(BMXCFN(BMXCID,BMXC),-1) Q:'+BMXC D
282 . S BMXCFN1=+BMXCFN(BMXCID,BMXC)
283 . I '$D(BMXMFL(BMXCFN,"OTM")) D
284 . . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q
285 . . S BMXCFIEN=BMXCFN1_","_$P(BMXIEN,",",$L(BMXIEN,",")-BMXOFF)_","_BMXCFIEN
286 . I $D(BMXMFL(BMXCFN,"OTM")) D
287 . . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q
288 . . S BMXCFIEN=BMXCFN1_$P(BMXCFN(BMXCID,BMXC),U,2)_","_BMXCFIEN
289 . S BMXOFF=BMXOFF+1
290 ;
291 ;
292 Q
293 ;
294FIXCFN ;
295 N J,K,L
296 S J=0 F S J=$O(BMXCFN(J)) Q:'+J D
297 . S K=0 F S K=$O(BMXCFN(J,K)) Q:'+K D
298 . . S L=0 F S L=$O(BMXCFN(J,K,L)) Q:'+L D
299 . . . K BMXCFN(J,K,L)
300 . . . S BMXCFN(J,K)=L
301 ;
302 Q
303 ;
304MCWP ;
305 ;MAKEC Process WP Field
306 N BMXIENL,BMXWP
307 S BMXIENL=1
308 S:$L(BMXIEN,",")>2 BMXIENL=2
309 S BMXWP=0
310 ;
311 F S BMXWP=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXWP)) Q:'+BMXWP D
312 . S BMXCS="BMXCHAIN("_BMXCID_","_BMXIENL_","_BMXCFN_BMXIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_","_BMXWP_")"
313 . S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXWP)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)_U_"W"_U_BMXWP
314 Q
315 ;
316 ;
317MAKEB ;
318 N BMXFILE,BMXIEN,BMXFLD,BMXINT
319 N BMXSUB,BMXIENR
320 S BMXFILE=0 F S BMXFILE=$O(A(BMXFILE)) Q:'+BMXFILE D
321 . S BMXIEN=0 F S BMXIEN=$O(A(BMXFILE,BMXIEN)) Q:'+BMXIEN D
322 . . S BMXFLD=0 F S BMXFLD=$O(A(BMXFILE,BMXIEN,BMXFLD)) Q:'+BMXFLD D
323 . . . S BMXINT=0 F S BMXINT=$O(A(BMXFILE,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D
324 . . . . S BMXIENR=$$REVERSE(BMXIEN)
325 . . . . S BMXSUB="B("_BMXFILE_","_$C(34)_BMXIENR_$C(34)_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")"
326 . . . . I $D(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),$P(BMXFLDO(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),U,5)="D" D Q
327 . . . . . S @BMXSUB=$TR(A(BMXFILE,BMXIEN,BMXFLD,BMXINT),"@"," ")
328 . . . . S @BMXSUB=A(BMXFILE,BMXIEN,BMXFLD,BMXINT)
329 Q
330 ;
331REVERSE(BMXIEN) ;
332 N J,T,C
333 S C=1
334 F J=$L(BMXIEN,","):-1:1 D
335 . S $P(T,",",C)=$P(BMXIEN,",",J)
336 . S C=C+1
337 Q T
338LAST(VAR) ; Get last entry in an array //SMH new code
339 N SUB1 S SUB1=$O(@VAR@(""),-1)
340 N SUB2 S SUB2=$O(@VAR@(SUB1,""),-1)
341 N SUB3 S SUB3=$O(@VAR@(SUB1,SUB2,""),-1)
342 I SUB3="" Q $NA(@VAR@(SUB1,SUB2))
343 E Q $NA(@VAR@(SUB1,SUB2,SUB3))
Note: See TracBrowser for help on using the repository browser.