source: cprs/branches/tmg-cprs/m_files/TMGFMUT.m@ 1099

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

Initial upload
File size: 66.1 KB
Line 
1TMGFMUT ;TMG/kst/Fileman utility functions ;03/25/06
2 ;;1.0;TMG-LIB;**1**;07/12/05
3
4 ;"TMG FILEMAN-UTILITY FUNCTIONS
5 ;"Kevin Toppenberg MD
6 ;"GNU General Public License (GPL) applies
7 ;"7-12-2005
8
9 ;"=======================================================================
10 ;" API -- Public Functions.
11 ;"=======================================================================
12 ;"$$PTRLINKS
13 ;"$$FilePtrs(File,OutVarP)
14 ;"DispArray(ArrayP,DispdList,indentDepth,MaxDepth)
15 ;"ASKPTRIN
16 ;"ASKMVPTR
17 ;"QTMVPTR(Info,PFn) --quietly redirect pointers.
18 ;"QTMMVPTR(Info,ShowProgress) --quietly redirect multiple pointers at once.
19 ;"$$PtrsIn(File,IEN,Array)
20 ;"$$PtrsMIn(IENArray,Array,ShowProgress)
21 ;"$$PossPtrs(File,Array)
22 ;"$$FMDate(DateStr) -- convert string to FM date, with extended syntax handing
23
24 ;"=======================================================================
25 ;"PRIVATE API FUNCTIONS
26 ;"=======================================================================
27 ;"ScanFile(FInfo,IEN,Array)
28 ;"ScanMFile(FInfoArray,IENArray,Array,ShowProgress)
29 ;"HandleSubFile(SearchValue,FileArray,Array,IENS,Ref)
30 ;"HandleMSubFile(IENArray,FileArray,Array,IENS,Ref)
31
32 ;"=======================================================================
33 ;"DEPENDENCIES
34 ;"=======================================================================
35 ;"TMGDBAPI
36 ;"=======================================================================
37
38
39PTRLINKS
40 ;"Purpose: To examine the Fileman data dictionary for a specified file
41 ;" Then tell any pointers out to other files. If found, then display
42 ;" this 'dependency'. Then follow trail to that file, and show it's
43 ;" 'dependency'. Trail will be followed up to N levels deep (set=6 here)
44 ;"Results: 1=OKToContinue, 0=failure
45
46 new File,Info,DispdList
47 new result
48
49 write "Display pointer dependencies between files.",!!
50 read "Enter file name or number to explore (^ to abort): ",File,!
51 if File="^" goto PTDone
52 set result=$$FilePtrs(File,"Info")
53 if result=0 write "Error. Aborting. Sorry about that...",!! goto PTDone
54
55 do DispArray("Info",.DispdList,0,6) ;"force max depth=6
56
57PTDone
58 quit result
59
60
61FilePtrs(File,OutVarP)
62 ;"For File, create array listing those fields with pointers to other files
63 ;"Input: File -- can be file name or number to explore
64 ;" OutVarP -- the name of array to put results into
65 ;"Output: Values are put into @OutVarP as follows:
66 ;" @OutVarP@(FileNum,"FILE NAME")=File Name
67 ;" @OutVarP@(FileNum,FieldNum)=Field Number
68 ;" @OutVarP@(FileNum,FieldNum,"FIELD NAME")=Field Name
69 ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference
70 ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to
71 ;" @OutVarP@(FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to
72 ;" @OutVarP@(FileNum,FieldNum,"X GET")=Code to xecute to get value
73 ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,.11),"^",5))"
74 ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE
75 ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value
76 ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,.11),"^",5)=TMGVALUE"
77 ;" ** For subfiles ** ...
78 ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"FIELD NAME")=Field Name
79 ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","GREF")=Open format global reference
80 ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NAME")=File name pointed to
81 ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"POINTS TO","FILE NUMBER")=File number pointed to
82 ;" @OutVarP@(FileNum,FieldNum,"SUBFILE",FileNum,FieldNum,"X GET")=Code to xecute to get value
83 ;" e.g. SET TMGVALUE=$PIECE($GET(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5))"
84 ;" note: TMGIEN is IEN to lookup, and result is in TMGVALUE
85 ;" @OutVarP@(FileNum,FieldNum,"X SET")=Code to xecute to set value
86 ;" e.g. SET TMGVALUE=$PIECE(^VA(200,TMGIEN,TMGIEN(1),.11),"^",5)=TMGVALUE"
87 ;" ... etc.
88 ;"Results: 1=OKToContinue, 0=failure
89
90 new TMGptrArray
91 new result
92 new index
93 new FileNum,FileName
94
95 set result=$$GetFldList^TMGDBAPI(.File,"TMGptrArray")
96 if result=0 goto FPtrDone
97 set result=($get(OutVarP)'="")
98 if result=0 goto FPtrDone
99 if +$get(File)=0 do
100 . set FileNum=$$GetFileNum^TMGDBAPI(.File)
101 . set FileName=$get(File)
102 else do
103 . set FileNum=+File
104 . set FileName=$$GetFName^TMGDBAPI(FileNum)
105 set result=(FileNum'=0)
106 if result=0 goto FPtrDone
107
108 set index=$order(TMGptrArray(""))
109 for do quit:(result=0)!(index="")
110 . new fieldnum,TMGFldInfo
111 . set fieldnum=index
112 . if +fieldnum=0 set result=0 quit
113 . do FIELD^DID(FileNum,fieldnum,,"POINTER;MULTIPLE-VALUED","TMGFldInfo","TMGMsg")
114 . if $data(TMGMsg) do set result=0 quit
115 . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg")
116 . . if $data(TMGMsg("DIERR"))'=0 do quit
117 . . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound)
118 . if $get(TMGFldInfo("MULTIPLE-VALUED"))=1 do
119 . . ;" handle subfiles via a recursive call
120 . . new subfile,subArrayP
121 . . set subfile=$$GetSubFileNumber^TMGDBAPI(FileNum,fieldnum)
122 . . if subfile=0 quit
123 . . set subArrayP=$name(@OutVarP@(FileNum,fieldnum,"SUBFILE"))
124 . . ;"set subArrayP=OutVarP
125 . . set result=$$FilePtrs(subfile,subArrayP)
126 . if $get(TMGFldInfo("POINTER"))'="" do
127 . . if +TMGFldInfo("POINTER")>0 quit ;"screen out computed nodes.
128 . . if TMGFldInfo("POINTER")[":" quit ;"screen out set type fields
129 . . new gref,node0
130 . . set gref=TMGFldInfo("POINTER")
131 . . set @OutVarP@(FileNum,"FILE NAME")=FileName
132 . . set @OutVarP@(FileNum,fieldnum,"FIELD NAME")=$$GetFldName^TMGDBAPI(FileNum,fieldnum)
133 . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","GREF")=gref
134 . . set gref="^"_gref_"0)"
135 . . ;"write "index=",index," gref=",gref,!
136 . . set node0=$get(@gref)
137 . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NAME")=$piece(node0,"^",1)
138 . . set @OutVarP@(FileNum,fieldnum,"POINTS TO","FILE NUMBER")=+$piece(node0,"^",2)
139 . . new DD set DD=$get(^DD(FileNum,fieldnum,0)) quit:(DD="")
140 . . new nodepce set nodepce=$piece(DD,"^",4) quit:(nodepce="")
141 . . new node set node=+$piece(nodepce,";",1) quit:(node="")
142 . . new pce set pce=+$piece(nodepce,";",2) quit:(pce'>0)
143 . . new thisGL set thisGL=$get(^DIC(FileNum,0,"GL"))
144 . . new getCode,setCode
145 . . if thisGL="" do quit:(thisGL="")
146 . . . ;"Note: I am only going to support 1 sub level. More--> brain hurts!
147 . . . new upNum set upNum=$get(^DD(FileNum,0,"UP"))
148 . . . if upNum="" quit
149 . . . set thisGL=$get(^DIC(upNum,0,"GL"))
150 . . . if thisGL="" quit ;"happens with sub-sub.. nodes.
151 . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,TMGIEN(1),"_node_")),""^"","_pce_")"
152 . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,TMGIEN(1),"_node_"),""^"","_pce_")=TMGVALUE"
153 . . else do
154 . . . set getCode="SET TMGVALUE=$PIECE($GET("_thisGL_"TMGIEN,"_node_")),""^"","_pce_")"
155 . . . set setCode="SET $PIECE("_thisGL_"TMGIEN,"_node_"),""^"","_pce_")=TMGVALUE"
156 . . set @OutVarP@(FileNum,fieldnum,"X GET")=getCode
157 . . set @OutVarP@(FileNum,fieldnum,"X SET")=setCode
158 . set index=$order(TMGptrArray(index))
159
160FPtrDone
161 quit result
162
163DispArray(ArrayP,DispdList,indentDepth,MaxDepth)
164 ;"Purpose: Display array created by FilePtrs (see format there)
165 ;"Input: ArrayP : name of array containing information
166 ;" DispdList : array (pass by reference) contining list of files already displayed
167 ;" DispdList("TIU DOCUMENT")=""
168 ;" DispdList("PATIENT")="" etc.
169 ;" indentDepth : Number of indents deep this function is. Default=0
170 ;" MaxDepth : maximum number of indents deep allowed.
171
172 new i,fieldnum,file,FileName
173 set indentDepth=+$get(indentDepth,0)
174 new indentS set indentS=""
175 for i=1:1:(indentDepth) s indentS=indentS_". "
176
177 set file=$order(@ArrayP@(""))
178 set FileName=$get(@ArrayP@(file,"FILE NAME"))
179 set DispdList(FileName)=""
180 if FileName'="" write indentS,"FILE: ",FileName,!
181 set fieldnum=$order(@ArrayP@(file,""))
182 for do quit:(+fieldnum=0)
183 . if +fieldnum=0 quit
184 . new p2FName
185 . set p2FName=$get(@ArrayP@(file,fieldnum,"POINTS TO","FILE NAME"))
186 . write indentS,"field: ",$get(@ArrayP@(file,fieldnum,"FIELD NAME")),"--> file: ",p2FName
187 . if $data(DispdList(p2FName))=0 do
188 . . set DispdList(p2FName)=""
189 . . if indentDepth<MaxDepth do
190 . . . new p2Array
191 . . . if $$FilePtrs(p2FName,"p2Array")=0 do quit
192 . . . . write " (?)",!
193 . . . write !
194 . . . do DispArray("p2Array",.DispdList,indentDepth+1,.MaxDepth)
195 . . else write " (...)",!
196 . else do
197 . . write " (above)",!
198 . set fieldnum=$order(@ArrayP@(file,fieldnum))
199
200 quit
201
202
203ASKPTRIN
204 ;"Purpose: An interface shell to PtrsIn.
205 ;" Will ask for name of a file, and then a record in that file.
206 ;" Will then show all pointers to that particular record.
207
208 new File,IEN,Array,PFn,result
209
210 write !!,"Pointer Scanner.",!
211 write "Will look for all pointers (references) to specified record.",!!
212 set DIC="^DIC("
213 set DIC(0)="MAQE"
214 d ^DIC
215 set File=+Y
216 if File'>0 goto APTDone
217 set DIC=File
218 do ^DIC
219 set IEN=+Y
220 if IEN'>0 goto APTDone
221 new TMGTIME set TMGTIME=$H
222 ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!"
223 set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)"
224 write !!,"Starting File Scan for instances of pointers (references) to this record.",!!
225 set result=$$PtrsIn(File,IEN,.Array,PFn)
226 if result=0 write !,"There was some problem. Sorry.",!! goto APTDone
227
228 if $data(Array) do
229 . write !,"Done. Here are results:",!
230 . write "Format is: ",!
231 . write " Array(File#,IEN,0)=LastCount",!
232 . write " Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef",!
233 . write " Description of parts:",!
234 . write " ----------------------",!
235 . write " File# -- the file the found entry exists it (may be a subfile number)",!
236 . write " IEN -- the record number in file",!
237 . write " Note: IEN here is different from the IEN passed in as a parameter",!
238 . write " FullRef -- the is the full reference to the found value. e.g.",!
239 . write " set value=$piece(@FullRef,""^"",piece)",!
240 . write " piece -- piece where value is stored in the node that is specified by FullRef",!
241 . write " IENS -- this is provided only for matches in subfiles. ",!
242 . write " It is the IENS that may be used in database calls",!
243 . write " TopGlobalRef -- this is the global reference for file. If the match is in a",!
244 . write " subfile, then this is the global reference of the parent file ",!
245 . write " (or the highest grandparent file if the parent file itself is",!
246 . write " a subfile)",!
247 . zwr Array(*)
248 . write "---------------------------",!
249 . new temp read "Press [ENTER] to continue.",temp:$get(DTIME,3600),!
250 else write !,"No pointers to that record found.",!
251
252APTDone
253 quit
254
255SCRLPTRIN
256 ;"Purpose: An scrolling interface shell to PtrsIn.
257 ;" Will ask for name of a file, and then a record in that file.
258 ;" Will then show all pointers to that particular record.
259 ;" Will then allow one to trace along pointer path (in or out)
260
261 new File,IEN,Array,PFn,result
262 new AFile,AIEN,ACount
263 new ShowArray,ShowResults,Header,Count
264 new PickStr,PickInfo,Abort,Menu,UsrSlct
265 new DIC,X,Y
266
267 write !!,"Pointer Scanner/Browser.",!
268 write "Will look for all pointers (references) to specified record.",!!
269 set DIC="^DIC("
270 set DIC(0)="MAQE"
271 DO ^DIC
272 set File=+Y
273 if File'>0 goto SCPTDone
274 set DIC=File
275 do ^DIC
276 set IEN=+Y
277 if IEN'>0 goto SCPTDone
278 new TMGTIME set TMGTIME=$H
279 set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)"
280SCPT1 ;
281 write !!,"Scanning files for instances of pointers (references) to this record.",!!
282 set result=$$PtrsIn(File,IEN,.Array,PFn)
283 if result=0 do goto APTDone
284 . write !,"There was some problem. Sorry.",!!
285 . do PressToCont^TMGUSRIF
286 ;"Returned format is: ",!
287 ;" Array(File#,IEN,0)=LastCount",!
288 ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef",!
289 ;" Description of parts:",!
290
291 set File=0,Abort=0
292 for set File=$order(Array(File)) quit:(+File'>0) do
293 . new FName set FName=$piece($get(^DIC(File,0)),"^",1)
294 . new IEN set IEN=0;
295 . for set IEN=$order(Array(File,IEN)) quit:(+IEN'>0) do
296 . . new Value01 set Value01=$$GET1^DIQ(File,IEN,.01)
297 . . set Count=0
298 . . for set Count=$order(Array(File,IEN,Count)) quit:(+Count'>0) do
299 . . . new Str set Str=FName_"; #"_IEN_"; "_Value01
300 . . . if Count>1 set Str=Str_" ("_Count_")"
301 . . . set ShowArray(Str,File_"^"_IEN_"^"_Count)=""
302 . . .
303 set Header="Pick ONE (and only ONE) record to explore. Press ESC ESC when done."
304SCPT2 kill ShowResults
305 if $get(TMGPTCABORT)=1 goto SCPTDone
306 do Slctor2^TMGUSRIF("ShowArray","ShowResults",Header)
307
308 set Count=$$ListCt^TMGMISC("ShowResults")
309 if Count>1 do goto SCPT2
310 . write "Please pick ONE (and only ONE) record to explore.",!
311 . write "You selected at least ",Count,!
312 . write "Enter ^ to quit",!
313 . do PressToCont^TMGUSRIF
314
315 set PickStr=""
316 set PickStr=$order(ShowResults(PickStr))
317 if PickStr="" do goto SCPTDone
318 . write "No selected record. Goodbye.",!
319 . do PressToCont^TMGUSRIF
320
321 set Count=$$ListCt^TMGMISC("ShowArray("_PickStr_")")
322 if Count>0 do goto SCPTDone
323 . set Abort=1
324 . write "Please pick ONE (and only ONE) record to explore.",!
325 . write "You selected at least ",Count,!
326 . do PressToCont^TMGUSRIF
327
328 set PickInfo=$order(ShowResults(PickStr,""))
329 set AFile=$piece(PickInfo,"^",1)
330 set AIEN=$piece(PickInfo,"^",2)
331 set ACount=$piece(PickInfo,"^",3)
332
333 set Menu(0)="Pick Option."
334 set Menu(1)="Show info for this selected record"_$C(9)_"ShowInfo"
335 set Menu(2)="DUMP this record"_$C(9)_"DumpRec"
336 set Menu(3)="Show pointers INTO selected record"_$C(9)_"ShowPtrIN"
337 set Menu(4)="Browse to other records pointed OUT from this record."_$C(9)_"BrowseOUT"
338
339MC1 write #
340 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^")
341 if UsrSlct="^" do goto SCPTDone
342 . write "Goodbye.",!
343 if UsrSlct=0 set UsrSlct=""
344
345 if UsrSlct="ShowInfo" do goto MC1
346 . if $data(Array(AFile,AIEN,ACount))=0 quit
347 . zwr Array(AFile,AIEN,ACount,*)
348 . do PressToCont^TMGUSRIF
349 if UsrSlct="DumpRec" do goto MC1
350 . do DumpRec2^TMGDEBUG(AFile,AIEN,0)
351 . do PressToCont^TMGUSRIF
352 if UsrSlct="ShowPtrIN" do goto SCPT1
353 . set File=AFile
354 . set IEN=AIEN
355 . set Count=ACount
356 if UsrSlct="BrowseOUT" do goto MC1
357 . do Browse^TMGBROWS(AFile,AIEN,0)
358 . do PressToCont^TMGUSRIF
359 goto MC1
360SCPTDone
361 quit
362
363
364ASKMVPTR
365 ;"Purpose: An interface shell toRedirect any pointer.
366 ;" Will ask for name of a file, and then a record in that file.
367 ;" Will then pass information to fileman function to move pointers.
368
369 ;"Note: Example of array passed to P^DITP
370 ;" 23510 is $J
371 ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*))
372 ;" 1646 is IEN to be substituted for all 47's
373 ;"
374 ;" First part of array is list of all files & fields that point to file
375 ;" ----------------
376 ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'"
377 ;" ...
378 ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV"
379 ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V"
380 ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V"
381 ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX"
382 ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX"
383 ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'"
384 ;"
385 ;" Second part of array is list of changes that should be made. Only 1 change shown here.
386 ;" ----------------
387 ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG("
388 ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG("
389
390 new File,fromIEN,toIEN,Array,PFn,result
391 new PossPtrs
392
393 write !,"Pointer Redirection Utility",!
394 write "Will change pointers to FROM to TO value",!
395
396 kill DIC
397 set DIC("A")="Select File holding records being pointed to: "
398 set DIC="^DIC("
399 set DIC(0)="MAQE"
400 d ^DIC ;"Get File to search
401 set File=+Y
402 if File'>0 goto AMPTDone
403
404 ;"Get list of files/fields with pointers in
405 set result=$$PossPtrs(File,.PossPtrs) if result=0 goto AMPTDone
406 if $data(PossPtrs)'>0 goto AMPTDone
407
408 set DIC=File
409 set DIC("A")="Select Original (i.e OLD) Record: "
410 do ^DIC ;"get FROM record in File
411 set fromIEN=+Y
412 if fromIEN'>0 goto AMPTDone
413
414 set DIC("A")="Select New Record: "
415 do ^DIC ;"get FROM record in File
416 set toIEN=+Y
417 if toIEN'>0 goto AMPTDone
418
419 ;"set PFn="w TMGCODE,"" "",((TMGCUR/TMGTOTAL)*100)\1,""%"",!"
420 ;"new TMGTIME set TMGTIME=$H
421 set PFn="do ProgressBar^TMGUSRIF(TMGCUR,""Scanning File: ""_$P(TMGCODE,""^"",1),1,TMGTOTAL)"
422 write !!,"Starting File Scan for instances of pointers (references) to this record.",!!
423 set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 goto AMPTDone
424
425 ;" write !,"Here are possible pointers in (file level)",!
426 ;" if $data(PossPtrs) zwr PossPtrs(*)
427
428 ;" write !,"Here are actual pointers in",!
429 ;" if $data(Array) zwr Array(*)
430
431 ;"Now convert to FileMan Format.
432 kill ^UTILITY("DIT",$J)
433 do Prep4FM(.Array)
434
435 if $data(^UTILITY("DIT",$J)) do
436 . merge ^UTILITY("DIT",$J,0)=PossPtrs
437 . ;"write !,"here are results",!
438 . ;" zwr ^UTILITY("DIT",$J,*)
439 . set DIR(0)="Y",DIR("B")="YES"
440 . set DIR("A")="Ask Fileman to redirect pointers?"
441 . set DIR("?")="Enter YES if you want Fileman to change all instances of the FROM record into the TO record."
442 . do ^DIR ;"get user response
443 . if +Y'=1 quit
444 . write "YES",!
445 . do PTS^DITP
446 else do
447 . write "No matches found...",!!
448
449AMPTDone
450 quit
451
452
453QTMVPTR(Info,PFn) ;"NOTE: this function hasn't been debugged/tested yet
454 ;"Purpose: An interface to quietly redirect any pointer.
455 ;"Input: Info, an array containing info for redirecting pointers.
456 ;" Format: Note: File can be file name or number.
457 ;" Info(File,OldIEN)=newIEN
458 ;" Info(File,OldIEN)=newIEN1
459 ;" Info(File,OldIEN)=newIEN
460 ;" PFn: OPTIONAL, a progress function (must be a complete M expression)
461 ;"Output: all pointers in linked files to OldIEN will be changed to newIEN
462 ;"Results: none
463
464 ;"Note: Example of array passed to P^DITP
465 ;" 23510 is $J
466 ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*))
467 ;" 1646 is IEN to be substituted for all 47's
468 ;"
469 ;" First part of array is list of all files & fields that point to file
470 ;" ----------------
471 ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'"
472 ;" ...
473 ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV"
474 ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V"
475 ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V"
476 ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX"
477 ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX"
478 ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'"
479 ;"
480 ;" Second part of array is list of changes that should be made. Only 1 change shown here.
481 ;" ----------------
482 ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG("
483 ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG("
484
485 new File,Array,result
486 set PFn=$get(PFn)
487 new Itr,File
488
489 ;"Cycle through all files to be changed.
490 set File=$$ItrAInit^TMGITR("Info",.Itr)
491 if File'="" for do quit:($$ItrANext^TMGITR(.Itr,.File)="")
492 . new PossPtrs
493 . if +File'=File set File=$$GetFileNum^TMGDBAPI(File) ;Convert File Name to File Number
494 . ;"Get list of files/fields with pointers in
495 . set result=$$PossPtrs(File,.PossPtrs) if result=0 quit
496 . if $data(PossPtrs)'>0 quit
497 . kill ^UTILITY("DIT",$J)
498 . new fromIEN,toIEN,fromItr
499 . set fromIEN=+$$ItrAInit^TMGITR($name(Info(File)),.fromItr)
500 . new done2 set done2=0
501 . ;"Cycle through all records to be changed.
502 . if fromIEN'=0 for do quit:(+$$ItrANext^TMGITR(.fromItr,.fromIEN)=0)!(done2=1)
503 . . set toIEN=$get(Info(File,fromIEN))
504 . . set result=$$PtrsIn(File,fromIEN,.Array,PFn) if result=0 set done2=1
505 . . do Prep4FM(.Array)
506 . if $data(^UTILITY("DIT",$J))=0 quit
507 . merge ^UTILITY("DIT",$J,0)=PossPtrs
508 . do PTS^DITP ;"Note: call separately for each file specified.
509
510QMPTDone
511 quit
512
513
514QTMMVPTR(Info,ShowProgress) ;"NOTE: this function hasn't been debugged/tested yet
515 ;"Purpose: An interface to quietly redirect multiple pointer.
516 ;"NOTE: This functions differes from QTMVPTR in that it can look for all IEN's
517 ;" for a given file at once, speeding database access.
518 ;"Input: Info, an array containing info for redirecting pointers.
519 ;" Format: Note: File can be file name or number.
520 ;" Info(File,OldIEN)=newIEN
521 ;" Info(File,OldIEN)=newIEN1
522 ;" Info(File,OldIEN)=newIEN
523 ;" ShowProgress: if 1, progress bar shown
524 ;"Output: all pointers in linked files to OldIEN will be changed to newIEN
525 ;"Results: none
526
527 ;"Note: Example of array passed to P^DITP
528 ;" 23510 is $J
529 ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*))
530 ;" 1646 is IEN to be substituted for all 47's
531 ;"
532 ;" First part of array is list of all files & fields that point to file
533 ;" ----------------
534 ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'"
535 ;" ...
536 ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV"
537 ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V"
538 ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V"
539 ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX"
540 ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX"
541 ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'"
542 ;"
543 ;" Second part of array is list of changes that should be made. Only 1 change shown here.
544 ;" ----------------
545 ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG("
546 ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG("
547
548 new ToFile,Array,result
549 set PFn=$get(PFn)
550 new Itr
551
552 ;"Cycle through all files to be changed.
553 set ToFile=$$ItrAInit^TMGITR("Info",.Itr)
554 if ToFile'="" for do quit:($$ItrANext^TMGITR(.Itr,.ToFile)="")
555 . new PossPtrs
556 . if +ToFile'=ToFile set ToFile=$$GetFileNum^TMGDBAPI(ToFile) ;"Convert File Name to File Number
557 . ;"Get list of files/fields with pointers in
558 . set result=$$PossPtrs(ToFile,.PossPtrs) if result=0 quit
559 . if $data(PossPtrs)'>0 quit
560 . kill ^UTILITY("DIT",$J)
561 . ;"new fromIEN,toIEN,fromItr
562 . ;"set fromIEN=+$$ItrAInit^TMGITR($name(Info(ToFile)),.fromItr)
563 . new IENArray set IENArray=ToFile
564 . merge IENArray=Info(ToFile)
565 . set IENArray=ToFile
566 . set result=$$PtrsMIn(.IENArray,.Array,.ShowProgress)
567 . new toFile2,toIEN,fromFile,fromIEN,Array2
568 . set toFile2=""
569 . for set toFile2=$order(Array(toFile2)) quit:(toFile2="") do
570 . . set toIEN=""
571 . . for set toIEN=$order(Array(toFile2,toIEN)) quit:(toIEN="") do
572 . . . set fromFile=""
573 . . . for set fromFile=$order(Array(toFile2,toIEN,fromFile)) quit:(fromFile="") do
574 . . . . set fromIEN=""
575 . . . . for set fromIEN=$order(Array(toFile2,toIEN,fromFile,fromIEN)) quit:(fromIEN="") do
576 . . . . . merge Array2(fromFile,fromIEN)=Array(toFile2,toIEN,fromFile,fromIEN)
577 . set toFile2=""
578 . for set toFile2=$order(Array2(toFile2)) quit:(toFile2="") do
579 . . do MPrep4FM(toFile2,.Array2)
580 . . if $data(^UTILITY("DIT",$J))=0 quit
581 . . merge ^UTILITY("DIT",$J,0)=PossPtrs
582 . . do PTS^DITP ;"Note: call separately for each file specified.
583
584QMMPTDone
585 quit
586
587
588Prep4FM(Array)
589 ;"Purpose: to convert Array with redirection info into format for Fileman
590 ;"Input: Array -- PASS BY REFERENCE. An array as created by PtrsIn()
591 ;"Output: Data will be put into ^UTILITY('DIT',$J)
592 ;"Results: none
593
594 ;"Now convert to FileMan Format.
595 new iFile,iIEN,count,index,toRef
596 set iFile=$order(Array(""))
597 if +iFile'=0 for do quit:(+iFile=0)
598 . set iIEN=$order(Array(iFile,""))
599 . if +iIEN'=0 for do quit:(+iIEN=0)
600 . . set count=+$get(Array(iFile,iIEN,0))
601 . . for index=1:1:count do
602 . . . set toRef=$piece($get(Array(iFile,iIEN,count)),";",4)
603 . . . set toRef=$extract(toRef,2,999)
604 . . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef
605 . . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_""
606 . . set iIEN=$order(Array(iFile,iIEN))
607 . set iFile=$order(Array(iFile))
608
609 quit
610
611
612MPrep4FM(fromFile,Array)
613 ;"Purpose: to convert Array with redirection info into format for Fileman
614 ;"Input: fromFile -- the FromFileNum -- Note: should be called once for
615 ;" each File number
616 ;" Array -- PASS BY REFERENCE. An array as created by PtrsMIn()
617 ;" Array(FromFile#,fromIEN,0)=LastCount
618 ;" Array(FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef
619 ;"Output: Data will be put into ^UTILITY('DIT',$J)
620 ;"Results: none
621
622 ;"Now convert to FileMan Format.
623 new fromIEN set fromIEN=""
624 for set fromIEN=$order(Array(fromFile,fromIEN)) quit:(+fromIEN'>0) do
625 . new count
626 . set count=+$get(Array(fromFile,fromIEN,0))
627 . new index for index=1:1:count do
628 . . new toRef
629 . . set toRef=$piece($get(Array(fromFile,fromIEN,count)),";",4)
630 . . set toRef=$extract(toRef,2,999)
631 . . set ^UTILITY("DIT",$J,fromIEN)=toIEN_";"_toRef
632 . . set ^UTILITY("DIT",$J,""_fromIEN_";"_toRef_"")=""_toIEN_";"_toRef_""
633
634 quit
635
636
637PtrsIn(File,IEN,Array,PrgsFn)
638 ;"SCOPE: PUBLIC
639 ;"Purpose: Create a list of incoming pointers to a given record in given file
640 ;"Input: File: The file to investigate (Number or Name)
641 ;" IEN: IEN of record to
642 ;" Array -- PASS BY REFERENCE. An array to receive results back.
643 ;" any prexisting data in Array is killed before filling
644 ;" PrgsFn: OPTIONAL -- <Progress Function Code>
645 ;" because this search process can be quite lengthy,
646 ;" an optional line of M code may be given here that will be executed
647 ;" before each file is scanned. The following variables will be defined:
648 ;" TMGCODE -- will hold code of current file being scanned.
649 ;" TMGTOTAL -- will hold total number of records to scan
650 ;" TMGCUR -- will hold count of current record being scanned.
651 ;"Output: Array is filled with format as follows:
652 ;" Array(File#,IEN,0)=LastCount
653 ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef
654 ;" Description of parts:
655 ;" ----------------------
656 ;" File# -- the file the found entry exists it (may be a subfile number)
657 ;" IEN -- the record number in file
658 ;" Note: IEN here is different from the IEN passed in as a parameter
659 ;" FullRef -- the is the full reference to the found value. e.g.
660 ;" set value=$piece(@FullRef,"^",piece)
661 ;" piece -- the piece where value is stored in the node that is specified by FullRef
662 ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls
663 ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then
664 ;" this is the global reference of the parent file (or the highest grandparent file if
665 ;" the parent file itself is a subfile, etc.)
666 ;"
667 ;"Result: 1 if results found, 0 if error occurred.
668 ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT!
669
670 kill Array
671 new result set result=0
672 new FileNum
673 set IEN=+$get(IEN)
674 if IEN=0 goto FPIDone ;"NOTE: IEN doesn't have to point to a valid record.
675 if $data(File)#10=0 goto FPIDone
676 if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number
677 else set FileNum=File
678 if +FileNum=0 goto FPIDone
679
680 new PossArray,TMGCODE
681 if $$PossPtrs(File,.PossArray)=0 goto FPIDone
682
683 ;"Count number of records to scan
684 new TMGCUR set TMGCUR=0
685 new TMGTOTAL set TMGTOTAL=0
686 do
687 . new temp set temp=$order(PossArray(""))
688 . if temp'="" for do quit:(temp="")
689 . . new code set code=PossArray(temp)
690 . . new ref set ref=$get(^DIC(+code,0,"GL"))
691 . . set ref=$$CREF^DILF(ref) ;"convert open to closed format
692 . . new NumRecs
693 . . if ref'="" set NumRecs=+$piece(@ref@(0),"^",4)
694 . . else set NumRecs=10000 ;"some arbitrary guess of #recs in a subfile
695 . . set TMGTOTAL=TMGTOTAL+1
696 . . set TMGTOTAL(TMGTOTAL)=NumRecs
697 . . set temp=$order(PossArray(temp))
698 . set temp=$order(TMGTOTAL(""))
699 . set TMGTOTAL=1
700 . if temp'="" for do quit:(temp="")
701 . . set TMGTOTAL=TMGTOTAL+TMGTOTAL(temp)
702 . . set temp=$order(TMGTOTAL(temp))
703 . if TMGTOTAL=0 set TMGTOTAL=1 ;"avoid div by zero issues.
704
705 new count set count=1
706 new index set index=$order(PossArray(""))
707 if index'="" for do quit:(index="")
708 . set TMGCUR=TMGCUR+TMGTOTAL(count)
709 . set count=count+1
710 . set TMGCODE=PossArray(index)
711 . if $get(PrgsFn)'="" do
712 . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode="""""
713 . . xecute PrgsFn
714 . do ScanFile(TMGCODE,IEN,.Array)
715 . set index=$order(PossArray(index))
716
717 set result=1
718FPIDone
719 quit result
720
721
722PtrsMIn(IENArray,Array,ShowProgress)
723 ;"SCOPE: PUBLIC
724 ;"Purpose: Create a list of incoming pointers to an array of records in given file
725 ;"NOTE: this function differes from PtrsIn because is allows multiple input IEN's
726 ;"Input: IENArray: PASS BY REFERENCE. Array of IENs of record in ToFile. Format:
727 ;" IENArray=SourceFile#
728 ;" IENArray(IEN)=""
729 ;" IENArray(IEN)=""
730 ;" Array -- PASS BY REFERENCE. An array to receive results back. Format below.
731 ;" any prexisting data in Array is killed before filling
732 ;" ShowProgress: if 1, progress bar shown
733 ;"Output: Array is filled with format as follows:
734 ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,0)=LastCount
735 ;" Array(ToFile#,ToIEN,FromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef
736 ;" Description of parts:
737 ;" ----------------------
738 ;" ToFile# -- the file containing the target IEN record
739 ;" ToIEN --the IEN in ToFile
740 ;" FromFile# -- the file the found entry exists it (may be a subfile number)
741 ;" fromIEN -- the record number in file
742 ;" Note: IEN here is different from the IEN passed in as a parameter
743 ;" FullRef -- the is the full reference to the found value. e.g.
744 ;" set value=$piece(@FullRef,"^",piece)
745 ;" piece -- the piece where value is stored in the node that is specified by FullRef
746 ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls
747 ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then
748 ;" this is the global reference of the parent file (or the highest grandparent file if
749 ;" the parent file itself is a subfile, etc.)
750 ;"
751 ;"Result: 1 if results found, 0 if error occurred.
752 ;"NOTE: This function manually scans through potentially HUGE numbers of records-->BE PATIENT!
753
754 kill Array
755 new result set result=0
756 new FileNum
757 set ToFile=$get(IENArray) if ToFile="" goto FMPIDone
758 if +ToFile=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number
759 else set FileNum=ToFile
760 if +FileNum=0 goto FMPIDone
761
762 new PossArray
763 if $$PossPtrs(FileNum,.PossArray)=0 goto FMPIDone
764
765 new FInfoArray
766 new index set index=""
767 for set index=$order(PossArray(index)) quit:(index="") do
768 . new tempS set tempS=$get(PossArray(index))
769 . new fromFile set fromFile=$piece(tempS,"^",1)
770 . new fromField set fromField=$piece(tempS,"^",2)
771 . new fldCode set fldCode=$piece(tempS,"^",3)
772 . set FInfoArray(fromFile,fromField)=fldCode
773
774 do ScanMFile(.FInfoArray,.IENArray,.Array,.ShowProgress)
775
776 set result=1
777FMPIDone
778 quit result
779
780
781ScanFile(FInfo,IEN,Array)
782 ;"SCOPE: PUBLIC
783 ;"Purpose: To scan one file (from array setup by PossPtrs) for actual pointers to IEN
784 ;"Input: FInfo : OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field)
785 ;"Examples of possible inputs follow:
786 ;"50^62.05^*P50'"
787 ;"695^.01^RP50'"
788 ;"801.43^.02^RV"
789 ;"810.31^.04^V"
790 ;"811.902^.01^MVX"
791
792 ;"NOTE: Idea for future enhancement: Allow FInfo to hold a list rather than just one value.
793 ;" This would be for instances where multiple fields in given record need to be searched
794 ;" This might speed up database access times.
795
796 ;" IEN : the IEN that pointers should point to, to be considered a match.
797 ;" Array : PASS BY REFERENCE. An array to receive results.
798 ;"Output: Format of Array output:
799 ;" Array(File#,IEN,0)=LastCount
800 ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef
801 ;" Description of parts:
802 ;" ----------------------
803 ;" File# -- the file the found entry exists it (may be a subfile number)
804 ;" IEN -- the record number in file
805 ;" Note: IEN here is different from the IEN passed in as a parameter
806 ;" FullRef -- the is the full reference to the found value. e.g.
807 ;" set value=$piece(@FullRef,"^",piece)
808 ;" piece -- the piece where value is stored in the node that is specified by FullRef
809 ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls
810 ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then
811 ;" this is the global reference of the parent file (or the highest grandparent file if
812 ;" the parent file itself is a subfile, etc.)
813 ;"
814 ;"result : none
815
816 new File set File=$piece(FInfo,"^",1) if File="" goto SFDone
817 new Field set Field=$piece(FInfo,"^",2) if Field="" goto SFDone
818 new Code set Code=$piece(FInfo,"^",3) if Code="" goto SFDone
819 new count
820 if '((Code["P")!(Code["V")) goto SFDone
821 new GRef
822 new znode set znode=$get(^DD(File,Field,0))
823 new loc set loc=$piece(znode,"^",4)
824 new node set node=$piece(loc,";",1)
825 new pce set pce=$piece(loc,";",2)
826 if +$$IsSubFile^TMGDBAPI(File) do
827 . new FileArray,i,k,FNum,SubInfo
828 . set i=0
829 . set FileArray(0)=0
830 . set FileArray(i,"PARENT","LOC")=loc
831 . set FNum=File
832 . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence
833 . . set i=i+1
834 . . set FileArray(i)=FNum
835 . . if i=1 set FileArray(0,"FILE")=FNum
836 . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do
837 . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC")
838 . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor
839 . . else do
840 . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL"))
841 . . set FNum=$$IsSubFile^TMGDBAPI(FNum)
842 . do HandleSubFile(IEN,.FileArray,.Array)
843 else do
844 . set GRef=$get(^DIC(File,0,"GL"))
845 . new ORef set ORef=GRef
846 . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format
847 . new index set index=$order(@GRef@(0))
848 . if index'="" for do quit:(index="")
849 . . new value set value=$get(@GRef@(index,node))
850 . . if $piece(value,"^",pce)=IEN do
851 . . . set Array(File,index,0)=1
852 . . . set Array(File,index,1)=$name(@GRef@(index,node))_";"_pce_";"_""_";"_ORef
853 . . set index=$order(@GRef@(index))
854
855SFDone
856 quit
857
858
859ScanMFile(FInfoArray,IENArray,Array,ShowProgress)
860 ;"SCOPE: PUBLIC
861 ;"Purpose: To scan multiple file (from array setup by PossPtrs) for actual pointers to IENs
862 ;"Input: FInfoArray : PASS BY REFERENCE. Format:
863 ;" FInfoArray(OtherFile,Field)=FieldCode(piece#2 of 0 node of ^DD entry for field)
864 ;" Examples of possible inputs follow:
865 ;" FInfoArray(50,62.05)="*P50'"
866 ;" FInfoArray(695,.01)="RP50'"
867 ;" FInfoArray(801.43,.02)="RV"
868 ;" FInfoArray(810.31,.04)="V"
869 ;" FInfoArray(811.902,.01)="MVX"
870 ;" IENArray : PASS BY REFERENCE. IEN's that pointers should point TO, to be considered a match.
871 ;" Format: IENArray=SourceFile
872 ;" IENArray(IEN)=""
873 ;" IENArray(IEN)=""
874 ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format:
875 ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount
876 ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef
877 ;" Description of parts:
878 ;" ----------------------
879 ;" ToFile# -- the file containing the target IEN record
880 ;" ToIEN --the IEN in ToFile
881 ;" fromFile# -- the file the found entry exists it (may be a subfile number)
882 ;" fromIEN -- the record number in file
883 ;" Note: IEN here is different from the IEN passed in as a parameter
884 ;" FullRef -- the is the full reference to the found value. e.g.
885 ;" set value=$piece(@FullRef,"^",piece)
886 ;" piece -- the piece where value is stored in the node that is specified by FullRef
887 ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls
888 ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then
889 ;" this is the global reference of the parent file (or the highest grandparent file if
890 ;" the parent file itself is a subfile, etc.)
891 ;" ShowProgress: if 1, progress bar shown
892 ;"
893 ;"result : none
894
895 new ToFile set ToFile=+$get(IENArray)
896 set ShowProgress=$get(ShowProgress,0)
897 new abort set abort=0
898 set fromFile=""
899 for set fromFile=$order(FInfoArray(fromFile)) quit:(fromFile="")!abort do
900 . if $$UserAborted^TMGUSRIF set abort=1 quit
901 . write !,"Processing File#: ",fromFile,!
902 . new Field set Field=""
903 . for set Field=$order(FInfoArray(fromFile,Field)) quit:(Field="") do
904 . . write " Field#: ",Field,!
905 . . new Code set Code=$get(FInfoArray(fromFile,Field)) if Code="" quit
906 . . new count
907 . . if '((Code["P")!(Code["V")) goto SFDone
908 . . new GRef
909 . . new znode set znode=$get(^DD(fromFile,Field,0))
910 . . new loc set loc=$piece(znode,"^",4)
911 . . new node set node=$piece(loc,";",1)
912 . . new pce set pce=$piece(loc,";",2)
913 . . if +$$IsSubFile^TMGDBAPI(fromFile) do
914 . . . new FileArray,i,k,FNum,SubInfo
915 . . . set i=0
916 . . . set FileArray(0)=0
917 . . . set FileArray(i,"PARENT","LOC")=loc
918 . . . set FNum=fromFile
919 . . . for do quit:(+FNum=0) ;"setup array describing subfile's inheritence
920 . . . . set i=i+1
921 . . . . set FileArray(i)=FNum
922 . . . . if i=1 set FileArray(0,"FILE")=FNum
923 . . . . if $$GetSubFInfo^TMGDBAPI(FNum,.SubInfo) do
924 . . . . . set FileArray(i,"PARENT","LOC")=SubInfo("FIELD IN PARENT","LOC")
925 . . . . . set GRef=$get(SubInfo("PARENT","GL")) ;"<-- only valid for highest ancestor
926 . . . . else do
927 . . . . . set (FileArray(0,"TOP GL"),FileArray(i,"PARENT","GL"))=$get(^DIC(FNum,0,"GL"))
928 . . . . set FNum=$$IsSubFile^TMGDBAPI(FNum)
929 . . . do HandleMSubFile(.IENArray,.FileArray,.Array)
930 . . else do
931 . . . set GRef=$get(^DIC(fromFile,0,"GL"))
932 . . . new ORef set ORef=GRef
933 . . . set GRef=$$CREF^DILF(GRef) ;"convert open to closed format
934 . . . new Itr,fromIEN
935 . . . set fromIEN=$$ItrAInit^TMGITR(GRef,.Itr)
936 . . . if ShowProgress=1 do PrepProgress^TMGITR(.Itr,20,1,"fromIEN")
937 . . . if fromIEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.fromIEN)="")!abort
938 . . . . if $$UserAborted^TMGUSRIF set abort=1 quit
939 . . . . ;"for set fromIEN=$order(@GRef@(fromIEN)) quit:(fromIEN="") do
940 . . . . new valueS set valueS=$get(@GRef@(fromIEN,node))
941 . . . . new ToIEN set ToIEN=$piece(valueS,"^",pce)
942 . . . . if $data(IENArray(ToIEN))>0 do
943 . . . . . new lastCount set lastCount=+$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1
944 . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=lastCount
945 . . . . . set Array(ToFile,ToIEN,fromFile,fromIEN,lastCount)=$name(@GRef@(fromIEN,node))_";"_pce_";"_""_";"_ORef
946
947SMFDone
948 quit
949
950
951HandleSubFile(SearchValue,FileArray,Array,IENS,Ref)
952 ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue.
953 ;"Input: SearchValue -- the value to be searched for, in INTERNAL format.
954 ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers
955 ;" and storage locations. Example:
956 ;" FileArra(0,"TOP GL")="^XTV(8989.3,"
957 ;" FileArra(0,"FILE")=8989.33211
958 ;" FileArra(0)=0
959 ;" FileArra(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece
960 ;" FileArra(1)=8989.33211
961 ;" FileArra(1,"PARENT","LOC")="1;0" <--- 1 is storage node
962 ;" FileArra(2)=8989.3321
963 ;" FileArra(2,"PARENT","LOC")="1;0" <--- 1 is storage node
964 ;" FileArra(3)=8989.332
965 ;" FileArra(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node
966 ;" FileArra(4)=8989.3
967 ;" FileArra(4,"PARENT","GL")="^XTV(8989.3,"
968 ;" Array -- PASS BY REFERENCE. An array the receives any search matches.
969 ;" Format is as follows
970 ;" Array(File#,IEN,0)=LastCount
971 ;" Array(File#,IEN,count)=FullRef;piece;IENS;TopGlobalRef
972 ;"
973 ;" IENS -- OPTIONAL -- used by this function internally during recursive calls
974 ;" Ref -- OPTIONAL -- used by this function internally during recursive calls
975
976 new index,s,IEN,CRef,pce,node
977 set index=$order(FileArray(""),-1)
978 set s=$get(FileArray(index,"PARENT","LOC"))
979 set node=$piece(s,";",1)
980 set pce=+$piece(s,";",2)
981 if s'="" do
982 . if +node'=node set node=""""_node_""""
983 . set s=node_","
984 else do
985 . set s=$get(FileArray(index,"PARENT","GL"))
986 . set node=""
987 set Ref=$get(Ref)_s
988 if Ref="" goto HSFDone
989 set CRef=$$CREF^DILF(Ref)
990 new subFArray
991 merge subFArray=FileArray
992 kill subFArray(index) ;"trim top entry from list/array
993 if index>0 do
994 . set IEN=$order(@CRef@(0))
995 . if +IEN>0 for do quit:(+IEN=0)
996 . . new subRef,subIENS
997 . . set subRef=Ref_IEN_","
998 . . set subIENS=IEN_","_$get(IENS)
999 . . do HandleSubFile(SearchValue,.subFArray,.Array,.subIENS,subRef)
1000 . . set IEN=$order(@CRef@(IEN))
1001 else do
1002 . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs
1003 . . set subRef=$$CREF^DILF(subRef)
1004 . . new p,t set (p,t)=0
1005 . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter
1006 . . ;"new ORef set ORef=$extract(subRef,1,p-1)
1007 . . set IEN=$piece($extract(subRef,p,99),")",1)
1008 . . new value set value=$get(@subRef@(node))
1009 . . set value=$piece(value,"^",pce)
1010 . . set value=$piece(value,";",1) ;"I think VARIABLE pointers format is: IEN;file#
1011 . . if value=SearchValue do
1012 . . . new tFile set tFile=$get(FileArray(0,"FILE"),"?")
1013 . . . new count set count=$get(Array(tFile,IEN,0))+1
1014 . . . set Array(tFile,IEN,0)=count
1015 . . . set Array(tFile,IEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL"))
1016
1017HSFDone
1018 quit
1019
1020
1021HandleMSubFile(IENArray,FileArray,Array,IENS,Ref)
1022 ;"Purpose: To provide a means of recursively handling subfiles, searching for SearchValue.
1023 ;"Input: IENArray : PASS BY REFERENCE. IEN's to search for in INTERNAL format.
1024 ;" Format: IENArray=SourceFile
1025 ;" IENArray(IEN)=""
1026 ;" IENArray(IEN)=""
1027 ;" File Array -- PASS BY REFERENCE An array that describes the parent file numbers
1028 ;" and storage locations. Example:
1029 ;" FileArray(0,"TOP GL")="^XTV(8989.3,"
1030 ;" FileArray(0,"FILE")=8989.33211
1031 ;" FileArray(0)=0
1032 ;" FileArray(0,"PARENT","LOC")="0;1" <-- for FileArray(0) node, stores node;piece
1033 ;" FileArray(1)=8989.33211
1034 ;" FileArray(1,"PARENT","LOC")="1;0" <--- 1 is storage node
1035 ;" FileArray(2)=8989.3321
1036 ;" FileArray(2,"PARENT","LOC")="1;0" <--- 1 is storage node
1037 ;" FileArray(3)=8989.332
1038 ;" FileArray(3,"PARENT","LOC")="ABPKG;0" <--- "ABPKG" is storage node
1039 ;" FileArray(4)=8989.3
1040 ;" FileArray(4,"PARENT","GL")="^XTV(8989.3,"
1041 ;" Array : PASS BY REFERENCE. AN OUT PARAMETER. Format:
1042 ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,0)=LastCount
1043 ;" Array(ToFile#,ToIEN,fromFile#,fromIEN,count)=FullRef;piece;IENS;TopGlobalRef
1044 ;" Description of parts:
1045 ;" ----------------------
1046 ;" ToFile# -- the file containing the target IEN record
1047 ;" ToIEN --the IEN in ToFile
1048 ;" fromFile# -- the file the found entry exists it (may be a subfile number)
1049 ;" fromIEN -- the record number in file
1050 ;" Note: IEN here is different from the IEN passed in as a parameter
1051 ;" FullRef -- the is the full reference to the found value. e.g.
1052 ;" set value=$piece(@FullRef,"^",piece)
1053 ;" piece -- the piece where value is stored in the node that is specified by FullRef
1054 ;" IENS -- this is provided only for matches in subfiles. It is the IENS that may be used in database calls
1055 ;" TopGlobalRef -- this is the global reference for file. If the match is in a subfile, then
1056 ;" this is the global reference of the parent file (or the highest grandparent file if
1057 ;" the parent file itself is a subfile, etc.)
1058 ;"
1059 ;" IENS -- OPTIONAL -- used by this function internally during recursive calls
1060 ;" Ref -- OPTIONAL -- used by this function internally during recursive calls
1061
1062 new ToFile set ToFile=$get(IENArray)
1063 new index,s,IEN,CRef,pce,node
1064 set index=$order(FileArray(""),-1)
1065 set s=$get(FileArray(index,"PARENT","LOC"))
1066 set node=$piece(s,";",1)
1067 set pce=+$piece(s,";",2)
1068 if s'="" do
1069 . if +node'=node set node=""""_node_""""
1070 . set s=node_","
1071 else do
1072 . set s=$get(FileArray(index,"PARENT","GL"))
1073 . set node=""
1074 set Ref=$get(Ref)_s
1075 if Ref="" goto HSFDone
1076 set CRef=$$CREF^DILF(Ref)
1077 new subFArray
1078 merge subFArray=FileArray
1079 kill subFArray(index) ;"trim top entry from list/array
1080 if index>0 do
1081 . set fromIEN=0
1082 . for set fromIEN=$order(@CRef@(fromIEN)) quit:(+fromIEN=0) do
1083 . . new subRef,subIENS
1084 . . set subRef=Ref_fromIEN_","
1085 . . set subIENS=fromIEN_","_$get(IENS)
1086 . . do HandleMSubFile(.IENArray,.subFArray,.Array,.subIENS,subRef)
1087 else do
1088 . if (pce>0) do ;"Here is were the actual comparison to SearchValue occurs
1089 . . set subRef=$$CREF^DILF(subRef)
1090 . . new p,t set (p,t)=0
1091 . . for set t=$find(subRef,",",t) set:(t>0) p=t quit:(t=0) ;"find pos of last parameter
1092 . . ;"new ORef set ORef=$extract(subRef,1,p-1)
1093 . . set fromIEN=$piece($extract(subRef,p,99),")",1)
1094 . . new valueS set valueS=$get(@subRef@(node))
1095 . . set valueS=$piece(valueS,"^",pce)
1096 . . new ToIEN set ToIEN=$piece(valueS,";",1) ;"I think VARIABLE pointers format is: IEN;file#
1097 . . if $data(IENArray(ToIEN))>0 do
1098 . . . new fromFile set fromFile=$get(FileArray(0,"FILE"),"?")
1099 . . . new count set count=$get(Array(ToFile,ToIEN,fromFile,fromIEN,0))+1
1100 . . . set Array(ToFile,ToIEN,fromFile,fromIEN,0)=count
1101 . . . set Array(ToFile,ToIEN,fromFile,fromIEN,count)=$name(@subRef@(node))_";"_pce_";"_""_$get(IENS)_""_";"_$get(FileArray(0,"TOP GL"))
1102
1103HMSFDone
1104 quit
1105
1106
1107PossPtrs(File,Array)
1108 ;"SCOPE: PUBLIC
1109 ;"Purpose: to create a list of all possible pointers to a specified file, i.e. all other fields/fields
1110 ;" that point to the specified file.
1111 ;"Input: File: The file to investigate (Number or Name)
1112 ;" Array -- PASS BY REFERENCE. An array to receive results back.
1113 ;" any prexisting data in Array is killed before filling
1114 ;"Output: Array is filled with format as follows:
1115 ;" Array(1)=OtherFile#^Field#^FieldCode(piece#2 of 0 node of ^DD entry for field)
1116 ;" Array(2)=OtherFile#^Field#^FieldCode
1117 ;"Result: 1 if results found, 0 if error occurred.
1118
1119 kill Array
1120 new result set result=0
1121 new FileNum
1122 if $data(File)#10=0 goto PPtrsDone
1123 if +File=0 set FileNum=$$GetFileNum^TMGDBAPI(File) ;"Convert File Name to File Number
1124 else set FileNum=File
1125 if +FileNum=0 goto PPtrsDone
1126
1127 new count set count=1
1128 new PtrFile set PtrFile=$order(^DD(FileNum,0,"PT",""))
1129 if PtrFile'="" for do quit:(PtrFile="")
1130 . new PtrField set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,""))
1131 . if PtrField'="" for do quit:(PtrField="")
1132 . . new s set s=PtrFile_"^"_PtrField
1133 . . set s=s_"^"_$piece($get(^DD(PtrFile,PtrField,0)),"^",2)
1134 . . set Array(count)=s
1135 . . set count=count+1
1136 . . set PtrField=$order(^DD(FileNum,0,"PT",PtrFile,PtrField))
1137 . set PtrFile=$order(^DD(FileNum,0,"PT",PtrFile))
1138
1139 set result=1
1140PPtrsDone
1141 quit result
1142
1143
1144 ;"Note: Not fully debugged yet..."
1145SAFEKILL(Array,ShowProgress)
1146 ;"Purpose: to safely kill records, including removing any pointers TO them
1147 ;"input: pArray -- PASS BY REFERENCE. Expected input Format:
1148 ;" Array(File,IEN)=0
1149 ;" Array(File,IEN)=0
1150 ;" ShowProgress: if 1, progress bar shown
1151 ;"Output: all pointers in linked files to OldIEN will be changed to newIEN
1152 ;"Results: none
1153
1154 do QTMMVPTR(.Array,.ShowProgress)
1155 quit
1156
1157
1158ASKKILL
1159 ;"Purpose: to interact with user and safely kill records
1160 ;"Input: none.
1161 ;"Output: Records and pointers may be deleted
1162 ;"Results: none
1163
1164 new DIC,File,X,Y
1165 new fromIEN,toIEN
1166 new delArray
1167
1168 kill DIC
1169 set DIC("A")="Select file to delete from: "
1170 set DIC="^DIC("
1171 set DIC(0)="MAQE"
1172 d ^DIC ;"Get File to search
1173 set File=+Y
1174 if File'>0 goto ASKKDone
1175
1176 new Menu,UsrSlct
1177 set Menu(0)="Pick Option for Selecting Record(s) to Safely Delete"
1178 set Menu(1)="Manually pick Record(s)"_$char(9)_"ManualPick"
1179 set Menu(2)="Select a SET (aka SORT TEMPLATE) Contianing Many Records"_$char(9)_"PickSet"
1180
1181M1 write #
1182 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^")
1183
1184 if UsrSlct="ManualPick" goto ManualPick
1185 if UsrSlct="PickSet" goto PickSet
1186 if UsrSlct="^" goto ASKKDone
1187 if UsrSlct=0 set UsrSlct=""
1188 goto M1
1189
1190ManualPick
1191 set DIC=File
1192 set DIC("A")="Select record to delete: "
1193 do ^DIC ;"get FROM record in File
1194 write !
1195 set fromIEN=+Y
1196 if fromIEN'>0 goto ASKGo
1197 set delArray(File,fromIEN)=0
1198 new % set %=2
1199 write "Pick another record" do YN^DICN write !
1200 if %=1 goto ManualPick
1201 if %=-1 goto ASKKDone
1202 goto ASKGo
1203
1204PickSet new IENArray
1205 if $$GetTemplateRecs^TMGXMLUI(File,"IENArray","",1)=0 goto ASKKDone
1206 ;"Output: Data is put into pRecs like this: @pRecs@(IEN)=""
1207
1208 new IEN set IEN=""
1209 for set IEN=$order(IENArray(IEN)) quit:(IEN="") do
1210 . set delArray(File,IEN)=0
1211
1212ASKGo
1213 if $data(delArray)=0 goto ASKKDone
1214
1215 ;"Get list of files/fields with pointers in
1216 set result=$$PossPtrs(File,.PossPtrs) if result=0 goto ASKKDone
1217 if $data(PossPtrs)'>0 goto DelRecs
1218
1219 do SAFEKILL(.delArray,1)
1220
1221DelRecs ;"Now that pointers to records are deleted, it is safe to remove records themselves
1222
1223 set IEN=""
1224 new abort set abort=0
1225 for set IEN=$order(IENArray(IEN)) quit:(IEN="")!(abort=1) do
1226 . if $$UserAborted^TMGUSRIF set abort=1 quit
1227 . new TMGFDA,TMGMSG
1228 . set TMGFDA(File,IEN_",",.01)="@"
1229 . do FILE^DIE("EK","TMGFDA","TMGMSG")
1230 . do ShowIfDIERR^TMGDEBUG(.TMGMSG)
1231
1232ASKKDone
1233 quit
1234
1235
1236
1237VerifyPtrs(File,pArray,Verbose,AutoFix)
1238 ;"Purpose: to scan a file for pointers OUT that are bad/invalid
1239 ;"Input: File : file Name or Number to scan
1240 ;" pArray : PASS BY NAME, an OUT PARAMETER. Format:
1241 ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr
1242 ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr
1243 ;" Verbose: OPTIONAL. If 1, then errors immediately written out.
1244 ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted.
1245 ;"Results: None
1246
1247 new PtrsOUT
1248 new pPtrsOUT set pPtrsOUT="PtrsOUT"
1249 new fileNum
1250 if +File=File set fileNum=+File
1251 else set fileNum=$$GetFileNum^TMGDBAPI(File)
1252 set Verbose=+$get(Verbose)
1253 set AutoFix=+$get(AutoFix)
1254
1255 if $$FilePtrs(fileNum,pPtrsOUT)=0 goto VPtrDone
1256
1257 new Itr,Itr2,TMGIEN,fieldNum
1258 new TMGVALUE,code
1259 new abort set abort=0
1260 new $etrap set $etrap="set Y=""(Invalid M code!. Error Trapped.)"" set $etrap="""",$ecode="""""
1261
1262 do DoVerify(File,pArray,Verbose,AutoFix) ;" Split out code to call it to call itself reentrantly
1263
1264VPtrDone
1265 quit
1266
1267
1268DoVerify(fileNum,pArray,Verbose,AutoFix,IENS,pTMGIEN)
1269 ;"Purpose: Function allow VerifyPtrs to call reentrantly
1270 ;"Input: File : file Name or Number to scan
1271 ;" pArray : PASS BY NAME, an OUT PARAMETER. Format:
1272 ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr
1273 ;" @pArray@(FileNum,IEN,FieldNum)=ValueOfBadPtr
1274 ;" Verbose: OPTIONAL. If 1, then errors immediately written out.
1275 ;" AutoFix: OPTIONAL. If 1, then bad pointers are deleted.
1276 ;" IENS: OPTIONAL. If fileNum is a sub-file, then must supply
1277 ;" to give location of subfile in parent file.
1278 ;" pTMGIEN: "TMGIEN", or "TMGIEN(1)" etc.
1279 ;"Results: None
1280 ;"NOTICE: right now this MUST first be called from VerifyPtrs because
1281 ;" I have not moved some NEW commandes etc from there to here.
1282 ;" So this function depends on it's variables with global scope.
1283
1284 set IENS=$get(IENS)
1285 set pTMGIEN=$get(pTMGIEN,"TMGIEN")
1286 set @pTMGIEN=$$ItrInit^TMGITR(fileNum,.Itr,.IENS)
1287 if IENS="" do PrepProgress^TMGITR(.Itr,20,0,pTMGIEN) ;" no bar for subfiles
1288 if @pTMGIEN'="" for do quit:(+$$ItrNext^TMGITR(.Itr,.@pTMGIEN)'>0)!abort
1289 . set fieldNum=$$ItrAInit^TMGITR($name(@pPtrsOUT@(fileNum)),.Itr2)
1290 . if fieldNum'="" for do quit:(+$$ItrANext^TMGITR(.Itr2,.fieldNum)'>0)!abort
1291 . . if (@pTMGIEN#10=0),$$UserAborted^TMGUSRIF set abort=1 quit
1292 . . ;"Line below handles subfiles
1293 . . if $data(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE")) do quit
1294 . . . new subFile set subFile=$order(@pPtrsOUT@(fileNum,fieldNum,"SUBFILE",""))
1295 . . . set IENS=IENS_@pTMGIEN_","
1296 . . . do DoVerify(subFile,$name(@pArray@("SUBFILE")),.Verbose,.AutoFix,IENS,$name(@pTMGIEN@(1)))
1297 . . ;"Otherwise, the usual case....
1298 . . set code=$get(PtrsOUT(fileNum,fieldNum,"X GET"))
1299 . . if code="" quit
1300 . . xecute code
1301 . . if TMGVALUE="" quit
1302 . . set TMGVALUE=+TMGVALUE
1303 . . if TMGVALUE'>0 do quit
1304 . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE
1305 . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="")
1306 . . . new priorValue set priorValue=TMGVALUE
1307 . . . set TMGVALUE=""
1308 . . . if 'AutoFix quit
1309 . . . xecute setCode
1310 . . . if 'Verbose quit
1311 . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",!
1312 . . . write " fixed...",!
1313 . . ;"if (fileNum=2)&(TMGVALUE=777) do quit ;"TEMP!!!!
1314 . . ;". set code=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(code="")
1315 . . ;". set TMGVALUE=69
1316 . . ;". xecute code
1317 . . new PtToGref set PtToGref="^"_$get(PtrsOUT(fileNum,fieldNum,"POINTS TO","GREF"))
1318 . . if PtToGref="" do quit
1319 . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)="??No reference for pointed to file??"
1320 . . . if 'Verbose quit
1321 . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Pointer value=[",TMGVALUE,"] but 'No reference for pointed to file (??)'",!
1322 . . set PtToGref=PtToGref_TMGVALUE_")"
1323 . . if $data(@PtToGref)'>0 do quit
1324 . . . set @pArray@(fileNum,@pTMGIEN,fieldNum)=TMGVALUE
1325 . . . new setCode set setCode=$get(PtrsOUT(fileNum,fieldNum,"X SET")) quit:(setCode="")
1326 . . . new priorValue set priorValue=TMGVALUE
1327 . . . set TMGVALUE=""
1328 . . . if 'AutoFix quit
1329 . . . xecute setCode
1330 . . . if 'Verbose quit
1331 . . . write !,"File=",fileNum,"; IEN=",@pTMGIEN,"; Field=",fieldNum,"; Bad Pointer value=[",priorValue,"]",!
1332 . . . write " fixed...",!
1333 if IENS="" do ProgressDone^TMGITR(.Itr)
1334 quit
1335
1336
1337ASKVFYPT ;"ASK VERIFY POINTERS
1338 ;"Ask user to pick file, then verify pointers for that file.
1339
1340 write "NOTICE: this function caused corruption of the database from",!
1341 write " deletion of pointers incorrectly. Until this function",!
1342 write " (ASKVFYPT^TMGFMUT) is fixed, it may not be used.",!,!
1343 do PressToCont^TMGUSRIF
1344 goto ASKDone
1345
1346
1347 new DIC,X,Y
1348 new FileNum,IEN
1349 new UseDefault set UseDefault=1
1350
1351 ;"Pick file to dump from
1352ASK1 set DIC=1
1353 set DIC(0)="AEQM"
1354 set DIC("A")="SELECT FILE TO VERIFY POINTERS IN: "
1355 if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called
1356 . do ^DICRW ;" has default value of user's last response
1357 else do ^DIC ;doesn't have default value...
1358 write !
1359 if +Y'>0 write ! goto ASKDone
1360 set FileNum=+Y
1361
1362 new BadPtrs
1363 new AutoFix,Verbose,%
1364 set %=2
1365 write "View details of scan" do YN^DICN write !
1366 if %=-1 goto ASKDone
1367 set Verbose=(%=1)
1368
1369 set %=2
1370 write "Auto-delete bad pointers (i.e. 0 value, or pointers to empty records)"
1371 do YN^DICN write !
1372 if %=-1 goto ASKDone
1373 set AutoFix=(%=1)
1374
1375 do VerifyPtrs(FileNum,"BadPtrs",Verbose,AutoFix)
1376
1377 if $data(BadPtrs) do
1378 . new % set %=2
1379 . write "View array of bad pointers" do YN^DICN write !
1380 . if %'=1 quit
1381 . do ArrayDump^TMGDEBUG("BadPtrs")
1382 else write "No bad pointers. Great!",!
1383
1384 do PressToCont^TMGUSRIF
1385
1386ASKDone
1387 quit
1388
1389GREP(FIELD,S)
1390 ;"The is a stub function, called by a Fileman Function (entry in file .5)
1391 new result
1392 set result="X1="_$get(FIELD)_" X2="_$get(S)_" D0="_$get(D0)_" DCC="_$get(DCC)
1393 merge ^TMG("TMP","KILL","DIQGEY")=DIQGEY
1394 set ^TMG("TMP","KILL","DA")=$get(DA)
1395 set ^TMG("TMP","KILL","DR")=$get(DR)
1396 set ^TMG("TMP","KILL","D0")=$get(D0)
1397 set ^TMG("TMP","KILL","DCC")=$get(DCC)
1398 QUIT result
1399
1400GETAPPT(TMGIEN)
1401 QUIT 0
1402
1403FMDate(DateStr)
1404 ;"Purpose: convert string to FM date, with extended syntax handling
1405 ;"Results: returns FM date, or -1 if error
1406 new result set result=-1
1407 ;"First try direct conversion
1408 new X,Y
1409 set DateStr=$$TRIM^XLFSTR($get(DateStr))
1410 if DateStr="" goto FMDDone
1411 for quit:(DateStr'[" ") set DateStr=$$Substitute^TMGSTUTL(DateStr," "," ")
1412 if (DateStr'["@")&($length(DateStr," ")>3) do
1413 . set DateStr=$piece(DateStr," ",1,3)_"@"_$piece(DateStr," ",4,99)
1414 for quit:(DateStr'["@ ") set DateStr=$$Substitute^TMGSTUTL(DateStr,"@ ","@")
1415 for quit:(DateStr'[" @") set DateStr=$$Substitute^TMGSTUTL(DateStr," @","@")
1416 set %DT="T",X=DateStr
1417 do ^%DT
1418 set result=Y
1419FMDDone quit result
Note: See TracBrowser for help on using the repository browser.