[894] | 1 | TMGDEBUG ;TMG/kst/Debug utilities: logging, record dump ;03/25/06, 7/11/10
|
---|
[796] | 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)
|
---|
[894] | 24 | ;"$$FMERRSTR(ERRARRAY) -- same as $$GetErrStr()
|
---|
[796] | 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 |
|
---|
| 52 | GetDebugMode(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 |
|
---|
| 94 | GDMDone
|
---|
| 95 | quit result
|
---|
| 96 |
|
---|
| 97 | OpenDefLogFile
|
---|
| 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 |
|
---|
| 111 | OpenLogFile(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 |
|
---|
| 137 | DebugMsg(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 |
|
---|
| 167 | DebugWrite(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 |
|
---|
| 211 | DebugIndent(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 |
|
---|
| 228 | ArrayDump(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 |
|
---|
| 324 | ADDone
|
---|
| 325 | ;"--Leave out, this calls itself recursively! do DebugExit("ArrayDump")
|
---|
| 326 | quit
|
---|
| 327 |
|
---|
| 328 |
|
---|
| 329 | ASKANODES
|
---|
| 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 |
|
---|
| 340 | ArrayNodes(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 |
|
---|
| 354 | DebugEntry(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 |
|
---|
| 367 | DebugExit(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 |
|
---|
| 385 | ShowError(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 |
|
---|
| 407 | ShErrQuit
|
---|
| 408 | if $get(TMGDEBUG)>0 do DebugExit(.DBIndent,"ShowError")
|
---|
| 409 |
|
---|
| 410 | quit
|
---|
| 411 |
|
---|
| 412 |
|
---|
[894] | 413 | FMERRSTR(ERRARRAY)
|
---|
| 414 | QUIT $$GetErrStr(.ERRARRAY)
|
---|
| 415 | ;
|
---|
[796] | 416 | GetErrStr(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 |
|
---|
| 453 | ShowIfDIERR(ErrMsg,PriorErrorFound) ;"really same as below
|
---|
| 454 | goto SEL1
|
---|
| 455 |
|
---|
| 456 | ShowDIERR(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 |
|
---|
| 465 | SEL1
|
---|
| 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 |
|
---|
| 480 | ExpandLine(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
|
---|
| 528 | ELDone
|
---|
| 529 | quit
|
---|
| 530 |
|
---|
| 531 |
|
---|
| 532 | DumpRec(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 |
|
---|
| 556 | xASKDUMP
|
---|
| 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
|
---|
| 564 | xASK1 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
|
---|
| 573 | xASKLOOP 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 |
|
---|
| 605 | xASKDone
|
---|
| 606 | quit
|
---|
| 607 |
|
---|
| 608 | ASKDUMP
|
---|
| 609 | ;"Purpose: A record dumper -- a little different from Fileman Inquire
|
---|
| 610 |
|
---|
| 611 | write !!," -= RECORD DUMPER =-",!
|
---|
| 612 | new FIENS,IENS
|
---|
| 613 | AL1
|
---|
| 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 |
|
---|
| 620 | AL2
|
---|
| 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 |
|
---|
| 651 | ASKDone
|
---|
| 652 | quit
|
---|
| 653 |
|
---|
| 654 |
|
---|
| 655 | DumpRec2(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 |
|
---|
| 713 | WriteRLabel(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 |
|
---|
| 726 | WriteFLabel(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 |
|
---|
| 750 | WriteLine(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 |
|
---|
| 760 | WriteWPLine(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 |
|
---|