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

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

Initial upload
File size: 18.8 KB
Line 
1TMGDIS ;TMG/kst/Custom version of DIS ;03/25/06 ; 5/12/10 3:06pm
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 ;"
7 ;"Purpose: to GATHER SEARCH CRITERIA
8 ;"------Also includes code from DIS2, with header as below.
9 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS ;5:49 AM 2 Jun 1999
10 ;;22.0;VA FileMan;**6**;Mar 30, 1999
11 ;
12 ;"Purpose: SEARCH, TEMPLATES & COMPUTED FIELDS
13 ;"Note: Program execution can loop all the way back to ^DIS
14 ;"
15SRCH(TMGINFO,TMGOUT,TMGBYROOT) ;
16 ;"Purpose: Provide an API interface for the classic Fileman console search
17 ;"Input: TMGINFO -- PASS BY REFERENCE. This is pre-defined search terms. Format:
18 ;" TMGINFO("FILE") -- File name or number to be used for search
19 ;" TMGINFO(1,...) -- Search condition 1 (corresponds to 'A' in console)
20 ;" TMGINFO(2,...) -- Search condition 2 (corresponds to 'B' in console)
21 ;" ...
22 ;" --DETAILS ON SEARCH CONDITION----
23 ;" TMGINFO(n,"FLD") -- The Fileman field name or number to seach in
24 ;" TMGINFO(n,"COND") -- The condition: "=,>,<,[,?,NULL" Prefix ' or - to negate
25 ;" TMGINFO(n,"VALUE") -- the value to search for
26 ;" TMGOUT --An OUT PARAMETER. Prior values killed. Format:
27 ;" TMGOUT(FILENUM,IEN)=""
28 ;" TMGOUT(FILENUM,IEN)=""
29 ;" TMGOUT(FILENUM,IEN)=""
30 ;" TMGBYROOT -- (Optional) If 1, then TMGOUT is treated as a variable NAME (root)
31 ;" i.e. @TMGOUT@(FILENUM,IEN)=""
32 ;"Results: 1 if OK, or -1^Error Message
33 ;
34 NEW DC ;"Variable DC stores coded search values
35 ;"Example:
36 ;"DC(1)="14,.01^=105" <-- field 14, sub field .01 '=' IEN 105 (in pointed to file)
37 ;"DC(2)="14,2^=44" <-- field 14, sub field 2 '=' IEN 44 (in pointed to file)
38 ;"
39 ;"Example
40 ;"DC(1)="14,-1^[""ACETA""" <-- field 14 is a multiple, '-' --> ? 1 is field '[' ACETA
41 ;"DC(2)="14,-2^[""%""" <-- field 14 is a multiple, '-' --> ? 2 is field '[' %
42 ;"
43 ;"Example
44 ;"DC=6
45 ;"DC(1) = 14,.01^=105 <-- field 14, sub field .01 '=' IEN 105 (in pointed to file)
46 ;"DC(2) = 14,-2^["%" <-- field 14 is a multiple, '-' --> ? 2 is field '[' %
47 ;" note field 2 is a pointer, so perhaps '-' means non-exact match
48 ;"DC(3) = 14,1^["1" <-- field 14 is a multiple, 1 is field '[' ACETA
49 ;" note field 1 is free text, so perhaps '-' not needed
50 ;"DC(4) = 1^=211 <-- field 1 '=' IEN 211
51 ;"DC(5) = .01^["A" <-- field .01 '[' A
52 ;"Values of O with above example
53 ;"O=0
54 ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN
55 ;"O(2) = VA PRODUCT UNITS CONTAINS "%"
56 ;"O(3) = VA PRODUCT STRENGTH CONTAINS "1"
57 ;"O(4) = DOSAGE FORM EQUALS 211^BAG
58 ;"O(5) = NAME CONTAINS "A"
59 NEW DIS,%ZIS
60 NEW O ;"('Oh', not 'zero') Stores file & field names and values to search FOR
61 ;"Example:
62 ;"O=0
63 ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "ACETAMINOPHEN"
64 ;"O(2) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "CAFF"
65 ;"O(3) = VA GENERIC NAME CONTAINS "A"
66 ;"Note:
67 ;" Each node (i.e. (1),(2) etc) contains a separate search item.
68 ;"
69 ;"Another example
70 ;"O="EQUALS"
71 ;"O(1)="VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN"
72 ;"O(2)="VA PRODUCT UNITS EQUALS 44^%"
73 ;"
74 ;"Note:
75 ;" In above examples,
76 ;" O(1) --> VA PRODUCT is file name, ACTIVE INGREDIENTS is .01 field
77 ;" of ACTIVE INGREDIENTS multiple
78 ;" 105 is IEN of ACETAMINOPHEN
79 ;" EQUALS is chosen comparator
80 ;" O(2)--> VA PRODUCT is file name, UNITS is field 2 of ACTIVE INGREDIENTS multiple
81 ;" 44 is IEN of unit '%'
82 ;" EQUALS is chosen comparator
83 ;" The value in O (e.g. 'EQUALS') is later killed, so not used in actual search.
84
85 NEW N,P,C,Z,I,J,Q
86 NEW R ;"stores root of file being searched
87 NEW E ;"stores field type codes (piece 2 of 0 node)
88 NEW DIC,X,Y
89 NEW DL ;"DL=indent amount from left margin.
90 NEW DC ;"DC=search element i.e. 1=A,2=B,3=C etc.
91 NEW DU ;"DU = field number
92 NEW DA,DI,DV,DX,DY,DTOUT,DK
93 NEW DICMX,DICOMP
94 NEW TMGRESULT SET TMGRESULT=1 ;"Default to success
95 SET DIC=1
96 SET X=$GET(TMGINFO("FILE"))
97 DO ^DIC
98 IF Y=-1 DO GOTO SRCHDN
99 . SET TMGRESULT="-1^File '"_X_"' is not valid."
100 SET DIC=+Y
101 NEW TMGFILE SET TMGFILE=$P(Y,U,2)
102EN ;
103 IF DIC SET DIC=$G(^DIC(DIC,0,"GL"))
104 IF DIC="" DO GOTO SRCHDN
105 . SET TMGRESULT="-1^File '"_TMGFILE_"' is not valid."
106 KILL DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J)
107 IF '$DATA(@(DIC_"0)")) DO GOTO SRCHDN
108 . SET TMGRESULT="-1^File '"_TMGFILE_"' is missing its global."
109 SET (R,DI,I(0))=DIC
110 SET DL=1 ;"DL=indent amount from left margin.
111 SET DC=1 ;"DC=search element i.e. 1=A,2=B,3=C etc.
112 SET DY=999
113 SET N=0
114 SET Q=""""
115 SET DV=""
116R ;
117 ;"SET J(N) and DK<--file NUMBER, R<--file NAME
118 IF +R=R DO
119 . SET (J(N),DK)=R
120 . SET R=""
121 ELSE DO
122 . SET @("(J(N),DK)=+$PIECE("_R_"0),U,2)")
123 . SET R=$PIECE(^(0),U)
124 ;
125F ;=== Get next field===
126 IF DC>58 GOTO UP
127 ;"WRITE !
128 KILL X,DIC,P
129 ;"DO W ;"Write label to screen line -A-, or -B- etc.
130 SET DIC(0)="Z" ;"WAS EZ
131 SET C=","
132 SET DIC="^DD("_DK_C
133 ;"SET DIC("W")="SET %=$PIECE(^(0),U,2) WRITE:% $SELECT($PIECE(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")"
134 SET DIC("S")="IF $PIECE(^(0),U,2)'[""m"""_$select($DATA(DICS):" "_DICS,1:""),DU=""
135 ;"WRITE "SEARCH FOR "_R_" "_$PIECE(^DD(DK,0),U)_": "
136 ;"READ X:DTIME ;"ask user FOR filed to search in, from specified file
137 ;"SET:'$T DTOUT=1
138 ;"IF X=U!'$T GOTO Q
139 SET X=$GET(TMGINFO(DC,"FLD"))
140 ;"IF X?1"[".E GOTO TEM ;"I think this is for putting all on one line. REMOVED.
141 DO
142 . NEW DISVX SET DISVX=X
143 . DO ^DIC ;"search FOR field, based on user input.
144 . IF Y=-1 SET X=DISVX
145 IF '(Y>0) GOTO HARD ;"Time to do the hard part...
146 KILL P
147 SET DE=Y(0)
148 SET O(DC)=$PIECE(DE,U) ;"Store first part of search term
149 SET DU=+Y ;"DU = field number
150 SET Z=$PIECE(DE,U,3) ;"pointers or SET data
151 SET E=$PIECE(DE,U,2) ;"field info codes, poss with subfile #
152G ;==== Get Condition =========
153 KILL X,DIC
154 SET DIC="^DOPT(""DIS""," ;"file containing "equals","contains","greater than" etc.
155 SET DIC(0)="Z" ;"Was QEZ
156 IF E["B" SET X="" GOTO OK ;"'B'->field is a BOOLEAN COMPUTED field, so skip
157 IF +E=0 GOTO G2KT ;"E=file info code starts with # IF subfile. So skip IF not subfile
158 SET N(DL)=N
159 SET N=N+1
160 SET DV(DL)=DV
161 SET DL(DL)=DK
162 SET DK=+E
163 SET J(N)=DK
164 SET X=$PIECE($PIECE(DE,U,4),";") ;"4th piece of 0 node holds storage location
165 SET I(N)=$select(+X=X:X,1:""""_X_"""")
166 SET Y(0)=^DD(DK,.01,0)
167 SET DL=DL+1 ;"indent further
168 IF $PIECE(Y(0),U,2)["W" GOTO WP ;"Process WP fields
169 SET DV=DV_+Y_","
170 GOTO F ;"loop back to get more field info for subfile FIX!!! How is this pre-determined??
171G2KT IF E["P" DO GOTO HARD ;"IF field points to another file, setup and GOTO HARD
172 . SET P=+Y_U_Y(0) ;"e.g. P=.02^PATIENT^P9000001'
173 . SET X="(#"_+Y_")"
174C ;"DO W ;"Write label to screen line -A-, or -B- etc.
175 ;"READ "CONDITION: ",X:DTIME
176 ;"SET:'$T DTOUT=1
177 ;"IF X[U!'$T GOTO Q
178 SET X=$GET(TMGINFO(DC,"COND")) ;"Get pre-defined user search condition
179 IF X="" DO GOTO SRCHDN
180 . SET TMGRESULT="-1^Search condition not specified for term #"_DC
181 SET DN=$select("'-"[$E(X):"'",1:"") ;"IF NOT is specified then DN="'"
182 SET X=$E(X,DN]""+1,99) ;"remove 'NOT' symbol, IF present
183 DO ^DIC
184 ;"IF Y>0 GOTO C2
185 ;"IF X[U GOTO Q
186 ;"IF X="" GOTO B
187 ;"IF X["?" GOTO DISCDIQQQ
188 ;"GOTO C
189 IF Y=-1 DO GOTO SRCHDN
190 . SET TMGRESULT="-1^Search condition '"_X_"' is not valid."
191C2 SET O=$PIECE("NOT ",U,DN]"")_$PIECE(Y,U,2) ;"Store search condition in O
192 IF +Y=1 DO GOTO OK ;"Handle NULL selected
193 . SET X=DN_"?."" """
194 . SET O(DC)=O(DC)_" "_O
195 SET DQ=Y
196 ;"At this point DQ (and Y) should be one of following values:
197 ;"1 for NULL, 2 for CONTAINS 3 for matches
198 ;"4 for LESS THAN 5 for EQUALS 6 for GREATER THAN
199 ;
200 ;"====Get Search Term=================
201 ;"DO W ;"Write label to screen line -A-, or -B- etc.
202 ;"WRITE O
203 IF (E'["D")!(Y<4) GOTO PT
204 ;"Handle searches for DATES
205 ;"READ " DATE: ",X:DTIME
206 SET X=$GET(INFO(DC,"VALUE"))
207 ;"SET:'$T DTOUT=1
208 ;"IF X=U!'$T GOTO Q
209 IF X="" DO GOTO SRCHDN
210 . SET TMGRESULT="-1^No search value specified for term #"_DC
211 SET %DT="T" ;"was TE
212 DO ^%DT
213 IF Y<0 DO GOTO SRCHDN
214 . SET TMGRESULT="-1^Invalid date value '"_X
215 SET X=Y_U_X
216 XECUTE ^DD("DD")
217 SET Y=X_U_Y
218 GOTO GOT
219PT ;"POINTERS
220 IF $DATA(P),+DQ=5 DO GOTO Q:U[X!'$T DO ^DIC GOTO GOT:Y>0,PT
221 . KILL DIC,DIS($char(DC+64)_DL)
222 . SET DIC=U_$PIECE(P,U,4)
223 . SET DIC(0)="EMQ"
224 . SET DU=+P
225 . WRITE " "_$PIECE(@(DIC_"0)"),U)_": "
226 . READ X:DTIME
227 . SET:'$T DTOUT=1
228 READ ": ",Y:DTIME
229 IF '$T SET DTOUT=1 GOTO Q
230 GOTO X:Y=""
231 IF Y[U,$PIECE(DE,U,4)'[";E" GOTO Q
232 IF +DQ=3 SET X="I X?"_Y DO ^DIM GOTO GOT:$DATA(X) SET Y="?"
233 GOTO DISDIQQQ:Y?."?"
234SET IF E["S" DO IF '$DATA(X) KILL DIS(U,DC) GOTO DISDIQQQ
235 . IF +DQ=5!(Y["""") DO kill:D="" X QUIT
236 . . SET Y=":"_Y
237 . . NEW TMGQUIT SET TMGQUIT=0
238 . . ;"FOR X=1:1 DO IF D[Y WRITE $PIECE(D,Y,2,9) SET Y=$PIECE(D,":")_U_$PIECE(D,":",2) Q
239 . . FOR X=1:1 DO QUIT:TMGQUIT=1
240 . . . SET D=$PIECE(Z,";",X)
241 . . . IF D="" SET TMGQUIT=1 QUIT
242 . . . IF D[Y DO
243 . . . . WRITE $PIECE(D,Y,2,9)
244 . . . . SET Y=$PIECE(D,":")_U_$PIECE(D,":",2)
245 . . . . SET TMGQUIT=1
246N . NEW N,%,C
247 . WRITE !?7
248 . SET N="DE"_DN_$E(" [?<=>",DQ)_""""_Y_""""
249 . NEW TMGQUIT SET TMGQUIT=0
250 . FOR X=1:1 DO QUIT:TMGQUIT=1
251 . . SET D=$PIECE(Z,";",X)
252 . . SET DE=$PIECE(D,":",2)
253 . . IF D="" SET TMGQUIT=1
254 . . SET DIS(U,DC,$PIECE(D,":"))=DE
255 . . IF @N DO
256 . . . SET:'$DATA(%) %="[ Will match"
257 . . . WRITE %
258 . . . SET C=$G(C)+1
259 . . . SET %="'"_DE_"'"
260 . . . write:C>1 ","
261 . . . WRITE " "
262 . . . write:$X+$L(%)>73 !?7
263 . IF '$DATA(%) KILL X Q
264 . write:C>1 "and "
265 . WRITE %_" ]"
266T IF DQ["THAN",+$PIECE(Y,U)'=$PIECE(Y,U) GOTO X
267QUOTE IF DQ#3=2 DO ;"Equals or Contains
268 . write:$PIECE(Y,U)[""""&($L($PIECE(Y,U))>1) " (Your answer includes quotes)"
269 . SET $PIECE(Y,U)=""""_$$CONVQQ^DILIBF($PIECE(Y,U))_""""
270 . IF $PIECE(Y,U)?.E2A.E DO
271 . . SET DIS("XFORM",DC)="$$UP^DILIBF(;)"
272 . . SET O=O_" (case-insensitive)"
273 . . SET $PIECE(Y,U)=$$UP^DILIBF($PIECE(Y,U))
274GOT ;"At this point, Y should be search value
275 SET X=DN_$E(" [?<=>",DQ)_$PIECE(Y,U)
276 IF E["D" DO
277 . SET Y=$PIECE(Y,U,3)_U_$PIECE(Y,U,2)
278 . IF $PIECE(Y,U)'["." DO
279 . . SET %=$PIECE("^^^^ any time during^ the entire day",U,DQ)
280 . . IF %]"" DO
281 . . . SET DIS("XFORM",DC)="$PIECE(;,""."")"
282 . . . SET O=O_%
283 SET O(DC)=O(DC)_" "_O_" "_Y
284OK SET DC(DC)=DV_DU_U_X
285 SET %=DL-1_U_(N#100)
286 IF DL>1,O(DC)'[R SET O(DC)=R_" "_O(DC)
287 IF DU["W" SET %=DL-2_U_(N#100-1)
288 SET DX(DC)=%
289 SET DC=DC+1 ;"Inc logical part (i.e. 'A'->'B'->'C'->D)
290 IF DC=27 SET DC=33
291B GOTO F:(DU'["W"&(DC<59))
292
293 ;"==============
294UP IF '(DC>1) GOTO Q
295 IF DL<$select('$DATA(DIARF0):2,1:2) GOTO ^TMGDIS0 ;"Done with entering conditions
296 SET DL=DL-1
297 SET DV=DV(DL)
298 SET DK=DL(DL)
299 SET N=N(DL)
300 SET R=$select($DATA(R(DL)):R(DL),1:R)
301 KILL R(DL)
302 SET %=N
303 FOR SET %=$O(I(%)) SET:%="" %=-1 GOTO F:%<0 KILL I(%),J(%)
304 FOR DO IF %<0 GOTO F
305 . SET %=$O(I(%))
306 . IF %="" SET %=-1
307 . IF %<0 QUIT
308 . KILL I(%),J(%)
309 ;"==========================================
310 ;"Q IF '$DATA(DIARU) GOTO Q^TMGDIS2
311 ;" GOTO ^TMGDIS2
312
313 ;"==========================================
314HARD IF X="" GOTO UP
315 ;"IF X?."?" GOTO F
316 ;"IF X=U!($DATA(DTOUT)) GOTO Q
317 GOTO COMP
318
319 ;"==========================================
320WP SET DIC("S")="IF Y<3"
321 SET DU=+Y_"W"
322 GOTO C
323
324 ;"==========================================
325X ;
326 WRITE $char(7),"??",!!
327 GOTO B
328
329 ;"==========================================
330W WRITE !?DL*2,"-"_$char(DC+64)_"- "
331 QUIT
332
333 ;"==========================================
334ENS ;" ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE
335 GOTO EN^DIS3
336
337
338
339 ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS.
340DISDIQQQ ;
341 WRITE !?8,"ENTER A VALUE WHICH '"_O(DC)_"'"
342 WRITE !?8,"MUST "_$P("NOT ",U,DN]"")
343 WRITE $PIECE("^CONTAIN^MATCH^BE LESS THAN^EQUAL^EXCEED^FOLLOW",U,+DQ)
344 WRITE ", IN ORDER FOR TRUTH CONDITION -"_$char(DC+64)_"- TO BE TRUE",!
345 write:+DQ=3 ?8,"(I.E., ENTER WHAT WOULD FOLLOW THE MUMPS '?' OPERATOR)",!
346 IF E["S" WRITE !,"Use EXTERNAL VALUE (from list on the right)" D EN^DIQQ1(DK,DU,"?")
347 WRITE !
348 GOTO F
349
350 ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS
351 ;"DISCDIQQ ;
352 ;"WRITE !,"YOU CAN NEGATE ANY OF THESE CONDITIONS BY PRECEDING THEM WITH ""'"" OR ""-"""
353 ;"WRITE !,"SO THAT ""'NULL'"" MEANS ""NOT NULL""",!
354 ;"GOTO C
355 ;
356
357SRCHDN ;
358 ;"Purpose: New common exit point for function
359 QUIT TMGRESULT
360
361
362 ;===========================================================================
363 ;===========================================================================
364 ;" Below was code from DIS2
365 ;===========================================================================
366 ;===========================================================================
367
368DIS2 KILL DISV
369 GOTO G3:'DUZ
3700 DO
371 . NEW DIS,DIS0,DA,DC,DE,DJ,DL
372 . DO S3^DIBT1
373 . Q
374 KILL DIRUT,DIROUT
375 IF $D(DTOUT)!($D(DUOUT)) GOTO Q
376 IF X="" GOTO G3:'$D(DIAR)
377 IF Y<0 GOTO Q:X=U,0
378 IF $D(DIARU),DIARU-Y=0 DO GOTO 0
379 . write $C(7),!,"Archivers must not store results in the default template"
380 SET (DIARI,DISV)=+Y
381 SET A=$D(^DIBT(DISV,"DL"))
382 SET:$D(DIS0)#2 ^("DL")=DIS0
383 SET:$D(DA)#2 ^("DA")=DA
384 SET:$D(DJ)#2 ^("DJ")=DJ
385 IF $D(DIAR),'$D(DIARU) SET $P(^DIAR(1.11,DIARC,0),U,3)=DISV
386 SET Z=-1,DIS0="^DIBT(+Y,"
387 FOR P="DIS","DA","DC","DE","DJ","DL" DO
388 . SET %Y=DIS0_""""_P_""","
389 . SET %X=P_"("
390 . DO %XY^%RCR
391 SET %X="^UTILITY($J,"
392 SET %Y="^DIBT(DISV,""O"","
393 SET @(%X_"0)=U")
394 DO %XY^%RCR
395G3 NEW DISTXT
396 SET %X="^UTILITY($J,"
397 SET %Y="DISTXT("
398 DO %XY^%RCR
399 write !
400 SET Y=DI
401 DO Q
402 SET DIC=Y
403 GOTO EN1^DIP:$D(SF)!$D(L)&'$D(DIAR),EN^DIP
404
405 ;"==========================================
406TEM ;
407 KILL DIC
408 SET X=$P($extract(X,2,99),"]",1)
409 SET DIC="^DIBT("
410 SET DIC(0)="EQ"
411 SET DIC("S")="IF "_$select($D(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
412 SET DIC("W")="X ""FOR %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0)) write !?9 SET I=^(0) W:$L(I)+$X>79 !?9 write I"""
413 DO ^DIC
414 KILL DIC
415 GOTO F:Y<0
416 SET P="DIS"
417 SET Z=-1
418 SET %X="^DIBT(+Y,P,"
419 SET %Y="DIS("
420 DO %XY^%RCR
421 SET %Y="^UTILITY($J,"
422 SET P="O"
423 DO %XY^%RCR
424 GOTO DIS2
425
426 ;"==========================================
427COMP ;
428 SET E=X ;"e.g. X="(#.02)"
429 SET DICMX="X DIS(DIXX)"
430 SET DICOMP=N_"?"
431 SET DQI="Y("
432 SET DA="DIS("""_$C(DC+64)_DL_""","
433 IF '$D(O(DC))#2 SET O(DC)=X
434 GOTO COLON:X?.E1":"
435 IF X?.E1":.01",'$D(O(DC))#2 SET O(DC)=$extract(X,1,$L(X)-4)
436 DO EN^DICOMP ;"Eval computed expression
437 DO XA
438 GOTO X:'$D(X)
439 GOTO X:Y["m" ;"IF Y["m" SET X=E_":" GOTO COMP
440 SET DA(DC)=X
441 SET DU=-DC
442 SET E=$extract("B",Y["B")_$extract("D",Y["D")
443 GOTO G3
444
445 ;"==========================================
446XA SET %=0
447 FOR DO Q:%=""
448 . SET %=$O(X(%))
449 . Q:%=""
450 . SET @(DA_%_")")=X(%)
451 SET %=-1
452 QUIT
453
454 ;"==========================================
455COLON DO ^DICOMPW
456 GOTO X:'$D(X)
457 DO XA
458 SET R(DL)=R
459 SET N(DL)=N
460 SET N=+Y
461 SET DY=DY+1
462 SET DV(DL)=DV
463 SET DL(DL)=DK
464 SET DL=DL+1
465 SET DV=DV_-DY_C
466 SET DY(DY)=DP_U_$select(Y["m":DC_"."_DL,1:"")_U_X
467 SET R=U_$P(DP,U,2)
468 KILL X
469 GOTO R
470
471 ;"==========================================
472Q ;
473 KILL DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE
474 KILL DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT
475 KILL ^UTILITY($J)
476 QUIT
477
478 ;"==========================================
479DIS ;"PUT SET LOGIC INTO DIS FOR SUBFILE
480 SET %X=""
481 FOR %Y=1:1 DO QUIT:'%X
482 . SET %X=$O(DIS(%X))
483 . QUIT:'%X
484 . SET %=$select($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X))
485 . SET:%["X DIS(" %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2)
486 . SET ^DIAR(1.11,DIARC,"S",%Y,0)=%X
487 . SET ^(1)=%
488 IF %Y>1 DO
489 . SET %Y=%Y-1
490 . SET ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y
491 GOTO DIS2
Note: See TracBrowser for help on using the repository browser.