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

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

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