source: cprs/branches/tmg-cprs/m_files/TMGFMUT2.m@ 1119

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

replacing soft links with actual files

File size: 27.7 KB
Line 
1TMGFMUT2 ;TMG/kst/Fileman utility functions ;02/19/10
2 ;;1.0;TMG-LIB;**1**;02/19/10
3 ;
4 ;"TMG FILEMAN-UTILITY FUNCTIONS
5 ;"(c) Kevin Toppenberg MD
6 ;"Released under: GNU General Public License (GPL)
7 ;"2/19/10
8 ;
9 ;"=======================================================================
10 ;"NOTE: This module will provide pointer tools that are different than found
11 ;" if ^TMGFMUT. The approach here will be to create tables of pointer
12 ;" relationships, and then allow faster analysis from the tables. This
13 ;" recognizes that such tables can rapidly become out of sync with the
14 ;" actual data. Thus the tools will only be valid on a system at rest (i.e.
15 ;" no users on the system). They could be used for system maint. overnight
16 ;" etc.
17 ;" Several of the routines here are called from ^TMGSIPH*
18 ;"Data is stored here:
19 ;"^TMG("PTXREF","OUT",FROMFILE,IENS,FROMFLD,P2FILE,PT)=""
20 ;"^TMG("PTXREF","IN",P2FILE,PT,FROMFILE,IENS,FROMFLD)=""
21 ;"=======================================================================
22 ;" API -- Public Functions.
23 ;"=======================================================================
24 ;"PREPPTO(FILENUM,FLD,ARRAY) -- set up an easy to use array of potential pointers out from a file.
25 ;"SETPTOUT(FILENUM,DESTREF,PGFN,PGFREQ,LIMITS) -- scan a given file and create an array with all pointers INTO that file.
26 ;"KILLPTIX -- delete the last run of PT XREF, so it can be refreshened.
27 ;"GETPTIN(PARAMS,OUT,PGFN) --get a listing of all pointers INTO requested record
28 ;"BAKXREF(PARAMS,PGFN) --Make a xref of cross-references (a backward xref)
29 ;"BAKSXREF(PARAMS,PGFN)-- Make a xref of cross-references (a backward xref) **OF SUBFILES**
30 ;"GETXRAGE --Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification
31 ;"GETGL(SUBFILENUM,IENDEPTH) --return a reference 'GL' string for subfiles.
32 ;"GETGREF(FILENUM,IENS) -- To return a reference to a ** SUBFILE **
33 ;"IENCOMBO(REF,IENDEPTH,IEN) --set up global vars IEN(2),IEN(3),... etc, as needed for next combo when cycling through subfile arrays.
34 ;"TOPFILEN(FILENUM) -- Return the highest level of filenumber.
35 ;"ISSUBFIL(FILENUM) -- Return if a file is a subfile.
36 ;"GETIENS(IEN) --Turn IEN Array into IENS
37 ;"IENS2IEN(IENS,IEN) -- Turn IENS into IEN Array, opposite of GETIENS function
38 ;"GETSPFN(FILENUM) -- Turn a subfile number into 'SubFileNum{ParentFileNum{GrandParentFileNum....'
39 ;"HASPTR(FILENUM) --Return if file contains fields that are pointers to other files
40 ;"HASPTRSF(FILENUM) -- Return if file contains subfiles (or sub-subfiles) that contain pointers to other files)
41 ;"FILENAME(FILENUM) -- turn a (SUB)File number into a file name.
42 ;"=======================================================================
43 ;" API - Private Functions
44 ;"=======================================================================
45 ;"TESTSPTO -- test out PT XREF setup.
46 ;"HNDLPTIX(FILENUM,PGFN) -- prepair PT XREF for all records pointing INTO specified file.
47 ;"=======================================================================
48 ;"Dependancies
49 ;"=======================================================================
50 ;"TMGKERN2, TMGUSRIF
51 ;"=======================================================================
52 ;
53PREPPTO(FILENUM,FLD,ARRAY) ;
54 ;"Purpose: To set up an easy to use array of potential pointers out from a file.
55 ;"Input: FILENUM-- the filenumber to evaluate
56 ;" FLD -- the field to check for.
57 ;" ARRAY -- PASS BY REFERENCE. An OUT PARAMETER. Format
58 ;" ARRAY(GREF,ENTRY)
59 ;" Note: ENTRY=DataPiece^PointedToFile^PointedToReference^IENDepth^[V]^FromFile^Fromfield^ONEREF
60 ;" ONEREF will have multipe IEN entries if IENDepth>1, e.g. '^SC(IEN,"S",IEN(2),1,IEN(3),"C")'
61 ;" with order of IEN, IEN(2), IEN(3), ... etc.
62 ;"NOTE: This function was originally coppied from SETPTOUT^TMGSIPH1
63 ;
64 IF +$GET(FILENUM)'=FILENUM GOTO SPODN
65 NEW IENDEPTH SET IENDEPTH=1
66 NEW REF SET REF=$GET(^DIC(FILENUM,0,"GL"))
67 IF (REF=""),$DATA(^DD(FILENUM,0,"UP")) DO
68 . SET REF=$$GETGL(FILENUM,.IENDEPTH)
69 IF REF="" GOTO SPODN
70 NEW GREF SET GREF=REF
71 IF GREF["IEN," SET GREF=$PIECE(GREF,"IEN,",1)
72 NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0))
73 NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2)
74 IF (FLDTYPE'["P")&(FLDTYPE'["V") GOTO SPODN
75 NEW LOC SET LOC=$PIECE(ZNODE,"^",4)
76 NEW NODE SET NODE=$PIECE(LOC,";",1)
77 NEW PCE SET PCE=+$PIECE(LOC,";",2)
78 IF +NODE'=NODE SET NODE=""""_NODE_""""
79 NEW ONEREF,SUBSCR
80 SET SUBSCR=$SELECT((IENDEPTH>1):"("_IENDEPTH_")",1:"")
81 SET ONEREF=REF_"IEN"_SUBSCR_","_NODE_")"
82 NEW P2FILE SET P2FILE=0
83 NEW VREC SET VREC=0
84 NEW DONE SET DONE=0
85 FOR DO QUIT:(DONE=1)
86 . NEW ISVIRT SET ISVIRT=""
87 . NEW P2REF
88 . IF FLDTYPE["V" DO QUIT:(DONE=1)
89 . . SET VREC=+$ORDER(^DD(FILENUM,FLD,"V",VREC))
90 . . IF VREC=0 SET DONE=1 QUIT
91 . . SET P2FILE=+$GET(^DD(FILENUM,FLD,"V",VREC,0))
92 . . SET ISVIRT="V"
93 . . SET P2REF=$PIECE($GET(^DIC(P2FILE,0,"GL")),"^",2)
94 . ELSE DO
95 . . SET P2FILE=+$PIECE(FLDTYPE,"P",2)
96 . . SET P2REF=$PIECE(ZNODE,"^",3)
97 . . SET DONE=1
98 . NEW ENTRY
99 . SET ENTRY=PCE_"^"_P2FILE_"^"_P2REF_"^"_IENDEPTH_"^"_ISVIRT_"^"_FILENUM_"^"_FLD_"^"_ONEREF
100 . SET ARRAY(GREF,ENTRY)=""
101SPODN QUIT
102 ;
103 ;
104GETIENS(IEN) ;"Turn IEN Array into IENS
105 NEW RESULT SET RESULT=IEN
106 NEW I SET I=1
107 FOR SET I=$ORDER(IEN(I)) QUIT:(+I'>0) DO
108 . SET RESULT=$GET(IEN(I))_","_RESULT
109 IF RESULT["," SET RESULT=RESULT_","
110 QUIT RESULT
111 ;
112 ;
113IENS2IEN(IENS,IEN) ;
114 ;"Purpose: Turn IENS into IEN Array, opposite of GETIENS function
115 ;"Input: IENS - an IENS string to convert. E.g. '7,2342,"
116 ;" IEN -- PASS BY REFERENCE. An OUT PARAMETER.
117 ;"Results: None.
118 KILL IEN
119 SET IENS=$GET(IENS)
120 NEW LEN SET LEN=$LENGTH(IENS,",")-1
121 NEW I FOR I=1:1:LEN DO
122 . NEW IDX SET IDX=(LEN-I+1)
123 . NEW VALUE SET VALUE=$PIECE(IENS,",",I)
124 . IF IDX>1 SET IEN(IDX)=VALUE
125 . ELSE SET IEN=VALUE
126 QUIT
127 ;
128 ;
129SETPTOUT(FILENUM,DESTREF,PGFN,PGFREQ,LIMITS)
130 ;"Purpose: To scan a given file and create an array with all pointers INTO that file.
131 ;" NOTE: The output will be a snapshot of the database that will quickly be out
132 ;" of date if/when the database changes.
133 ;"Input: FILENUM -- the Fileman file number to test. This is that file that other records will point TO
134 ;" DESTREF -- OPTIONAL. PASS BY NAME. The name of an array to store output into.
135 ;" MUST BE IN CLOSED FORMAT. If not specified, then ^TMG("PTXREF" will be used.
136 ;" PGFN -- OPTIONAL. <Progress Function Code>
137 ;" A string of mumps code that will be executed once for every 100 records that are scanned.
138 ;" The following variables will be defined for use.
139 ;" TMGCT -- The total number of that have been scanned so far.
140 ;" TMGFNAME -- The file that is currently begin scanned.
141 ;" TMGIEN -- Record number in the current file being scanned.
142 ;" TMGMAX -- Max record number in the current file being scanned.
143 ;" TMGMIN -- Min record number in the current file being scanned.
144 ;" PGFREQ --OPTIONAL. The number of records that must be scanned before the Progress Fn
145 ;" code is called. Default = 100.
146 ;" LIMITS -- OPTIONAL. If $DATA(LIMITS("REF"))'=0 then REF should be an array with format:
147 ;" LIMITS("REF")=<aREF>
148 ;" @aREF@(FILENUM,IEN)="" <-- Forms a set that will limit search. Only these entries are considered.
149 ;" @aREF@(FILENUM,IEN)="" <--
150 ;"Result: none.
151 NEW RESULT SET RESULT=0
152 SET FILENUM=+$GET(FILENUM) GOTO:(FILENUM=0) SPODN
153 SET DESTREF=$GET(DESTREF,$NAME(^TMG("PTXREF")))
154 SET PGFN=$GET(PGFN,"QUIT")
155 SET PGFREQ=+$GET(PGFREQ) IF PGFREQ'>0 SET PGFREQ=100
156 NEW LIMITREF SET LIMITREF=$GET(LIMITS("REF"))
157 SET LIMITS=(LIMITREF'="")
158 ;
159 ;"Build up ARRAY, an easy to use array of potential pointers OUT from a file.
160 ;"NOTE: Only files that point INTO FILENUM will be put into this array.
161 NEW ARRAY
162 NEW FROMFILE SET FROMFILE=0 ;"OtherFile
163 FOR SET FROMFILE=$ORDER(^DD(FILENUM,0,"PT",FROMFILE)) QUIT:(+FROMFILE'>0) DO
164 . NEW FLD SET FLD=0
165 . FOR SET FLD=$ORDER(^DD(FILENUM,0,"PT",FROMFILE,FLD)) QUIT:(+FLD'>0) DO
166 . . DO PREPPTO(FROMFILE,FLD,.ARRAY) ;
167 ;
168 ;"Now, cycle through possible pointers to look for real pointers.
169 SET @DESTREF@("TIMESTAMP")=$H
170 NEW ABORT SET ABORT=0
171 NEW TMGCT SET TMGCT=0
172 NEW GREF SET GREF=""
173 FOR SET GREF=$ORDER(ARRAY(GREF)) QUIT:(GREF="")!ABORT DO
174 . NEW TEMPN SET TEMPN=0
175 . NEW SKIP SET SKIP=0
176 . NEW FOUND SET FOUND=0
177 . FOR SET TEMPN=$ORDER(^DIC(TEMPN)) QUIT:(+TEMPN'>0)!FOUND DO ;"Get filenumber of GREF
178 . . IF $GET(^DIC(TEMPN,0,"GL"))'=GREF QUIT
179 . . SET FOUND=1
180 . . SET @DESTREF@("OUT",TEMPN)=$H
181 . IF SKIP QUIT
182 . NEW REF SET REF=$$CREF^DILF(GREF)
183 . NEW TMGMAX SET TMGMAX=$ORDER(@REF@("+"),-1)
184 . NEW TMGMIN SET TMGMIN=$ORDER(@REF@(0))
185 . NEW SKIP SET SKIP=0
186 . NEW IEN SET IEN=0
187 . FOR SET IEN=$ORDER(@REF@(IEN)) QUIT:(+IEN'>0)!ABORT!SKIP DO
188 . . IF LIMITS DO QUIT:SKIP ;"If running on client side, only look at downloaded records.
189 . . . IF $DATA(@LIMITREF@(TEMPN,IEN))'=0 QUIT
190 . . . SET SKIP=1
191 . . NEW INFO SET INFO=""
192 . . FOR SET INFO=$ORDER(ARRAY(GREF,INFO)) QUIT:(INFO="")!ABORT DO
193 . . . NEW PCE SET PCE=$PIECE(INFO,"^",1)
194 . . . NEW IENDEPTH SET IENDEPTH=$PIECE(INFO,"^",4)
195 . . . NEW ONREF SET ONEREF=$PIECE(INFO,"^",8,99)
196 . . . NEW TEMP SET TEMP=IEN KILL IEN SET IEN=TEMP ;"clear subscripts
197 . . . FOR QUIT:($$IENCOMBO(ONEREF,IENDEPTH,.IEN)'=1)!ABORT DO
198 . . . . NEW FROMFILE SET FROMFILE=$PIECE(INFO,"^",6)
199 . . . . SET TMGCT=TMGCT+1
200 . . . . IF TMGCT#PGFREQ=0 DO
201 . . . . . SET ABORT=$$UserAborted^TMGUSRIF() QUIT:ABORT
202 . . . . . NEW TMGFNAME SET TMGFNAME=$PIECE($GET(^DIC(FROMFILE,0)),"^",1)
203 . . . . . NEW TMGIEN SET TMGIEN=IEN
204 . . . . . NEW $ETRAP SET $ETRAP="W ""(Invalid M Code!. Error Trapped.)"" S $ETRAP="""",$ECODE="""""
205 . . . . . XECUTE PGFN
206 . . . . NEW PT SET PT=$PIECE($GET(@ONEREF),"^",PCE) ;"$$IENCOMBO sets up IEN(n).. needed for @REF
207 . . . . NEW ISVIRT SET ISVIRT=($PIECE(INFO,"^",5)="V")
208 . . . . NEW P2REF SET P2REF=$PIECE(INFO,"^",3)
209 . . . . IF ISVIRT,$PIECE(PT,";",2)'=P2REF QUIT ;"Loop to handle PTR with different INFO entry (V-Ptrs stored as IEN;OREF)
210 . . . . SET PT=+PT QUIT:(PT'>0)
211 . . . . NEW IENS SET IENS=$$GETIENS(.IEN)
212 . . . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2)
213 . . . . NEW FROMFLD SET FROMFLD=$PIECE(INFO,"^",7)
214 . . . . SET @DESTREF@("OUT",FROMFILE,IENS,FROMFLD,P2FILE,PT)=""
215 . . . . SET @DESTREF@("IN",P2FILE,PT,FROMFILE,IENS,FROMFLD)=""
216 QUIT
217 ;
218 ;
219TESTSPTO
220 ;"Purpose: test out PT XREF setup.
221 NEW X,Y,DIC
222 SET DIC=1,DIC(0)="MAEQ"
223 DO ^DIC WRITE !
224 IF +Y'>0 QUIT
225 NEW TMGSTIME SET TMGSTIME=$H
226 NEW PGFN SET PGFN="DO ProgressBar^TMGUSRIF(TMGIEN,TMGFNAME,TMGMIN,TMGMAX,60,TMGSTIME)"
227 DO SETPTOUT(+Y,$NAME(^TMG("PTXREF")),PGFN,500)
228 WRITE !,"Quitting normally.",!
229 QUIT
230 ;
231 ;
232KILLPTIX ;
233 ;"Purpose: To delete the last run of PT XREF, so it can be refreshened.
234 KILL ^TMG("PTXREF")
235 QUIT
236 ;
237 ;
238HNDLPTIX(FILENUM,PGFN) ;
239 ;"Purpose: To prepair PT XREF for all records pointing INTO specified file.
240 ;"Input: FILENUM -- The fileman file number to get pointers INTO.
241 ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
242 ;"Result: None
243 SET FILENUM=+$GET(FILENUM) IF FILENUM'>0 QUIT
244 NEW TMGSTIME SET TMGSTIME=$H
245 DO SETPTOUT(FILENUM,$NAME(^TMG("PTXREF")),.PGFN,3000,CLSIDE)
246 SET ^TMG("PTXREF","IN",FILENUM)=$H
247 SET ^TMG("PTXREF")=$H
248 QUIT
249 ;
250 ;
251GETPTIN(PARAMS,OUT,PGFN) ;
252 ;"Purpose: To get a listing of all pointers INTO requested record
253 ;"Input: PARAMS -- this is FILENUM^IEN
254 ;" OUT -- PASS BY REFERNCE. Will be filled as with format:
255 ;" OUT(1)=FROMFILE^FROMIENS^FROMFLD
256 ;" OUT(2)=FROMFILE^FROMIENS^FROMFLD
257 ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
258 ;" ...
259 NEW FILENUM SET FILENUM=+$PIECE(PARAMS,"^",1)
260 NEW TMGCT SET TMGCT=1
261 NEW IEN SET IEN=+$PIECE(PARAMS,"^",2)
262 IF $DATA(^TMG("PTXREF","IN",FILENUM))'>0 DO HNDLPTIX(FILENUM,.PGFN)
263 NEW FROMFILE,FROMIENS,FROMFLD
264 SET (FROMFILE,FROMIENS,FROMFLD)=0
265 FOR SET FROMFILE=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE)) QUIT:(+FROMFILE'>0) DO
266 . FOR SET FROMIENS=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE,FROMIENS)) QUIT:(+FROMIENS'>0) DO
267 . . FOR SET FROMFLD=$ORDER(^TMG("PTXREF","IN",FILENUM,IEN,FROMFILE,FROMIENS,FROMFLD)) QUIT:(+FROMFLD'>0) DO
268 . . . SET OUT(TMGCT)=FROMFILE_"^"_FROMIENS_"^"_FROMFLD
269 . . . SET TMGCT=TMGCT+1
270 QUIT
271 ;
272 ;
273BAKXREF(PARAMS,PGFN) ;
274 ;"Purpose: Make a xref of cross-references (a backward xref)
275 ;"Input: PARAMS -- This is FILENUM^[KEEP]
276 ;" FILENUM -- The fileman file to work with
277 ;" KEEP -- optional. DEFAULT=0; If '1', then nothing done if xref already exists.
278 ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
279 ;" The following globally-scoped variables will be available for use:
280 ;" FILENUM,INDEX
281 ;"Output: ^TMG("PTXREF","XREFS",FILENUM,IEN,REF)=<xref value>
282 ;" e.g. ^TMG("PTXREF","XREFS",FILENUM,113,"^VA(200,""A"",8870804679,113)")=6188
283 ;"Result: none.
284 SET PARAMS=$GET(PARAMS)
285 SET FILENUM=$PIECE(PARAMS,"^",1) IF +FILENUM'>0 GOTO BXDN
286 IF FILENUM["{" DO BAKSXREF(.PARAMS,.PGFN) GOTO BXDN
287 IF $DATA(^TMG("PTXREF","XREFS",FILENUM))>0 GOTO BXDN
288 SET PGFN=$GET(PGFN)
289 NEW STIME SET STIME=$H
290 NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL"))
291 IF GREF="" QUIT ;"Happened for file 799.6
292 NEW GRLEN SET GRLEN=$LENGTH(GREF)
293 NEW CGREF SET CGREF=$$CREF^DILF(GREF)
294 NEW GREFQLEN SET GREFQLEN=$QLENGTH(CGREF)
295 NEW REF SET REF=$QUERY(@CGREF@("@"))
296 NEW INDEX,LASTINDEX SET LASTINDEX=""
297 NEW DELAYCT SET DELAYCT=500 ;"ensure fires at least once to avoid timeout with many quick XREFS
298 NEW DONE SET DONE=0
299 KILL ^TMG("PTXREF","XREFS",FILENUM)
300 IF $GET(^TMG("PTXREF"))="" SET ^TMG("PTXREF")=$H
301 SET ^TMG("PTXREF","XREFS",FILENUM)=$H
302 FOR QUIT:(REF="") DO
303 . SET DELAYCT=DELAYCT+1
304 . IF (DELAYCT>500),(PGFN'="") DO
305 . . SET DELAYCT=0
306 . . IF ($PIECE($H,",",2)-STIME)<5 QUIT
307 . . SET STIME=$PIECE($H,",",2)
308 . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE="""""
309 . . XECUTE PGFN
310 . IF $EXTRACT(REF,1,GRLEN)'=GREF SET REF="" QUIT
311 . NEW IEN SET IEN=$QSUBSCRIPT(REF,$QLENGTH(REF))
312 . SET ^TMG("PTXREF","XREFS",FILENUM,IEN,REF)=$GET(@REF)
313 . SET INDEX=$QSUBSCRIPT(REF,GREFQLEN+1)
314 . IF INDEX'=LASTINDEX DO
315 . . SET LASTINDEX=INDEX
316 . . SET STIME=$PIECE($H,",",2)
317 . . SET DELAYCT=0
318 . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE="""""
319 . . XECUTE PGFN
320 . SET REF=$QUERY(@REF)
321BXDN QUIT
322 ;
323 ;
324BAKSXREF(PARAMS,PGFN) ;
325 ;"Purpose: Make a xref of cross-references (a backward xref) **OF SUBFILES**
326 ;"Input: PARAMS -- This is FILENUM^[KEEP]
327 ;" FILENUM -- subfilenum{parentfilenum{grandparent....
328 ;" KEEP -- optional. DEFAULT=0; If '1', then nothing done if xref already exists.
329 ;" PGFN -- OPTIONAL -- M Code that wil be periodically executed to show progress.
330 ;" The following globally-scoped variables will be available for use:
331 ;" FILENUM,INDEX
332 ;"Output: ^TMG("PTXREF","XREFS",SUBFILENUM,IENS,REF)=<xref value>
333 ;"Result: none.
334 SET PARAMS=$GET(PARAMS)
335 SET FILENUM=+$PIECE(PARAMS,"^",1) ;"Just get the subfile number.
336 IF FILENUM'>0 GOTO BXSDN
337 IF $DATA(^TMG("PTXREF","XREFS",FILENUM))>0 GOTO BXSDN
338 SET PGFN=$GET(PGFN)
339 NEW IEN SET IEN=0
340 NEW INDEX SET INDEX=""
341 NEW IENDEPTH SET IENDEPTH=""
342 NEW GREF SET GREF=$$GETGL(FILENUM,.IENDEPTH) ;" e.g. file 44.003 --> ^SC(IEN,"S",IEN(2),1, (open format)
343 IF GREF="" QUIT ;"Happened for file 799.6
344 NEW CGREF SET CGREF=$$CREF^DILF(GREF)
345 NEW J FOR J=1:1:IENDEPTH SET IEN(J)=1 ;"dummy values to satisfy $QLENGTH on line below
346 NEW GREFQLEN SET GREFQLEN=$QLENGTH($NAME(@CGREF))
347 NEW DELAYCT SET DELAYCT=999
348 ;"NOTE: IENCOMBO is only for getting subfile combos. It doesn't modify IEN. So I need
349 ;"to manually cycle between all the records of the top-most file. Use GETTOPFILEN^TMGFMUT2 to get this.
350 NEW TOPFILE SET TOPFILE=+$$TOPFILEN(FILENUM)
351 NEW TOPREF SET TOPREF=$GET(^DIC(TOPFILE,0,"GL"))
352 IF TOPREF="" GOTO BXSDN
353 KILL IEN SET IEN=0
354 SET TOPREF=$$CREF^DILF(TOPREF)
355 FOR SET IEN=$ORDER(@TOPREF@(IEN)) QUIT:(+IEN'>0) DO
356 . FOR DO QUIT:(OKCOMBO=0)
357 . . SET DELAYCT=DELAYCT+1
358 . . IF (DELAYCT>500),(PGFN'="") DO
359 . . . SET DELAYCT=0
360 . . . NEW $ETRAP SET $ETRAP="SET $ETRAP="""",$ECODE="""""
361 . . . XECUTE PGFN
362 . . SET OKCOMBO=$$IENCOMBO^TMGFMUT2(CGREF,IENDEPTH,.IEN) ;"Sets up IEN(n).. needed for @CGREF
363 . . QUIT:(OKCOMBO=0)
364 . . NEW GREF SET GREF=$$OREF^DILF($NAME(@CGREF)) ;"resolve IEN vars into actual numbers
365 . . NEW GRLEN SET GRLEN=$LENGTH(GREF)
366 . . NEW REF SET REF=$NAME(@CGREF@("@"))
367 . . FOR DO QUIT:(REF="")
368 . . . SET REF=$QUERY(@REF)
369 . . . IF $EXTRACT(REF,1,GRLEN)'=GREF SET REF="" QUIT
370 . . . SET INDEX=$QSUBSCRIPT(REF,GREFQLEN+1) ;"set up for use by PGFN
371 . . . NEW PTR SET PTR=$QSUBSCRIPT(REF,$QLENGTH(REF))
372 . . . NEW TMPIEN MERGE TMPIEN=IEN
373 . . . SET TMPIEN(IENDEPTH+1)=PTR
374 . . . NEW IENS SET IENS=$$GETIENS(.TMPIEN)
375 . . . SET ^TMG("PTXREF","XREFS",FILENUM,IENS,REF)=$GET(@REF)
376 . KILL IEN("DONE"),IEN("INIT")
377BXSDN QUIT
378 ;
379 ;
380GETXRAGE() ;
381 ;"Purpose: Return, in HOURS, the time since the ^TMG("PTXREF") array has had any modification
382 ;"Results: 0 if not currently defined, otherwise number of HOURS since setup.
383 NEW LASTT SET LASTT=$GET(^TMG("PTXREF","TIMESTAMP"))
384 NEW DELTAT SET DELTAT=0
385 IF LASTT'="" SET DELTAT=$$HDIFF^XLFDT($H,LASTT,2)\(60*60)
386 QUIT DELTAT
387 ;
388 ;
389GETGL(SUBFILENUM,IENDEPTH) ;
390 ;"Purpose: To return a reference 'GL' string for subfiles.
391 ;" E.g. file 44.003 --> ^SC(IEN,"S",IEN(2),1,
392 ;"INPUT: SUBFILENUM -- The sub file number
393 ;" IENDEPTH -- PASS BY REFERENCE. Should be 1 on first call
394 ;"Results: Returns an OPEN reference.
395 NEW RESULT SET RESULT=""
396 SET IENDEPTH=+$GET(IENDEPTH)+1
397 NEW UPFILE SET UPFILE=+$GET(^DD(SUBFILENUM,0,"UP"))
398 IF UPFILE'>0 DO GOTO IDN
399 . SET RESULT=$GET(^DIC(SUBFILENUM,0,"GL"))
400 NEW UPFLD SET UPFLD=+$ORDER(^DD(UPFILE,"SB",SUBFILENUM,""))
401 IF UPFLD'>0 GOTO IDN
402 NEW NODE SET NODE=$PIECE(^DD(UPFILE,UPFLD,0),"^",4)
403 SET NODE=$PIECE(NODE,";",1)
404 IF +NODE'=NODE SET NODE=""""_NODE_""""
405 SET RESULT=NODE_","
406 NEW GREF SET GREF=$GET(^DIC(UPFILE,0,"GL"))
407 NEW NUM2 SET NUM2=IENDEPTH
408 IF GREF="" SET GREF=$$GETGL(UPFILE,.IENDEPTH)
409 SET RESULT=GREF_"#"_$CHAR(64+NUM2)_"#,"_RESULT
410IDN NEW I,TMGSPEC
411 FOR I=1:1:IENDEPTH DO
412 . IF I=IENDEPTH SET TMGSPEC("#"_$CHAR(64+I)_"#")="IEN"
413 . ELSE SET TMGSPEC("#"_$CHAR(64+I)_"#")="IEN("_(IENDEPTH-I+1)_")"
414 SET RESULT=$$REPLACE^XLFSTR(RESULT,.TMGSPEC)
415IDN2 QUIT RESULT
416 ;
417 ;
418GETGREF(FILENUM,IENS) ;
419 ;"Purpose: To return a reference to a file or a subfile
420 ;" This function differs from GETGL in that REF from GETGREFhere has actual record numbers
421 ;" put in, while REF from GETGL has variable names (e.g. IEN(2)) in it.
422 ;"Input: IENS -- A standard IENS string to locate subfile. Not used unless FILENUM is a subfile.
423 ;" NOTE: the lowest level IEN is not used. e.g. '7,22345,' --> 7 is not used
424 ;"Returns : an OPEN format reference.
425 NEW GREF
426 NEW IENDEPTH SET IENDEPTH=1
427 SET GREF=$$GETGL(FILENUM,.IENDEPTH)
428 IF $$ISSUBFIL(FILENUM)=0 GOTO GGRDN
429 SET GREF=$$CREF^DILF(GREF)
430 NEW IEN DO IENS2IEN(.IENS,.IEN)
431 SET GREF=$NAME(@GREF) ;"Lock IEN value(s) from IENS into GREF
432 SET GREF=$$OREF^DILF(GREF)
433GGRDN QUIT GREF
434 ;
435 ;
436IENCOMBO(REF,IENDEPTH,IEN) ;
437 ;"Purpose: To set up global vars IEN(2),IEN(3),... etc, as needed for next combo when
438 ;" cycling through subfile arrays.
439 ;"Input: REF -- the is the potential pointer reference, as stored in ^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF,INFO)
440 ;" e.g. '^SC(IEN,"S",IEN(2),1,IEN(3),"C") (and IENDEPTH would be 3 for this example)
441 ;" IENDEPTH -- The number of variables to consider. I.e if value=3, then REF will
442 ;" contain IEN,IEN(2),IEN(3)
443 ;" IEN -- PASS BY REFERENCE. This variable will serve as an array to store the
444 ;" information needed to create the next valid set of variables needed
445 ;" to make use of the reference. NOTE: The value of IEN itself (e.g. IEN=4),
446 ;" is not modified.
447 ;"Results: 1 if a new valid IEN combo has been set up.
448 ;" 0 if there are no more subfile entries.
449 ;"
450 ;"NOTE!!!: If IENDEPTH=3, then this function will fail if there are records for depth 1,2, but not 3
451 ;" Needs debugging...
452 ;"
453 ;
454 NEW RESULT SET RESULT=0 ;"Default to invalid
455 IF $DATA(IEN("DONE")) GOTO ICODN
456 IF IENDEPTH=1 DO GOTO ICODN
457 . SET IEN("DONE")=1
458 . SET RESULT=1
459 NEW I
460 SET RESULT=1 ;"Default to valid
461 IF $DATA(IEN("ORDS"))=0 DO
462 . FOR I=2:1:IENDEPTH SET IEN("ORDS",I)=$$CREF^DILF($PIECE(REF,"IEN("_I_")",1))
463 IF +$GET(IEN("INIT"))=0 DO
464 . SET IEN("INIT")=1
465 . NEW INVALID SET INVALID=0
466 . NEW POS FOR POS=2:1:IENDEPTH DO QUIT:(INVALID=1)
467 . . IF $GET(IEN(POS))'="" QUIT
468 . . NEW TEMPREF SET TEMPREF=IEN("ORDS",POS)
469 . . SET IEN(POS)=+$ORDER(@TEMPREF@(0))
470 . . IF IEN(POS)'>0 SET INVALID=1
471 . IF (POS=IENDEPTH),(INVALID=0) SET RESULT=1
472 ELSE DO ;"At this point, IEN(n),IEN(n+1),... vars should be set to last valid combo.
473 . SET I=IENDEPTH
474 . NEW REF,NODE
475 . FOR DO QUIT:(I<2)!(I=IENDEPTH)
476 . . SET REF=IEN("ORDS",I)
477 . . SET IEN(I)=$ORDER(@REF@(IEN(I)))
478 . . IF (IEN(I)="") SET I=I-1 QUIT ;"reached last record at this level, so backup up level
479 . . IF (I<IENDEPTH) DO ;"We have a valid record, now get next subrecord
480 . . . NEW J FOR J=(I+1):1:IENDEPTH DO QUIT:(IEN(J)="")
481 . . . . SET REF=IEN("ORDS",J)
482 . . . . SET IEN(J)=$ORDER(@REF@(""))
483 FOR I=2:1:IENDEPTH IF +$GET(IEN(I))'>0 SET RESULT=0
484ICODN QUIT RESULT
485 ;
486 ;
487TOPFILEN(FILENUM) ;
488 ;"Purpose: Return the highest level of filenumber. I.e. if subfile, then return parent
489 ;" parent filenumber. If sub-sub-file, then return higest file number that is
490 ;" not a sub file.
491 ;" If FILENUM is not a subfile, then just return same FILENUM
492 ;"Results: 0 if problem, or Top-most filenumber.
493 NEW RESULT SET RESULT=0
494 IF +$GET(FILENUM)'=FILENUM GOTO TFNDN
495 FOR QUIT:$DATA(^DD(FILENUM,0,"UP"))=0 DO
496 . SET FILENUM=+$GET(^DD(FILENUM,0,"UP"))
497 SET RESULT=FILENUM
498TFNDN QUIT RESULT
499 ;
500 ;
501ISSUBFIL(FILENUM) ;
502 ;"Purpose: Return if a file is a subfile.
503 ;"Input: FILENUM -- a File, or Subfile, number
504 ;"Result: 1 if file is a subfile
505 QUIT ($DATA(^DD(FILENUM,0,"UP"))>0)
506 ;
507 ;
508HASPTRSF(FILENUM) ;" HAS POINTER-CONTAINING SUBFILES
509 ;"Purpose: Return if file contains subfiles (or sub-subfiles) that contain pointers to other files)
510 ;"Input: FILENUM -- The file number to investigatge
511 ;"Results: 1 if has pointer subfiles.
512 ;";
513 NEW RESULT SET RESULT=0
514 NEW FLD SET FLD=0
515 FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(RESULT=1) DO
516 . NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0))
517 . NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2)
518 . IF (+FLDTYPE'>0) QUIT
519 . NEW SUBFILEN SET SUBFILEN=+FLDTYPE
520 . IF $GET(^DD(SUBFILEN,0,"UP"))'=FILENUM QUIT
521 . SET RESULT=$$HASPTR(SUBFILEN)
522 QUIT RESULT
523 ;
524 ;
525HASPTR(FILENUM) ;" HAS POINTER fields
526 ;"Purpose: Return if file contains fields that are pointers to other files
527 ;"Input: FILENUM -- The file number to investigatge
528 ;"Results: 1 if has pointer subfiles.
529 ;"
530 NEW RESULT SET RESULT=($DATA(^DD(FILENUM,0,"PT"))'=0)
531 IF RESULT GOTO HPDN
532 NEW FLD SET FLD=0
533 FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0)!(RESULT=1) DO
534 . NEW ZNODE SET ZNODE=$GET(^DD(FILENUM,FLD,0))
535 . NEW FLDTYPE SET FLDTYPE=$PIECE(ZNODE,"^",2)
536 . IF +$PIECE(FLDTYPE,"P",2)>0 SET RESULT=1 QUIT
537 . IF (+FLDTYPE'>0) QUIT
538 . NEW SUBFILEN SET SUBFILEN=+FLDTYPE
539 . IF $GET(^DD(SUBFILEN,0,"UP"))'=FILENUM QUIT
540 . SET RESULT=$$HASPTRSF(SUBFILEN)
541HPDN QUIT RESULT
542 ;
543 ;
544FILENAME(FILENUM) ;
545 ;"Purpose: to turn a File number into a file name. ALSO, turn input with format of
546 ;" SubfileNumber{ParentFileNumber into a meaningful name too.
547 ;"Input: FILENUM: A file number, or a SubfileNumber{ParentFileNumber
548 ;"Result: returns name or name{name{name
549 ;"
550 IF (FILENUM'["{"),$$ISSUBFIL(+FILENUM) DO
551 . SET FILENUM=$$GETSPFN(FILENUM)
552 NEW RESULT SET RESULT=""
553 NEW I
554 FOR I=1:1:$LENGTH(FILENUM,"{") DO
555 . NEW ANUM SET ANUM=$PIECE(FILENUM,"{",I)
556 . NEW PFILE SET PFILE=+$GET(^DD(ANUM,0,"UP"))
557 . NEW ANAME
558 . IF PFILE=0 DO
559 . . SET ANAME=$PIECE($GET(^DIC(ANUM,0)),"^",1)
560 . ELSE DO
561 . . SET ANAME=$PIECE($GET(^DD(ANUM,0)),"^",1)
562 . . SET ANAME=$PIECE(ANAME,"SUB-FIELD",1)
563 . . SET ANAME=$$TRIM^XLFSTR(ANAME)
564 . IF RESULT'="" SET RESULT=RESULT_"{"
565 . SET RESULT=RESULT_ANAME
566 QUIT RESULT
567 ;
568 ;
569GETSPFN(FILENUM) ;" Get Special Filenum
570 ;"Purpose: Turn a subfile number into a 'special' subfilenumber, in format of:
571 ;" SubFileNum{ParentFileNum{GrandParentFileNum....
572 ;"Results: 0 if problem, or Top-most filenumber.
573 NEW RESULT SET RESULT=""
574 NEW FN SET FN=FILENUM
575 FOR DO QUIT:FN=0
576 . IF RESULT'="" SET RESULT=RESULT_"{"
577 . SET RESULT=RESULT_FN
578 . SET FN=+$GET(^DD(FN,0,"UP"))
579 QUIT RESULT
580 ;
581 ;
Note: See TracBrowser for help on using the repository browser.