source: cprs/branches/tmg-cprs/m_files/TMGDIS.m@ 1620

Last change on this file since 1620 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload
File size: 22.6 KB
RevLine 
[796]1TMGDIS ;TMG/kst/Custom version of DIS ;03/25/06 ; 5/19/10 1:16pm
2 ;;1.0;TMG-LIB;**1**;01/01/06
3 ;"-------Prior header below ---------------
4 ;"SFISC/GFT-GATHER SEARCH CRITERIA ;05:52 PM 27 Mar 2002
5 ;";22.0;VA FileMan;**6,97**;Mar 30, 1999
6 ;"Purpose: to GATHER SEARCH CRITERIA
7 ;
8 ;"------Also includes code from DIS2, with header as below.
9DIS2 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS;4JUN2005
10 ;;22.0;VA FileMan;**6,144**;Mar 30, 1999;Build 5
11 ;"
12 ;"NOTE: The following code was just to the point of working when I found a better
13 ;" way to do this via the new LIST^DIC. So I am going to stop work on this code.
14SRCH(TMGINFO,TMGOUT) ;
15 ;"Purpose: Provide an API interface for the classic Fileman console search
16 ;"Input: TMGINFO -- PASS BY REFERENCE. This is pre-defined search terms. Format:
17 ;" TMGINFO("FILE") -- File name or number to be used for search
18 ;" If name is supplied, will be converted to IEN^NAME
19 ;" TMGINFO(1,...) -- Search condition 1 (corresponds to 'A' in console)
20 ;" TMGINFO(2,...) -- Search condition 2 (corresponds to 'B' in console)
21 ;" TMGINFO("LOGIC-IF")=(OPTIONAL) Logic string that would be normally
22 ;" entered at 'IF: ' prompt
23 ;" e.g. "1&2", "A&B", "A+B", or "AB" <--- all the same
24 ;" Default is logic string ANDing all search terms.
25 ;" TMGINFO("LOGIC-OR",1)=(OPTIONAL) Logic string that would be normally
26 ;" entered at 'OR: ' prompt
27 ;" TMGINFO("LOGIC-OR",#)=(OPTIONAL) Logic string that would be normally
28 ;" entered at 'OR: ' prompt. #=2,3,4... For multiple
29 ;" lines of OR logic
30 ;" NOTE: Fileman console labels search terms as "A","B","C",...
31 ;" But the above numbering system uses "1","2","3",...
32 ;" When entering in logic strings, one may use either letters
33 ;" or numbers. A=1, B=2 etc. Note that Fileman allows AB to
34 ;" mean the same as A&B. This is not possible with numbers.
35 ;" --------------------------
36 ;" TMGINFO("SORT IEN")=MyIEN (OPTIONAL) -- If provided, then IEN must point
37 ;" to an existing SORT TEMPLATE that will be used to store the output
38 ;" search into. Any preexisting data in record will be deleated.
39 ;" --------------------------
40 ;" TMGINFO("PRE-SET", -- (Optional) PASS BY REFERENCE. If provided, then only
41 ;" the IEN's provided will be used for further searching. This will
42 ;" allow this function to be call successively, further narrowing a
43 ;" search. The results of a prior run can be passed back in. Format:
44 ;" TMGINFO("PRE-SET",Filenum,IEN)=""
45 ;" TMGINFO("PRE-SET",Filenum,IEN)=""
46 ;" -or-
47 ;" TMGINFO("PRE-SET","ROOT",Filenum)=NameOfVariableHoldingSet. Var must have format:
48 ;" Varname(IEN)=""
49 ;" --------------------------
50 ;" TMGINFO("BYROOT")=1 (Optional) If 1, then TMGOUT is treated as a variable NAME (root)
51 ;" i.e. @TMGOUT@(FILENUM,IEN)=""
52 ;" --------------------------
53 ;" ...
54 ;" --DETAILS ON SEARCH CONDITION----
55 ;" TMGINFO(n,"FLD") -- The Fileman field name or number to seach in
56 ;" TMGINFO(n,"COND") -- The condition: "=,>,<,[,?,NULL" Prefix ' or - to negate
57 ;" TMGINFO(n,"VALUE") -- the value to search for
58 ;" *Alternative Syntax*
59 ;" TMGINFO(n)=Fld^Cond^Value If this is found, it will be used to fill in fields above.
60 ;" TMGOUT --An OUT PARAMETER. Fill with results of search. Prior values killed. Format:
61 ;" TMGOUT(FILENUM,IEN)=""
62 ;" TMGOUT(FILENUM,IEN)=""
63 ;" or @TMGOUT@(FILENUM,IEN)="" if BYROOT=1 (see above)
64 ;"Results: 1 if OK, or -1^Error Message
65 ;
66 NEW TMGSORTT SET TMGSORTT=0 ;"Will store IEN of SORT TEMPLATE used for output
67 NEW TMGRESULT SET TMGRESULT=$$PREPTMPL(.TMGINFO)
68 IF +TMGRESULT=-1 GOTO SRCHDN
69 NEW TMGBYROOT SET TMGBYROOT=+$GET(TMGINFO("BYROOT"))
70 IF TMGSORTT'>0 DO GOTO SRCHDN
71 . SET TMGRESULT="-1^Unable to prepair a SORT template for use."
72 IF +TMGRESULT=-1 GOTO SRCHDN
73 NEW TMGFILE SET TMGFILE=+$GET(TMGINFO("FILE"))
74 NEW ROOT
75 IF $DATA(TMGINFO("PRE-SET",TMGFILE)) DO
76 . SET ROOT=$GET(TMGINFO("PRE-SET","ROOT",TMGFILE)) QUIT:ROOT'=""
77 . SET ROOT=$NAME(TMGINFO("PRE-SET",TMGFILE))
78 ELSE DO
79 . SET ROOT=$GET(^DIC(TMGFILE,0,"GL"))
80 . IF ROOT="" SET TMGRESULT="-1^Unable to get global root for file '"_TMGFILE_"'"
81 . SET ROOT=$$CREF^DILF(ROOT)
82 NEW DIS
83 MERGE DIS=^DIBT(+TMGSORTT,"DIS")
84 IF $DATA(DIS(0))=0 DO GOTO SRCHDN
85 . SET TMGRESULT="-1^Unable to find screening code in SORT template"
86 NEW RSLTROOT
87 IF TMGBYROOT SET RSLTROOT=TMGOUT
88 ELSE SET RSLTROOT="TMGOUT"
89 KILL @RSLTROOT
90 NEW D0 SET D0=0 ;"D0 is IEN used in DIS code.
91 FOR SET D0=$ORDER(@ROOT@(D0)) QUIT:(+D0'>0) DO
92 . XECUTE DIS(0)
93 . IF $TEST SET @RSLTROOT@(TMGFILE,D0)=""
94SRCHDN IF TMGSORTT>0 DO
95 . IF TMGSORTT=$GET(TMGINFO("SORT IEN")) QUIT ;"Don't delete if specified by user
96 . ;"IF $$DELTEMPL^TMGDIS2(TMGSORTT)>0 QUIT
97 . ;"SET TMGRESULT="-1^Unable to delete SORT TEMPLATE #"_TMGSORTT
98 QUIT TMGRESULT
99 ;
100 ;
101PREPTMPL(TMGINFO)
102 ;"PURPOSE: Prepair a SORT TEMPLATE that will be used for doing the actual search.
103 ;" Note: This code used to extend into DIP* code where the actual search would be done.
104 ;" But it has been repurposed.
105 ;"Input: TMGINFO -- See documentation above.
106 ;"Output: TMGSORTT should be set to the IEN of the SORT TEMPLATE that contains the searching code.
107 ;"Results: 1 if OK, or -1^Message if error
108 ;
109 NEW DC ;"Variable DC stores coded search values
110 ;"Example:
111 ;"DC(1)="14,.01^=105" <-- field 14, sub field .01 '=' IEN 105 (in pointed to file)
112 ;"DC(2)="14,2^=44" <-- field 14, sub field 2 '=' IEN 44 (in pointed to file)
113 ;"
114 ;"Example
115 ;"DC(1)="14,-1^[""ACETA""" <-- field 14 is a multiple, '-' --> ? 1 is field '[' ACETA
116 ;"DC(2)="14,-2^[""%""" <-- field 14 is a multiple, '-' --> ? 2 is field '[' %
117 ;"
118 ;"Example
119 ;"DC=6
120 ;"DC(1) = 14,.01^=105 <-- field 14, sub field .01 '=' IEN 105 (in pointed to file)
121 ;"DC(2) = 14,-2^["%" <-- field 14 is a multiple, '-' --> ? 2 is field '[' %
122 ;" note field 2 is a pointer, so perhaps '-' means non-exact match
123 ;"DC(3) = 14,1^["1" <-- field 14 is a multiple, 1 is field '[' ACETA
124 ;" note field 1 is free text, so perhaps '-' not needed
125 ;"DC(4) = 1^=211 <-- field 1 '=' IEN 211
126 ;"DC(5) = .01^["A" <-- field .01 '[' A
127 ;"Values of O with above example
128 ;"O=0
129 ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN
130 ;"O(2) = VA PRODUCT UNITS CONTAINS "%"
131 ;"O(3) = VA PRODUCT STRENGTH CONTAINS "1"
132 ;"O(4) = DOSAGE FORM EQUALS 211^BAG
133 ;"O(5) = NAME CONTAINS "A"
134 NEW DIS,%ZIS
135 NEW O ;"('Oh', not 'zero') Stores file & field names and values to search FOR
136 ;"Example:
137 ;"O=0
138 ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "ACETAMINOPHEN"
139 ;"O(2) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "CAFF"
140 ;"O(3) = VA GENERIC NAME CONTAINS "A"
141 ;"Note:
142 ;" Each node (i.e. (1),(2) etc) contains a separate search item.
143 ;"
144 ;"Another example
145 ;"O="EQUALS"
146 ;"O(1)="VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN"
147 ;"O(2)="VA PRODUCT UNITS EQUALS 44^%"
148 ;"
149 ;"Note:
150 ;" In above examples,
151 ;" O(1) --> VA PRODUCT is file name, ACTIVE INGREDIENTS is .01 field
152 ;" of ACTIVE INGREDIENTS multiple
153 ;" 105 is IEN of ACETAMINOPHEN
154 ;" EQUALS is chosen comparator
155 ;" O(2)--> VA PRODUCT is file name, UNITS is field 2 of ACTIVE INGREDIENTS multiple
156 ;" 44 is IEN of unit '%'
157 ;" EQUALS is chosen comparator
158 ;" The value in O (e.g. 'EQUALS') is later killed, so not used in actual search.
159
160 NEW N,P,C,I,J,Q
161 NEW R ;"stores root of file being searched
162 NEW E ;"stores field type codes (piece 2 of 0 node)
163 NEW Z ;"pointers or SET data (piece 3 of 0 note)
164 NEW DIC,X,Y
165 NEW DL ;"DL=indent amount from left margin.
166 NEW DC ;"DC=search element i.e. 1=A,2=B,3=C etc.
167 NEW DU ;"DU = field number
168 NEW DA,DI,DV,DX,DY,DTOUT,DK
169 NEW DICMX,DICOMP
170 NEW TMGSAVX
171 NEW TMGRESULT SET TMGRESULT=1 ;"Default to success
172 SET DIC=1
173 SET X=+$GET(TMGINFO("FILE"))
174 DO ^DIC
175 IF Y=-1 DO GOTO PREPDN
176 . SET TMGRESULT="-1^File '"_X_"' is not valid."
177 SET DIC=+Y
178 set TMGINFO("FILE")=Y
179 NEW TMGFILE SET TMGFILE=Y
180 DO ;"Parse syntax of all in one line into separate fields
181 . NEW I SET I=0
182 . FOR SET I=$ORDER(INFO(I)) QUIT:(+I'>0)!(+TMGRESULT=-1) DO
183 . . NEW S SET S=$GET(INFO(I)) QUIT:S=""
184 . . NEW TEMPL SET TEMPL="FLD^COND^VALUE"
185 . . NEW J FOR J=1:1:3 DO
186 . . . NEW LABL SET LABL=$PIECE(TEMPL,"^",J)
187 . . . NEW F1 SET F1=$PIECE(S,"^",J)
188 . . . IF $DATA(INFO(I,LABL)),$GET(INFO(I,LABL))'=F1 DO QUIT
189 . . . . SET TMGRESULT="-1^Conflicting "_LABL_" information for term #"_I
190 . . . SET INFO(I,LABL)=F1
191 . . IF +TMGRESULT'=-1 SET INFO(I)=""
192 IF +TMGRESULT=-1 GOTO PREPDN
193EN ;
194 IF DIC SET DIC=$G(^DIC(DIC,0,"GL"))
195 IF DIC="" DO GOTO PREPDN
196 . SET TMGRESULT="-1^File '"_TMGFILE_"' is not valid."
197 KILL DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J)
198 IF '$DATA(@(DIC_"0)")) DO GOTO PREPDN
199 . SET TMGRESULT="-1^File '"_TMGFILE_"' is missing its global."
200 SET (R,DI,I(0))=DIC
201 SET DL=1 ;"DL=indent amount from left margin.
202 SET DC=1 ;"DC=search element i.e. 1=A,2=B,3=C etc.
203 SET DY=999
204 SET N=0
205 SET Q=""""
206 SET DV=""
207R ;
208 ;"SET J(N) and DK<--file NUMBER, R<--file NAME
209 IF +R=R DO
210 . SET (J(N),DK)=R
211 . SET R=""
212 ELSE DO
213 . SET @("(J(N),DK)=+$PIECE("_R_"0),U,2)")
214 . SET R=$PIECE(^(0),U)
215 ;
216F ;=== Get next field===
217 IF DC>58 GOTO UP
218 KILL X,DIC,P ;"Note: newer version of code renames P to DISPOINT
219 SET DIC(0)="Z" ;"WAS EZ
220 SET C=","
221 SET DIC="^DD("_DK_C
222 SET DIC("W")=""
223 SET DIC("S")="IF $PIECE(^(0),U,2)'[""m"""_$SELECT($DATA(DICS):" "_DICS,1:""),DU=""
224 SET X=$GET(TMGINFO(DC,"FLD"))
225 IF X="" GOTO UP
226 ;"IF X?1"[".E GOTO TEM ;"I think this is for putting all on one line. REMOVED because it is user-interactive
227 SET TMGSAVX=X
228 DO ^DIC ;"search FOR field, based on user input.
229 IF Y=-1 SET X=TMGSAVX
230 IF Y'>0 GOTO COMP
231 KILL P
232 SET DE=Y(0)
233 SET O(DC)=$PIECE(DE,U) ;"Store first part of search term
234 SET DU=+Y ;"DU = field number
235 SET Z=$PIECE(DE,U,3) ;"pointers or SET data
236 SET E=$PIECE(DE,U,2) ;"field info codes, poss with subfile #
237G ;==== Get Condition =========
238 KILL X,DIC
239 SET DIC="^DOPT(""DIS""," ;"file containing "equals","contains","greater than" etc.
240 SET DIC(0)="Z" ;"Was QEZ
241 IF E["B" SET X="" GOTO OK ;"'B'->field is a BOOLEAN COMPUTED field, so skip
242 IF +E=0 GOTO G2 ;"E=file info code starts with # IF subfile. So skip IF not subfile
243 SET N(DL)=N
244 SET N=N+1
245 SET DV(DL)=DV
246 SET DL(DL)=DK
247 SET DK=+E
248 SET J(N)=DK
249 SET X=$PIECE($PIECE(DE,U,4),";") ;"4th piece of 0 node holds storage location
250 SET I(N)=$SELECT(+X=X:X,1:""""_X_"""")
251 SET Y(0)=^DD(DK,.01,0)
252 SET DL=DL+1 ;"indent further
253 IF $PIECE(Y(0),U,2)["W" DO GOTO C ;"was goto WP
254 . SET DIC("S")="IF Y<3"
255 . SET DU=+Y_"W"
256 SET DV=DV_+Y_","
257 GOTO F ;"loop back to get more field info for subfile FIX!!! How is this pre-determined??
258 ;
259G2 SET X=$PIECE(E,"P",2)
260 IF X,$DATA(^DIC(+X,0,"GL")) DO
261 . ;Y will be FIELD lookup, unless it's COMPUTED EXPRESSION from ^DIS2
262 . SET P=$SELECT(Y:+Y,1:-DC)_U_U_^("GL")
263 IF E["P" DO
264 . SET P=+Y_U_Y(0) ;"e.g. P=.02^PATIENT^P9000001'
265 . SET X=+$PIECE(E,"P",2)
266 . FOR QUIT:'X DO
267 . . SET DA=$PIECE($G(^DD(X,.01,0)),U,2)
268 . . IF DA["D" DO QUIT
269 . . . SET E="D"_E
270 . . . SET X=""
271 . . SET X=+$P(DA,"P",2)
272 IF $DATA(P),Y>0 DO
273 . SET X="(#"_+Y_")"
274 . NEW SAVX SET SAVX=X
275 . SET DA="DIS("""_$C(DC+64)_DL_""","
276 . SET DICOMP=N
277 . SET:$DATA(O(DC))[0 O(DC)=X
278 . DO EN^DICOMP
279 . IF $GET(X)="" DO QUIT
280 . . SET TMGRESULT="-1^Unable to process '"_SAVX
281 . SET DA(DC)=X
282 . SET DU=-DC
283 . FOR %=0:0 SET %=$ORDER(X(%)) Q:'% SET @(DA_%_")")=X(%)
284 IF +TMGRESULT=-1 GOTO PREPDN
285 ;
286C SET X=$GET(TMGINFO(DC,"COND")) ;"Get pre-defined user search condition
287 IF X="" DO GOTO PREPDN
288 . SET TMGRESULT="-1^Search condition not specified for term #"_DC
289 SET DN=$SELECT("'-"[$E(X):"'",1:"") ;"IF NOT is specified then DN="'"
290 SET X=$E(X,DN]""+1,99) ;"remove 'NOT' symbol, IF present
291 DO ^DIC
292 IF Y=-1 DO GOTO PREPDN
293 . SET TMGRESULT="-1^Search condition '"_X_"' is not valid."
294C2 SET O=$PIECE("NOT ",U,DN]"")_$PIECE(Y,U,2) ;"Store search condition in O
295 IF +Y=1 DO GOTO OK ;"Handle NULL selected
296 . SET X=DN_"?."" """
297 . SET O(DC)=O(DC)_" "_O
298 SET DQ=Y
299 ;"At this point DQ should be one of following values:
300 ;"1 for NULL, 2 for CONTAINS 3 for matches
301 ;"4 for LESS THAN 5 for EQUALS 6 for GREATER THAN
302 ;
303 ;"====Get Search Term=================
304 SET X=$GET(INFO(DC,"VALUE"))
305 IF X="" DO GOTO PREPDN
306 . SET TMGRESULT="-1^No search value specified for term #"_DC
307 ;
308DT ;"--Handle searches for DATES--
309 IF (E'["D")!(DQ<4) GOTO PT
310 SET %DT="T" ;"was TE
311 DO ^%DT
312 IF Y<0 DO GOTO PREPDN
313 . SET TMGRESULT="-1^Invalid date value '"_X
314 SET X=Y_U_X
315 XECUTE ^DD("DD")
316 SET Y=X_U_Y
317 GOTO GOT
318 ;
319PT ;"--POINTERS--
320 IF ($DATA(P)=0)!(+DQ'=5) GOTO PT2
321 ;"--Handle Pointer field EQUALS X value--
322 KILL DIC,DIS($char(DC+64)_DL)
323 SET DIC=U_$PIECE(P,U,4)
324 SET DIC(0)="M" ;"was EMQ
325 SET DU=+P
326 DO ^DIC
327 IF Y'>0 DO GOTO PREPDN
328 . SET TMGRESULT="-1^Search value '"_X_"' not found for search term #"_DC
329 GOTO GOT
330 ;
331PT2 SET Y=X
332 ;Line below allows looking for "^" in WP or $E-stored actual data
333 IF (Y[U),($PIECE(DE,U,4)'[";E"),('$P($G(DE),U,2)),(E'["C") DO GOTO PREPDN
334 . SET TMGRESULT="-1^Search value '"_Y_"' should not contain '^'"
335 IF +DQ'=3 GOTO PT3
336 SET X="I X?"_Y
337 SET TMGSAVX=X
338 DO ^DIM
339 IF $DATA(X)=0 DO GOTO PREPDN
340 . SET TMGRESULT="-1^Bad match expression: '"_TMGSAVX_"'"
341 GOTO GOT
342 ;
343PT3 IF (DQ=4)!(DQ=6),(+Y'=Y) DO GOTO PREPDN ;> or < have to be numeric
344 . SET TMGRESULT="-1^Search value '"_Y_"' must be numeric to use comparator '"_O_"'"
345 IF Y?."?" DO GOTO PREPDN
346 . SET TMGRESULT="-1^Bad search value '"_Y_"'"
347 ;
348SET ;"--Handle set-type fields----
349 IF E'["S" GOTO OTHR
350 SET TMGSAVX=X
351 DO
352 . NEW D
353 . SET X=1
354 . IF (+DQ=5)!(Y["""") DO KILL:(D="") X QUIT
355 . . NEW DIR,DDER
356 . . SET X=Y
357 . . SET DIR(0)="S^"_Z
358 . . SET DIR("V")=1
359 . . DO ^DIR
360 . . IF $G(DDER) DO QUIT
361 . . . SET D=""
362 . . . SET TMGRESULT="-1^Error choosing '"_X_"' in set '"_Z_"'"
363 . . NEW DONE SET DONE=0
364 . . FOR X=1:1 DO QUIT:(D="")!DONE
365 . . . SET D=$PIECE(Z,";",X) QUIT:D=""
366 . . . IF Y=$PIECE(D,":") DO
367 . . . . SET Y=""""_$$CONVQQ^DILIBF($P(D,":"))_"""^"_$P(D,":",2)
368 . . . . SET DONE=1
369 . NEW N,FND,C
370 . SET Y=""""_Y_""""
371 . SET N="DE"_DN_$E(" [?<=>",DQ)_Y
372 . FOR X=1:1 DO QUIT:(D="")
373 . . SET D=$PIECE(Z,";",X)
374 . . SET DE=$PIECE(D,":",2)
375 . . IF D="" QUIT
376 . . SET DIS(U,DC,$P(D,":"))=DE
377 . . NEW MATCH SET MATCH=0
378 . . IF @N SET MATCH=1 ;"Note: IF '(@N) QUIT <-- won't work
379 . . IF 'MATCH QUIT
380 . . SET FND="'"_DE_"'"
381 . IF $D(FND)=0 KILL X QUIT
382 IF +TMGRESULT=-1 GOTO PREPDN
383 KILL DIS("XFORM",DC)
384 IF $DATA(X)=0 DO GOTO PREPDN
385 . KILL DIS(U,DC)
386 . SET TMGRESULT="-1^Search value '"_TMGSAVX_"' is invalid for SET type field."
387 GOTO GOT
388 ;
389OTHR IF Y?.E2A.E DO
390 . SET DIS("XFORM",DC)="$$UP^DILIBF(;)"
391 . SET Y=$$UP^DILIBF(Y)
392 DO
393 . N P,YY,C
394 . SET C=""""
395 . SET YY=C_$$CONVQQ^DILIBF($P(Y,U))
396 . FOR P=2:1:$L(Y,U) DO
397 . . SET YY="("_YY_"""_$C(94)_"""_$$CONVQQ^DILIBF($P(Y,U,P)),C=C_")"
398 . SET Y=YY_C
399 ;
400 ;===============================================
401GOT ;"At this point, Y should be search value
402 SET X=DN_$EXTRACT(" [?<=>",DQ)_$P(Y,U)
403 IF E["D" DO
404 . IF ($PIECE(Y,U)'["."),$E(Y,6,7) DO
405 . . SET %=$PIECE("^^^^ any time during^ the entire day",U,DQ)
406 . . IF %']"" QUIT
407 . . SET DIS("XFORM",DC)="$P(;,""."")"
408 . . SET O=O_%
409 . SET Y=$P(Y,U,3)_U_$P(Y,U,2)
410 IF $GET(DIS("XFORM",DC))="$$UP^DILIBF(;)" SET O=O_" (case-insensitive)"
411 SET O(DC)=O(DC)_" "_O_" "_Y
412 ;
413OK SET DC(DC)=DV_DU_U_X
414 SET %=DL-1_U_(N#100)
415 IF DL>1,O(DC)'[R SET O(DC)=R_" "_O(DC)
416 IF DU["W" SET %=DL-2_U_(N#100-1)
417 SET DX(DC)=%
418 SET DC=DC+1 ;"Incr logical part (i.e. 'A'->'B'->'C'->D)
419 IF DC=27 SET DC=33
420B GOTO F:(DU'["W"&(DC<59))
421 ;
422 ;"==============
423UP IF (DC'>1)!(DL'<2) GOTO U2
424 ;"Done with entering conditions. Continue processing in ^TMGDIS0
425 DO DIS0^TMGDIS0(.TMGINFO,.TMGOUT,.TMGBYROOT) ;"Sets TMGRESULT
426 GOTO PREPDN
427 ;
428U2 SET DL=DL-1
429 SET DV=DV(DL)
430 SET DK=DL(DL)
431 SET N=N(DL)
432 SET R=$SELECT($DATA(R(DL)):R(DL),1:R)
433 KILL R(DL)
434 SET %=N
435 FOR DO IF %<0 GOTO F ;"go back and get more field information.
436 . SET %=$ORDER(I(%))
437 . IF %="" SET %=-1
438 . IF %<0 QUIT
439 . KILL I(%),J(%)
440Q2 IF '$D(DIARU) GOTO PREPDN
441 . SET TMGRESULT="-1^No search terms found"
442 ;"GOTO DIS2^TMGDIS2
443 SET TMGRESULT=$$DIS2^TMGDIS2
444 ;
445 ;"==========================================
446PREPDN ;"Purpose: New common exit point for function
447 DO Q ;"kill vars
448 QUIT TMGRESULT
449 ;
450 ;
451 ;--Code below from TMGDIS2----
452 ;"==========================================
453 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS;4JUN2005
454 ;;22.0;VA FileMan;**6,144**;Mar 30, 1999;Build 5
455 ;"==========================================
456 ;
457COMP SET E=X ;"e.g. X="(#.02)"
458 SET DICMX="X DIS(DIXX)"
459 SET DICOMP=N_"?"
460 SET DQI="Y("
461 SET DA="DIS("""_$C(DC+64)_DL_""","
462 IF $D(O(DC))[0
463 SET O(DC)=X
464 IF X?.E1":" DO COLON GOTO R
465 IF (X?.E1":.01"),($D(O(DC))[0) SET O(DC)=$E(X,1,$L(X)-4)
466 DO EN^DICOMP ;"Eval computed expression. Output in X
467 DO XA
468 IF $GET(X)="" DO GOTO PREPDN^TMGDIS
469 . SET TMGRESULT="-1^Unable to evaluate computed expression '"_E_"'"
470 IF Y["m" DO GOTO PREPDN^TMGDIS
471 . SET TMGRESULT="-1^Found unexpected 'm' in '"_Y_"'"
472 ;"GOTO X:'$D(X)
473 ;"GOTO X:Y["m" ;IF Y["m" SET X=E_":" G COMP
474 SET DA(DC)=X
475 SET DU=-DC
476 SET E=$E("B",Y["B")_$E("D",Y["D")
477 IF Y["p" SET E="p"_+$P(Y,"p",2)
478 GOTO G
479 ;
480COLON ; NOTE: code reached only by DO call
481 DO ^DICOMPW
482 DO XA ;"Setup DIS array
483 IF $GET(X)="" DO GOTO PREPDN^TMGDIS
484 . SET TMGRESULT="-1^Unable to evaluate computed expression '"_E_"'"
485 ;"G X:'$D(X)
486 SET R(DL)=R
487 SET N(DL)=N
488 SET N=+Y
489 SET DY=DY+1
490 SET DV(DL)=DV
491 SET DL(DL)=DK
492 SET DL=DL+1
493 SET DV=DV_-DY_C
494 SET DY(DY)=DP_U_$S(Y["m":DC_"."_DL,1:"")_U_X
495 SET R=U_$P(DP,U,2)
496 KILL X
497 QUIT
498 ;
499 ;"==========================================
500XA SET %=0
501 FOR DO Q:%=""
502 . SET %=$O(X(%))
503 . Q:%=""
504 . SET @(DA_%_")")=X(%)
505 SET %=-1
506 QUIT
507 ;
508Q ;
509 KILL DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV
510 KILL E,DE,DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT,^UTILITY($J)
511 QUIT
512
513TEM ;"Note: code execution reached here by GOTO
514 ;"Note: This code is user-interactive, so will not be used.
515 KILL DIC
516 SET X=$P($E(X,2,99),"]",1)
517 SET DIC="^DIBT("
518 SET DIC(0)="EQ"
519 DO
520 . NEW S SET S=$S($D(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")
521 . SET DIC("S")="I "_S_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
522 . SET DIC("W")="X ""FOR %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0)) "
523 . SET DIC("W")=DIC("W")_"WRITE !?9 SET I=^(0) W:$L(I)+$X>79 !?9 WRITE I"""
524 DO ^DIC
525 KILL DIC
526 IF Y<0 GOTO F
527 SET P="DIS"
528 SET Z=-1,%X="^DIBT(+Y,P,",%Y="DIS(" D %XY^%RCR
529 SET %Y="^UTILITY($J,",P="O" D %XY^%RCR
530 SET TMGRESULT=$$DIS2^TMGDIS2() ;"G DIS2^TMGDIS2
531 GOTO PREPDN
Note: See TracBrowser for help on using the repository browser.