source: cprs/branches/tmg-cprs/m_files/TMGDEBUG.m.old@ 1548

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

Initial upload
File size: 26.0 KB
RevLine 
[796]1TMGDEBUG ;TMG/kst/Debug utilities: logging, record dump ;03/25/06
2 ;;1.0;TMG-LIB;**1**;07/12/05
3
4 ;"TMG DEBUG UTILITIES
5 ;"Kevin Toppenberg MD
6 ;"GNU General Public License (GPL) applies
7 ;"7-12-2005
8
9 ;"=======================================================================
10 ;" API -- Public Functions.
11 ;"=======================================================================
12 ;"$$GetDebugMode^TMGDEBUG(DefVal)
13 ;"OpenDefLogFile^TMGDEBUG
14 ;"OpenLogFile^TMGDEBUG(DefPath,DefName)
15 ;"DebugMsg^TMGDEBUG(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L)
16 ;"DebugWrite^TMGDEBUG(DBIndent,s,AddNewline)
17 ;"DebugIndent^TMGDEBUG(Num)
18 ;"ArrayDump^TMGDEBUG(ArrayP,index,indent)
19 ;"ASKANODES
20 ;"ArrayNodes(pArray)
21 ;"DebugEntry^TMGDEBUG((DBIndent,ProcName)
22 ;"DebugExit^TMGDEBUG(DBIndent,ProcName)
23 ;"ShowError^TMGDEBUG(PriorErrorFound,Error)
24 ;"$$GetErrStr^TMGDEBUG(ErrArray)
25 ;"ShowIfDIERR^TMGDEBUG(ErrMsg,PriorErrorFound) ;really same as below
26 ;"ShowDIERR^TMGDEBUG(ErrMsg,PriorErrorFound)
27 ;"ExpandLine(Pos)
28 ;"ASKDUMP -- A record dumper -- a little different from Fileman Inquire
29 ;"DumpRec(FileNum,IEN) -- dump (display) a record, using Fileman functionality.
30 ;"DumpRec2(FileNum,IEN,ShowEmpty) -- dump (display) a record, NOT Fileman's Inquire code
31
32 ;"=======================================================================
33 ;"Private API functions
34
35 ;"DumpRec2(FileNum,IEN,ShowEmpty)
36 ;"WriteRLabel(IEN,Ender)
37 ;"WriteFLabel(Label,Field,Type,Ender)
38 ;"WriteLine(Line)
39
40 ;"=======================================================================
41 ;"DEPENDENCIES
42 ;" TMGUSRIF
43
44 ;"Note: This module accesses custom file 22711, TMG UPLOAD SETTINGS
45 ;" It is OK if this file does not exist (i.e. on other computer systems.) However, the function
46 ;" OpenDefLogFile will fail to find a default specified file, and would not open a log file.
47 ;" Nothing is PUT INTO this file in this module. So new global would NOT be created.
48 ;"=======================================================================
49 ;"=======================================================================
50
51GetDebugMode(DefVal)
52 ;"Purpose: to ask if debug output desired
53 ;"Input: DefVal [optional] -- Default choice
54 ;"result: returns values as below
55 ;" 0, cdbNone - no debug
56 ;" 1, cdbToScrn - Debug output to screen
57 ;" 2, cdbToFile - Debug output to file
58 ;" 3, cdbToTail - Debug output to X tail dialog box.
59 ;" Note: 2-2-06 I am adding a mode (-1) which is EXTRA QUIET (used initially in ShowError)
60 ;"Note: This does not set up output streams etc, just gets preference.
61
62 new cdbNone set cdbNone=0
63 new cdbAbort set cdbAbort=0
64 new cdbToScrn set cdbToScrn=1 ;"was 2
65 new cdbToFile set cdbToFile=2 ;"was 3
66 new cdbToTail set cdbToTail=3 ;"was 4
67
68 new Input
69 new result set result=cdbNone ;"the default
70 new Default set Default=$get(DefVal,3)
71
72 write !,"Select debug output option:",!
73 write " '^'. Abort",!
74 write " 0. NO debug output",!
75 write " 1. Show debug output on screen",!
76 write " 2. Send debug output to file",!
77 if $get(DispMode(cDialog)) do
78 . write " 3. Show debug output in X tail dialog box.",!
79
80 write "Enter option number ("_Default_"): "
81 read Input,!
82
83 if Input="" do
84 . write "Defaulting to: ",Default,!
85 . set Input=Default
86
87 if Input="^" set result=cdbAbort
88 if Input=0 set result=cdbNone
89 if Input=1 set result=cdbToScrn
90 if Input=2 set result=cdbToFile
91 if Input=3 set result=cdbToTail
92
93GDMDone
94 quit result
95
96OpenDefLogFile
97 ;"Purpose: To open a default log file for debug output
98 ;"Results: none
99
100 new DefPath,DefName
101
102 set DefPath=$piece($get(^TMG(22711,1,2)),"^",1)
103 set DefName=$piece($get(^TMG(22711,1,1)),"^",1)
104
105 do OpenLogFile(.DefPath,.DefName)
106
107 quit
108
109
110OpenLogFile(DefPath,DefName)
111 ;"Purpose: To open a log file for debug output
112 ;"Input: DefPath -- the default path, like this: "/tmp/" <-- note trailing '/'
113 ;" DefName -- default file name (without path). e.g. "LogFile.tmp"
114 ;"Results: None
115
116 new DebugFPath set DebugFPath=$get(DefPath,"/tmp/")
117 new DebugFName set DebugFName=$get(DefName,"M_DebugLog.tmp")
118 if $get(TMGDEBUG)>1 do
119 . write "Note: Sending debug output to file: ",DebugFPath,DebugFName,!
120
121 ;"new DebugFile -- don't NEW here, needs to be global-scope
122 set DebugFile=DebugFPath_DebugFName
123 new FileSpec set FileSpec(DebugFile)=""
124
125 if +$piece($get(^TMG(22711,1,1)),"^",2)'=1 do
126 . ;"kill any pre-existing log
127 . new result
128 . set result=$$DEL^%ZISH(DebugFPath,$name(FileSpec)) ;"delete any preexisting one.
129
130 open DebugFile
131 use $PRINCIPAL
132
133 quit
134
135
136DebugMsg(DBIndent,Msg,A,B,C,D,E,F,G,H,I,J,K,L)
137 ;"PUBLIC FUNCTION
138 ;"Purpose: a debugging message output procedure
139 ;"Input:DBIndent -- the value of indentation expected
140 ;" Msg -- a string or value to show as message
141 ;" A..L -- extra values to show.
142 ;"
143 if $get(TMGDEBUG,0)=0 quit
144 set cTrue=$get(cTrue,1)
145 set DBIndent=$get(DBIndent,0)
146
147 set Msg=$get(Msg)
148 set Msg=Msg_$get(A)
149 set Msg=Msg_$get(B)
150 set Msg=Msg_$get(C)
151 set Msg=Msg_$get(D)
152 set Msg=Msg_$get(E)
153 set Msg=Msg_$get(F)
154 set Msg=Msg_$get(G)
155 set Msg=Msg_$get(H)
156 set Msg=Msg_$get(I)
157 set Msg=Msg_$get(J)
158 set Msg=Msg_$get(K)
159 set Msg=Msg_$get(L)
160 do DebugIndent(DBIndent)
161 do DebugWrite(DBIndent,.Msg,cTrue)
162
163 quit
164
165
166DebugWrite(DBIndent,s,AddNewline)
167 ;"PUBLIC FUNCTION
168 ;"Purpose: to write debug output. Having the proc separate will allow
169 ;" easier dump to file etc.
170 ;"Input:DBIndent, the amount of indentation expected for output.
171 ;" s -- the text to write
172 ;" AddNewline -- boolean, 1 if ! (i.e. newline) should be written after s
173
174 ;"Relevant DEBUG values
175 ;" cdbNone - no debug (0)
176 ;" cdbToScrn - Debug output to screen (1)
177 ;" cdbToFile - Debug output to file (2)
178 ;" cdbToTail - Debug output to X tail dialog box. (3)
179 ;"Note: If above values are not defined, then functionality will be ignored.
180
181
182 set cdbNone=$get(cdbNone,0)
183 set cdbToScrn=$get(cdbToScrn,1)
184 set cdbToFile=$get(cdbToFile,2)
185 set cdbToTail=$get(cdbToTail,3)
186 set TMGDEBUG=$get(TMGDEBUG,cdbNone)
187 if $get(TMGDEBUG)=cdbNone quit
188
189 if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do
190 . if $data(DebugFile) use DebugFile
191
192 new ch,chN,l,i
193 set l=$length(s)
194 for i=1:1:l do
195 . set ch=$extract(s,i)
196 . set chN=$ascii(ch)
197 . if (chN<32)&(chN'=13) write "<",chN,">"
198 . else write ch
199 ;"write s
200
201 set cTrue=$get(cTrue,1)
202 if $get(AddNewline)=cTrue write !
203
204 if (TMGDEBUG=$get(cdbToFile))!(TMGDEBUG=$get(cdbToTail)) do
205 . use $PRINCIPAL
206
207 quit
208
209
210DebugIndent(DBIndentForced)
211 ;"PUBLIC FUNCTION
212 ;"Purpose: to provide a unified indentation for debug messages
213 ;"Input: DBIndent = number of indentations
214 ;" Forced = 1 if to indent regardless of DEBUG mode
215
216 set Forced=$get(Forced,0)
217
218 if ($get(TMGDEBUG,0)=0)&(Forced=0) quit
219 new i
220 for i=1:1:DBIndent do
221 . if Forced do DebugWrite(DBIndent," ")
222 . else do DebugWrite(DBIndent,". ")
223 quit
224
225
226
227ArrayDump(ArrayP,TMGIDX,indent,flags)
228 ;"PUBLIC FUNCTION
229 ;"Purpose: to get a custom version of GTM's "zwr" command
230 ;"Input: Uses global scope var DBIndent (if defined)
231 ;" ArrayP: NAME of global or variable to display, i.e. "^VA(200)", "MyVar"
232 ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5) -- Optional
233 ;" indent: spacing from left margin to begin with. (A number. Each count is 2 spaces)
234 ;" OPTIONAL: indent may be an array, with information about columns
235 ;" to skip. For example:
236 ;" indent=3, indent(2)=0 --> show | for columns 1 & 3, but NOT 2
237 ;" flags: OPTIONAL. "F"-> flat (don't use tre structure)
238 ;"Result: none
239
240 ;"--Leave out, this calls itself recursively! do DebugEntry("ArrayDump")
241 ;"--Leave out, this calls itself recursively! do DebugMsg^TMGDEBUG("ArrayP=",ArrayP,", TMGIDX=",index)
242
243 if $data(ArrayP)=0 quit
244
245 if $get(flags)["F" do goto ADDone
246 . new ref set ref=ArrayP
247 . new nNums set nNums=$qlength(ref)
248 . new lValue set lValue=$qsubscript(ref,nNums)
249 . write ref,"=""",$get(@ref),"""",!
250 . for set ref=$query(@ref) quit:(ref="")!($qsubscript(ref,nNums)'=lValue) do
251 . . write ref,"=""",$get(@ref),"""",!
252
253 ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes.
254 new X set X="SET TEMP=$GET("_ArrayP_")"
255 set X=$$UP^XLFSTR(X)
256 do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference.
257 if $get(X)="" quit
258
259 set DBIndent=$get(DBIndent,0)
260 set cTrue=$get(cTrue,1)
261 set cFalse=$get(cFalse,0)
262
263 ;"Force this function to output, even if TMGDEBUG is not defined.
264 ;"if $data(TMGDEBUG)=0 new TMGDEBUG ;"//kt 1-16-06, doesn't seem to be working
265 new TMGDEBUG ;"//kt added 1-16-06
266 set TMGDEBUG=1
267
268 new ChildP,TMGi
269
270 set TMGIDX=$get(TMGIDX,"")
271 set indent=$get(indent,0)
272 new SavIndex set SavIndex=TMGIDX
273
274 do DebugIndent(DBIndent)
275
276 if indent>0 do
277 . for TMGi=1:1:indent-1 do
278 . . new s set s=""
279 . . if $get(indent(TMGi),-1)=0 set s=" "
280 . . else set s="| "
281 . . do DebugWrite(DBIndent,s)
282 . do DebugWrite(DBIndent,"}~")
283
284 if TMGIDX'="" do
285 . if $data(@ArrayP@(TMGIDX))#10=1 do
286 . . new s set s=@ArrayP@(TMGIDX)
287 . . if s="" set s=""""""
288 . . new qt set qt=""
289 . . if +TMGIDX'=TMGIDX set qt=""""
290 . . do DebugWrite(DBIndent,qt_TMGIDX_qt_" = "_s,cTrue)
291 . else do
292 . . do DebugWrite(DBIndent,TMGIDX,1)
293 . set ArrayP=$name(@ArrayP@(TMGIDX))
294 else do
295 . ;"do DebugWrite(DBIndent,ArrayP_"(*)",cFalse)
296 . do DebugWrite(DBIndent,ArrayP,cFalse)
297 . if $data(@ArrayP)#10=1 do
298 . . do DebugWrite(0,"="_$get(@ArrayP),cFalse)
299 . do DebugWrite(0,"",cTrue)
300
301 set TMGIDX=$order(@ArrayP@(""))
302 if TMGIDX="" goto ADDone
303 set indent=indent+1
304
305 for do quit:TMGIDX=""
306 . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX))
307 . if tTMGIDX="" set indent(indent)=0
308 . new tIndent merge tIndent=indent
309 . do ArrayDump(ArrayP,TMGIDX,.tIndent) ;"Call self recursively
310 . set TMGIDX=$order(@ArrayP@(TMGIDX))
311
312 ;"Put in a blank space at end of subbranch
313 do DebugIndent(DBIndent)
314
315 if indent>0 do
316 . for TMGi=1:1:indent-1 do
317 . . new s set s=""
318 . . if $get(indent(TMGi),-1)=0 set s=" "
319 . . else set s="| "
320 . . do DebugWrite(DBIndent,s)
321 . do DebugWrite(DBIndent," ",1)
322
323ADDone
324 ;"--Leave out, this calls itself recursively! do DebugExit("ArrayDump")
325 quit
326
327
328ASKANODES
329 ;"Purpose: to ask user for the name of an array, then display nodes
330
331 new name
332 write !
333 read "Enter name of array to display nodes in: ",name,!
334 if name="^" set name=""
335 if name'="" do ArrayNodes(name)
336 quit
337
338
339ArrayNodes(pArray)
340 ;"Purpose: To display all the nodes of the given array
341 ;"Input: pArray -- NAME OF array to display
342
343 new TMGi
344
345 write pArray,!
346 set TMGi=$order(@pArray@(""))
347 if TMGi'="" for do quit:(TMGi="")
348 . write " +--(",TMGi,")",!
349 . set TMGi=$order(@pArray@(TMGi))
350
351 quit
352
353DebugEntry(DBIndent,ProcName)
354 ;"PUBLIC FUNCTION
355 ;"Purpose: A way to show when entering a procedure, in debug mode
356 ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE
357 ;" ProcName: any arbitrary name to show when decreasing indent amount.
358
359 set ProcName=$get(ProcName,"?")
360 set DBIndent=$get(DBIndent,0)
361 do DebugMsg(DBIndent,ProcName_" {")
362 set DBIndent=DBIndent+1
363 quit
364
365
366DebugExit(DBIndent,ProcName)
367 ;"PUBLIC FUNCTION
368 ;"Purpose: A way to show when leaving a procedure, in debug mode
369 ;"Input: DBIndent, a variable to keep track of indentation amount--PASS BY REFERENCE
370 ;" ProcName: any arbitrary name to show when decreasing indent amount.
371
372 ;"write "DBIndent=",DBIndent,!
373 ;"write "ProcName=",ProcName,!
374 set ProcName=$get(ProcName,"?")
375 set DBIndent=$get(DBIndent)-1
376 if DBIndent<0 set DBIndent=0
377 do DebugMsg(DBIndent,"} //"_ProcName)
378
379 quit
380
381
382
383
384ShowError(PriorErrorFound,Error)
385 ;"Purpose: to output an error message
386 ;"Input: [OPTIONAL] PriorErrorFound -- var to see if an error already shown.
387 ;" if not passed, then default value used ('no prior error')
388 ;" Error -- a string to display
389 ;"results: none
390
391 if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely
392
393 if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowError")
394 if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error msg=",Error)
395
396 if $get(PriorErrorFound,0) do goto ShErrQuit ;"Remove to show cascading errors
397 . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Prior error found, so won't show this error.")
398
399 if $data(DBIndent)=0 new DBIndent ;"If it wasn't global before, keep it that way.
400 new SaveIndent set SaveIndent=$get(DBIndent)
401 set DBIndent=1
402 do PopupBox^TMGUSRIF("<!> ERROR . . .",Error)
403 set PriorErrorFound=1
404 set DBIndent=SaveIndent
405
406ShErrQuit
407 if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowError")
408
409 quit
410
411
412GetErrStr(ErrArray)
413 ;"Purpose: convert a standard DIERR array into a string for output
414 ;"Input: ErrArray -- PASS BY REFERENCE. example:
415 ;" array("DIERR")="1^1"
416 ;" array("DIERR",1)=311
417 ;" array("DIERR",1,"PARAM",0)=3
418 ;" array("DIERR",1,"PARAM","FIELD")=.02
419 ;" array("DIERR",1,"PARAM","FILE")=2
420 ;" array("DIERR",1,"PARAM","IENS")="+1,"
421 ;" array("DIERR",1,"TEXT",1)="The new record '+1,' lacks some required identifiers."
422 ;" array("DIERR","E",311,1)=""
423 ;"Results: returns one long equivalent string from above array.
424
425 new ErrStr
426 new TMGIDX
427 new ErrNum
428
429 set ErrStr=""
430 for ErrNum=1:1:+$get(ErrArray("DIERR")) do
431 . set ErrStr=ErrStr_"Fileman says: '"
432 . if ErrNum'=1 set ErrStr=ErrStr_"(Error# "_ErrNum_") "
433 . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",""))
434 . if TMGIDX'="" for do quit:(TMGIDX="")
435 . . set ErrStr=ErrStr_$get(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))_" "
436 . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"TEXT",TMGIDX))
437 . if $get(ErrArray("DIERR",ErrNum,"PARAM",0))>0 do
438 . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",0))
439 . . set ErrStr=ErrStr_"Details: "
440 . . for do quit:(TMGIDX="")
441 . . . if TMGIDX="" quit
442 . . . set ErrStr=ErrStr_"["_TMGIDX_"]="_$get(ErrArray("DIERR",1,"PARAM",TMGIDX))_" "
443 . . . set TMGIDX=$order(ErrArray("DIERR",ErrNum,"PARAM",TMGIDX))
444
445 quit ErrStr
446
447
448
449ShowIfDIERR(ErrMsg,PriorErrorFound) ;"really same as below
450 goto SEL1
451
452ShowDIERR(ErrMsg,PriorErrorFound)
453 ;"Purpose: To provide a standard output mechanism for the fileman DIERR message
454 ;"Input: ErrMsg -- PASS BY REFERENCE. a standard error message array, as
455 ;" put out by fileman calls
456 ;" PriorErrorFound -- OPTIONAL variable to keep track if prior error found.
457 ;" Note -- can also be used as ErrorFound (i.e. set to 1 if error found)
458 ;"Output -- none
459 ;"Result -- none
460
461SEL1
462 if $get(TMGDEBUG)=-1 quit ;"EXTRA QUIET mode --> skip entirely
463
464 if $get(TMGDEBUG)>0 do DebugEntry(.DBIndent,"ShowDIERR")
465
466 if $data(ErrMsg("DIERR")) do
467 . if $get(TMGDEBUG)>0 do DebugMsg(.DBIndent,"Error message found. Here is array:")
468 . if $get(TMGDEBUG) do ArrayDump("ErrMsg")
469 . new ErrStr
470 . set ErrStr=$$GetErrStr(.ErrMsg)
471 . do ShowError(.PriorErrorFound,.ErrStr)
472
473 if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowDIERR")
474 quit
475
476ExpandLine(Pos)
477 ;"Purpose: to expand a line of code, found at position "Pos", using ^XINDX8 functionality
478 ;"Input: Pos: a position as returned by $ZPOS (e.g. G+5^DIS, or +23^DIS)
479 ;"Output: Writes to the currently selecte IO device and expansion of one line of code
480 ;"Note: This is used for taking the very long lines of code, as found in Fileman, and
481 ;" convert them to a format with one command on each line.
482 ;" Note: it appears to do syntax checking and shows ERROR if syntax is not per VA
483 ;" conventions--such as commands must be UPPERCASE etc.
484
485 ;"--- copied and modified from XINDX8.m ---
486
487 kill ^UTILITY($J)
488
489 new label,offset,RTN,dmod
490 do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod)
491 if label'="" do ;"change position from one relative to label into one relative to top of file
492 . new CodeArray
493 . set Pos=$$ConvertPos^TMGMISC(Pos,"CodeArray")
494 . do ParsePos^TMGMISC(Pos,.label,.offset,.RTN,.dmod)
495
496 if RTN="" goto ELDone
497
498 do BUILD^XINDX7
499 set ^UTILITY($J,RTN)=""
500 do LOAD^XINDEX
501 set CCN=0
502 for I=1:1:+^UTILITY($J,1,RTN,0,0) S CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2
503 set ^UTILITY($J,1,RTN,0)=CCN
504 ;"do ^XINDX8 -- included below
505
506 new Q,DDOT,LO,PG,LIN,ML,IDT
507 new tIOSL set tIOSL=IOSL
508 set IOSL=999999 ;"really long 'page length' prevents header printout (and error)
509
510 set Q=""""
511 set DDOT=0
512 set LO=0
513 set PG=+$G(PG)
514
515 set LC=offset
516 if $D(^UTILITY($J,1,RTN,0,LC)) do
517 . S LIN=^(LC,0),ML=0,IDT=10
518 . set LO=LC-1
519 . D CD^XINDX8
520
521 K AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY
522
523 set IOSL=tIOSL ;"restore saved IOSL
524ELDone
525 quit
526
527
528DumpRec(FileNum,IEN)
529 ;"Purpose: to dump (display) a record, using Fileman functionality.
530 ;"Input: FileNum -- the number of the file to dump from
531 ;" IEN -- the record number to display
532 ;"Note: this code is modified from INQ^DII
533
534 new DIC,X,Y,DI,DPP,DK,DICSS
535
536 set X=FileNum,Y=X
537
538 set DI=$get(^DIC(FileNum,0,"GL")) if DI="" quit
539 set DPP(1)=FileNum_"^^^@"
540 set DK=FileNum
541
542 K ^UTILITY($J),^(U,$J),DIC,DIQ,DISV,DIBT,DICS
543
544 set DIK=1
545 set ^UTILITY(U,$J,DIK,IEN)="" ;"<-- note, to have multiple IEN's shown, iterate via DIK
546
547 do S^DII ;"Jump into Fileman code.
548
549 quit
550
551
552xASKDUMP
553 ;"Purpose: A record dumper -- a little different from Fileman Inquire
554
555 new DIC,X,Y
556 new FileNum,IEN
557 new UseDefault set UseDefault=1
558
559 ;"Pick file to dump from
560xASK1 set DIC=1
561 set DIC(0)="AEQM"
562 if UseDefault do ;"leave the redundant do loop, it protects $T, so second do ^DIC isn't called
563 . do ^DICRW ;" has default value of user's last response
564 else do ^DIC ;doesn't have default value...
565 if +Y'>0 write ! goto xASKDone
566 set FileNum=+Y
567
568 ;"Pick record to dump
569xASKLOOP kill DIC,X
570 set DIC=+FileNum
571 set DIC(0)="AEQM"
572 do ^DIC write !
573 if +Y'>0 set UseDefault=0 goto xASK1
574 set IEN=+Y
575
576 new % set %=2
577 write "Display empty fields"
578 do YN^DICN
579 if %=-1 write ! goto xASKDone
580
581 new %ZIS
582 set %ZIS("A")="Enter Output Device: "
583 set %ZIS("B")="HOME"
584 do ^%ZIS ;"standard device call
585 if POP do goto xASKDone
586 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.")
587 use IO
588
589 ;"Do the output
590 write !
591 do DumpRec2(FileNum,IEN,(%=1))
592
593 ;" Close the output device
594 do ^%ZISC
595
596 new temp
597 read "Press [ENTER] to continue...",temp:$get(DTIME,3600),!
598
599 goto xASKLOOP
600
601xASKDone
602 quit
603
604ASKDUMP
605 ;"Purpose: A record dumper -- a little different from Fileman Inquire
606
607 write !!," -= RECORD DUMPER =-",!
608 new FIENS,IENS
609AL1
610 set FIENS=$$AskFIENS^TMGDBAPI()
611 if (FIENS["?")!(FIENS="^") goto ASKDone
612
613 set FileNum=$piece(FIENS,"^",1)
614 set IENS=$piece(FIENS,"^",2)
615
616AL2
617 set IENS=$$AskIENS^TMGDBAPI(FileNum,IENS)
618 if (IENS["?")!(IENS="") goto AL1
619
620 new % set %=2
621 write "Display empty fields"
622 do YN^DICN
623 if %=-1 write ! goto ASKDone
624
625 new %ZIS
626 set %ZIS("A")="Enter Output Device: "
627 set %ZIS("B")="HOME"
628 do ^%ZIS ;"standard device call
629 if POP do goto ASKDone
630 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.")
631 use IO
632
633 ;"Do the output
634 write ! do DumpRec2(FileNum,IENS,(%=1))
635
636 ;" Close the output device
637 do ^%ZISC
638
639 do PressToCont^TMGUSRIF
640 ;"new temp
641 ;"read "Press [ENTER] to continue...",temp:$get(DTIME,3600),!
642
643 set IENS=$piece(IENS,",",2,99) ;"force Pick of new record to dump
644 if +IENS>0 goto AL2
645 goto AL1
646
647ASKDone
648 quit
649
650
651DumpRec2(FileNum,IENS,ShowEmpty,FieldsArray)
652 ;"Purpose: to dump (display) a record, NOT using ^DII (Fileman's Inquire code)
653 ;"Input: FileNum -- the number of the file to dump from
654 ;" IENS -- the record number to display (or IENS: #,#,#,)
655 ;" ShowEmpty -- OPTIONAL; if 1 then empty fields will be displayed
656 ;" FieldsArray -- OPTIONAL. PASS BY REFERENCE.
657 ;" Allows user to specify which fields to show. Format:
658 ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number
659 ;" FieldsArray(FieldtoShow)="" <-- FieldtoShow is name or number
660 ;" Default is an empty array, in which all fields are considered
661
662 new Fields
663 set Fields("*")=""
664 new flags set flags="i"
665 if $get(ShowEmpty)=1 set flags=flags_"b"
666
667 write "Record# ",IENS,!
668
669 new field,fieldName
670 if $data(FieldsArray)=0 do
671 . set field=$order(^DD(FileNum,0))
672 . if +field>0 for do quit:(+field'>0)
673 . . set fieldName=$piece(^DD(FileNum,field,0),"^",1)
674 . . set Fields("TAG NAME",field)=fieldName_"("_field_")"
675 . . set field=$order(^DD(FileNum,field))
676 else do ;"Handle case of showing ONLY requested fields
677 . new temp set temp=""
678 . for set temp=$order(FieldsArray(temp)) quit:(temp="") do
679 . . if +temp=temp do
680 . . . set field=+temp
681 . . . set fieldName=$piece(^DD(FileNum,field,0),"^",1)
682 . . else do
683 . . . set fieldName=temp
684 . . . if $$SetFileFldNums^TMGDBAPI(FileNum,fieldName,,.field)=0 quit
685 . . set Fields("TAG NAME",field)=fieldName_"("_field_")"
686 . ;"Now exclude those fields not specifically included
687 . set field=0
688 . for set field=$order(^DD(FileNum,field)) quit:(+field'>0) do
689 . . if $data(Fields("TAG NAME",field))'=0 quit
690 . . set fieldName=$piece(^DD(FileNum,field,0),"^",1)
691 . . set Fields("Field Exclude",field)=""
692
693 new RFn,FFn,LFn,WPLFn
694 set RFn="WriteRLabel^TMGDEBUG"
695 set FFn="WriteFLabel^TMGDEBUG"
696 set LFn="WriteLine^TMGDEBUG"
697 set WPLFn="WriteWPLine^TMGDEBUG"
698
699 ;"write "Using flags (options): ",flags,!
700
701 if +IENS=IENS do
702 . do Write1Rec^TMGXMLE2(FileNum,IENS,.Fields,flags,,,"",RFn,FFn,LFn,WPLFn)
703 else do ;"dump a subfile record
704 . do Write1Rec^TMGXMLE2(FileNum,+IENS,.Fields,flags,,IENS,"",RFn,FFn,LFn,WPLFn)
705
706 quit
707
708
709WriteRLabel(IEN,Ender)
710 ;"Purpose: To actually write out labels for record starting and ending.
711 ;" IEN -- the IEN (record number) of the record
712 ;" Ender -- OPTIONAL if 1, then ends field.
713 ;"Results: none.
714 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
715
716 if +$get(Ender)>0 write !
717 else write " Multiple Entry #",IEN,"",!
718
719 quit
720
721
722WriteFLabel(Label,Field,Type,Ender)
723 ;"Purpose: This is the code that actually does writing of labels etc for output
724 ;" This is a CUSTOM CALL BACK function called by Write1Fld^TMGXMLE2
725 ;"Input: Label -- OPTIONAL -- Name of label, to write after 'label='
726 ;" Field -- OPTIONAL -- Name of field, to write after 'id='
727 ;" Type -- OPTIONAL -- Typeof field, to write after 'type='
728 ;" Ender -- OPTIONAL if 1, then ends field.
729 ;"Results: none.
730 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
731
732 ;"To write out <Field label="NAME" id=".01" type="FREE TEXT"> or </Field>
733
734 if +$get(Ender)>0 do
735 . write !
736 else do
737 . new s set s=Field
738 . if $get(Field)'="" write $$RJ^XLFSTR(.s,6," "),"-"
739 . if $get(Label)'="" write Label," "
740 . ;"if $get(Type)'="" write "type=""",Type,""" "
741 . write ": "
742
743 quit
744
745
746WriteLine(Line)
747 ;"Purpose: To actually write out labels for record starting and ending.
748 ;"Input: Line -- The line of text to be written out.
749 ;"Results: none.
750 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
751
752 write line
753 quit
754
755
756WriteWPLine(Line)
757 ;"Purpose: To actually write out line from WP field
758 ;"Input: Line -- The line of text to be written out.
759 ;"Results: none.
760 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
761
762 write line,!
763 quit
764
Note: See TracBrowser for help on using the repository browser.