source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/m/BMXFIND.m@ 740

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

Initial Import of BMX.net code
File size: 8.0 KB
Line 
1BMXFIND ; IHS/OIT/HMW - BMX GENERIC FIND ;
2 ;;2.1;BMX;;Jul 26, 2009
3 ;
4 ;
5TABLE(BMXGBL,BMXFL) ;EP
6 ;
7 ;---> If file number not provided check for file name.
8 ;S ^HW("BMXTABLE")=BMXFL
9 S BMX31=$C(31)_$C(31)
10 I +BMXFL'=BMXFL D
11 . S BMXFL=$TR(BMXFL,"_"," ")
12 . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
13 . S BMXFL=$O(^DIC("B",BMXFL,0))
14 I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
15 D FIND(.BMXGBL,BMXFL,"*",,,10,,,,1)
16 Q
17 ;
18FIND(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC,BMXNUM) ;EP
19 ;
20 ;TODO:
21 ; -- Return column info even if no rows returned
22 ;
23 ;---> Places matching records from requested file into a
24 ;---> result global, ^BMXTEMP($J). The exact global name
25 ;---> is returned in the first parameter (BMXGBL).
26 ;---> Records are returned one per node in the result global.
27 ;---> Each record is terminated with a $C(30), for parsing out
28 ;---> on the VB side, since the Broker concatenates all nodes
29 ;---> into a single string when passing the data out of M.
30 ;---> Requested fields within records are delimited by "^".
31 ;---> NOTE: The first "^"-piece of every node is the IEN of
32 ;---> that entry in its file; the requested fields follow.
33 ;---> The final record (node) contains Error Delimiter,
34 ; $C(31)_$C(31), followed by error text, if any.
35 ;
36 ;
37 ;---> Parameters:
38 ; 1 - BMXGBL (ret) Name of result global for Broker.
39 ; 2 - BMXFL (req) File for lookup.
40 ; 3 - BMXFLDS (opt) Fields to return w/each entry.
41 ; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent.
42 ; 5 - BMXIN (opt) Input to match on (see Algorithm below).
43 ; 6 - BMXMX (opt) Maximum number of entries to return.
44 ; 7 - BMXIX (opt) Indexes to search.
45 ; 8 - BMXSCR (opt) Screen/filter (M code).
46 ; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
47 ; (Converts data in uppercase to mixed case.)
48 ; 10 - BMXNUM (opt) Include IEN in returned recordset (1=true)
49 ;
50 ;---> Set variables, kill temp globals.
51 ;N (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC)
52 S BMX31=$C(31)_$C(31)
53 S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^"
54 K ^BMXTMP($J),^BMXTEMP($J)
55 ;
56 ;---> If file number not provided check for file name.
57 I +BMXFL'=BMXFL D
58 . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
59 . S BMXFL=$O(^DIC("B",BMXFL,0))
60 I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
61 ;
62 ;---> If no fields provided, pass .01.
63 ;---> NOTE: If .01 is NOT included, but the Index to lookup on is
64 ;---> NOT on the .01, then the .01 will be returned
65 ;---> automatically as the second ^-piece of data in the
66 ;---> Result Global.
67 ;---> So it would be: IEN^.01^requested fields...
68 I $G(BMXFLDS)="" S BMXFLDS=".01"
69 ;
70 ;---> If no index or flag provided, set flag="M".
71 I $G(BMXFLG)="" D
72 .I $G(BMXIX)="" S BMXFLG="M" Q
73 .S BMXFLG=""
74 ;
75 ;---> If no Maximum Number provided, set it to 200.
76 I '$G(BMXMX) S BMXMX=200
77 ;
78 ;---> Define index and screen.
79 S:'$D(BMXIX) BMXIX=""
80 S:'$D(BMXSCR) BMXSCR=""
81 ;
82 ;---> Set Target Global for output and errors.
83 S BMXG="^BMXTMP($J)"
84 ;
85 ;---> If Mixed Case not set, set to No Change.
86 I '$D(BMXMC) S BMXMC=0
87 ;
88 ;---> If Return IEN not set, set to No
89 I '$D(BMXNUM) S BMXNUM=0
90 S BMXNUM=+BMXNUM
91 ;
92 ;---> Silent Fileman call.
93 D
94 .I $G(BMXIN)="" D Q
95 ..D LIST^DIC(BMXFL,,,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG)
96 .D FIND^DIC(BMXFL,,,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG)
97 ;
98 D WRITE
99 Q
100 ;
101 ;
102 ;----------
103WRITE ;EP
104 ;---> Collect data for matching records and write in result global.
105 ;
106 ;---> First, check for errors.
107 ;---> If errors exist, write them and quit.
108 N I,N,X
109 I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q
110 .S N=0,X=""
111 .F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D
112 ..N M S M=0
113 ..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D
114 ...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" "
115 .D ERROUT(X,1)
116 ;
117 ;
118 ;---> Write valid results.
119 ;---> Loop through the IEN node (...2,N) of the temp global.
120 ; and call GETS^DIQ for each record
121 N I,N,X S N=0
122 S BMXA="A"
123 ;B
124 S I=0
125 S BMXFLDF=0
126RESULTS F S N=$O(^BMXTMP($J,"DILIST",2,N)) Q:'N D
127 . S X=^BMXTMP($J,"DILIST",2,N)
128 . S I=I+1
129 . K A
130 . D GETS^DIQ(BMXFL,X_",",BMXFLDS,,BMXA,BMXA)
131 . ;--->Once only, write field names
132 . D:'BMXFLDF FIELDS
133 . ;
134 . ;
135 . ;---> Loop through results global
136 . S F=0,BMXCNT=0
137 . F S F=$O(A(BMXFL,X_",",F)) Q:'F S BMXCNT=BMXCNT+1
138 . S F=0
139 . S BMXREC=""
140 . S:BMXNUM ^BMXTEMP($J,I)=X_"^"
141 . S BMXCNTB=0
142 . S BMXORD=BMXNUM
143 . F S F=$O(A(BMXFL,X_",",F)) Q:'F S BMXCNTB=BMXCNTB+1 D S:BMXCNTB<BMXCNT ^BMXTEMP($J,I)=^BMXTEMP($J,I)_U
144 . . S BMXORD=BMXORD+1
145 . . I $P(^DD(BMXFL,F,0),U,2) D I 1 ;Multiple or WP
146 . . . ;Get the subfile number into FL1
147 . . . S FL1=+$P(^DD(BMXFL,F,0),U,2)
148 . . . S FLD1=$O(^DD(FL1,0))
149 . . . I $P(^DD(FL1,FLD1,0),U,2)["W" D ;WP
150 . . . . S WPL=0,BMXLTMP=0
151 . . . . F S WPL=$O(A(BMXFL,X_",",F,WPL)) Q:'WPL S I=I+1 D
152 . . . . . S ^BMXTEMP($J,I)=A(BMXFL,X_",",F,WPL)_" "
153 . . . . . S BMXLTMP=BMXLTMP+$L(A(BMXFL,X_",",F,WPL))+1
154 . . . . . Q
155 . . . . S:BMXLTMP>BMXLEN(BMXORD) BMXLEN(BMXORD)=BMXLTMP
156 . . . . Q
157 . . . D ;It's a multiple. Implement in next phase
158 . . . . Q ;
159 . . . Q
160 . . E D ;Not a multiple
161 . . . S I=I+1
162 . . . S ^BMXTEMP($J,I)=A(BMXFL,X_",",F)
163 . . . S:$L(A(BMXFL,X_",",F))>BMXLEN(BMXORD) BMXLEN(BMXORD)=$L(A(BMXFL,X_",",F))
164 . . . Q
165 . . Q
166 . ;---> Convert data to mixed case if BMXMC=1.
167 . ;S:BMXMC BMXREC=$$T^BMXTRS(BMXREC)
168 . ;---> Set data in result global.
169 . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_$C(30)
170 ;
171 ;---> If no results, report it as an error.
172 D:'$O(^BMXTEMP($J,0))
173 .I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q
174 .S BMXERR="Either the lookup file is empty"
175 .S BMXERR=BMXERR_" or all entries are screened (software error)."
176 ;
177 ;---> Tack on Error Delimiter and any error.
178 S I=I+1
179 S ^BMXTEMP($J,I)=BMX31_BMXERR
180 ;---> Column types and widths
181 S C=0
182 F S C=$O(BMXLEN(C)) Q:'C D
183 . I BMXLEN(C)>99999 S BMXLEN(C)=99999
184 . S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C)
185 Q
186 ;
187 ;
188NUMCHAR(BMXN) ;EP
189 ;---> Returns Field Length left-padded with 0
190 ;
191 N BMXC
192 S BMXC="00000"_BMXN
193 Q $E(BMXC,$L(BMXC)-4,$L(BMXC))
194 ;
195 ;---> Dead code follows
196 N C,BMXC,F,N,J
197 S BMXC=""
198 S N=BMXN
199 S:N>99999 N=99999
200 S:N<0 N=0
201 F J=1:1:$L(N) D
202 . S F=10**(J-1)
203 . S C=65+(N-((N\(10*F))*(10*F))\F)
204 . S C=$C(C)
205 . S BMXC=C_BMXC
206 S BMXC="AAAAA"_BMXC
207 Q $E(BMXC,$L(BMXC)-4,$L(BMXC))
208 ;
209 ;
210FIELDS ;---> Write Field Names
211 ;Field name is TAAAAANAME
212 ;Where T is the field type (T=Text; D=Date)
213 ; AAAAA is the field size (see NUMCHAR routine)
214 ; NAME is the field name
215 S BMXFLDF=1
216 K BMXLEN,BMXTYP
217 D:$D(A)
218 . I BMXNUM S ^BMXTEMP($J,I)="IEN^",BMXLEN(I)=10,BMXTYP(I)="T",I=I+1 ;TODO: Change from text to number
219 . S ASDXFNUM=0
220 . S BMXIENS=$O(A(BMXFL,0))
221 . F S ASDXFNUM=$O(A(BMXFL,BMXIENS,ASDXFNUM)) Q:'ASDXFNUM D
222 . . S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^") ;Get type here
223 . . S ASDXFNAM=$TR(ASDXFNAM," ","_")
224 . . S BMXTYP(I)="T"
225 . . S BMXLEN(I)=0 ;Start with length zero
226 . . S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_I
227 . . S ^BMXTEMP($J,I)=ASDXFNAM_"^"
228 . . S I=I+1
229 . S ^BMXTEMP($J,I-1)=$E(^BMXTEMP($J,I-1),1,$L(^BMXTEMP($J,I-1))-1)_$C(30)
230 Q
231 ;
232 ;----------
233ERROUT(BMXERR,I) ;EP
234 ;---> Save next line for Error Code File if ever used.
235 ;---> If necessary, use I>1 to avoid overwriting valid data.
236 S:'$G(I) I=1
237 S ^BMXTEMP($J,I)=BMX31_BMXERR
238 Q
239 ;
240 ;
241PASSERR(BMXGBL,BMXERR) ;EP
242 ;---> If the RPC routine calling the BMX Generic Lookup above
243 ;---> detects a specific error prior to the call and wants to pass
244 ;---> that error in the result global rather than a generic error,
245 ;---> then a call to this function (PASSERR) can be made.
246 ;---> This call will store the error text passed in the result global.
247 ;---> The calling routine should then quit (abort its call to the
248 ;---> BMX Generic Lookup function above).
249 ;
250 ;---> Parameters:
251 ; 1 - BMXGBL (ret) Name of result global for Broker.
252 ; 2 - BMXERR (req) Text of error to be stored in result global.
253 ;
254 S:$G(BMXERR)="" BMXERR="Error not passed (software error)."
255 ;
256 N BMX31 S BMX31=$C(31)_$C(31)
257 K ^BMXTMP($J),^BMXTEMP($J)
258 S BMXGBL="^BMXTEMP("_$J_")"
259 S ^BMXTEMP($J,1)=BMX31_BMXERR
260 Q
Note: See TracBrowser for help on using the repository browser.