source: BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/BMX41000/routines/BMXSQL6.m@ 1691

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

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