XTER1 ;ISC-SF.SEA/JLI - Kernel Error Trap Display ;09/27/10 15:31
;;8.0;KERNEL;**8,392,431**;Jul 10, 1995;Build 35
;Per VHA Directive 2004-038, this routine should not be modified.
S XTDV1=0
WRT S XTOUT=0 S:'$D(XTBLNK) $P(XTBLNK," ",133)=" " S:'$D(C) C=0 K:C=0 ^TMP($J,"XTER")
D DV
I '$D(%XTZLIN) S %XTY=$P(%XTZE,","),%XTX=$P(%XTY,"^") S:%XTX[">" %XTX=$P(%XTX,">",2)
I '$D(%XTZLIN),%XTX'="" S X=$P($P(%XTY,"^",2),":") I X'="" X ^%ZOSF("TEST") I $T D
. N XCNP,DIF
. S XCNP=0,DIF="^TMP($J,""XTER1""," X ^%ZOSF("LOAD") S %XTY=$P(%XTX,"+",1) D
. . I %XTY'="" F X=0:0 S X=$O(^TMP($J,"XTER1",X)) Q:X'>0 I $P(^(X,0)," ")=%XTY S X=X+$P(%XTX,"+",2),%XTZLIN=^TMP($J,"XTER1",X,0) Q
. . I %XTY="" S X=+$P(%XTX,"+",2) Q:X'>0 S %XTZLIN=^TMP($J,"XTER1",X,0)
S:'$D(%XTZLIN) %XTZLIN="" K ^TMP($J,"XTER1")
I %XTZLIN'="" D ADD(""),ADD(%XTZLIN)
;I '$D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B")) F XTI=0:0 S XTI=$O(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI)) Q:XTI'>0 S XTSYM=^(XTI,0),^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTSYM,XTI)=""
I '$D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B")) D ;p431
. F XTI=0:0 S XTI=$O(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI)) Q:XTI'>0 S XTSYM=$P(^(XTI,0),"(") S:'$D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTSYM)) ^(XTSYM,XTI)=""
;I IO'=IO(0) S XTDV1=0 D DV ;p431
D:'$G(XTMES)&'$G(XTPRNT) WRITER^XTER1A
I IO'="",IO'=IO(0)!$G(XTPRNT) U IO W:$E($G(IOST))="C" @IOF S X="^L" G WRTA
I $G(XTMES) S X="^L" G WRTA
;
K ^TMP($J,"XTER") S C=0
R !!,"Which symbol? > ",XTX:DTIME S:'$T!(XTX="") XTX="^"
S:$E(XTX,1)="^" XTX=$TR(XTX,"ilmpqr","ILMPQR") ;uppercase
G XTERR^XTER:XTX>0!(XTX="^"),END^XTER:XTX="^Q",MESG^XTER1A:XTX="^M",PRNT^XTER1A:XTX="^P" S X=XTX,XTX="",XTOUT=0
I X="^I" D EN^XTER1B G WRT
I X["?" S XTF="1,2,10,7,13,14,15,8,9" D HELP^XTER G WRT
I X="$" S XTDV1=0 D DV G WRT
I X="^R" G RESTOR^XTER2
;
WRTA ;Show All (^L)
D WRT1 S:'$D(XTX) XTX=""
Q:$G(XTMES)!$G(XTPRNT) G:IO=IO(0)&(XTX'="^Q")&(XTX'="^q") WRT
U IO(0) G END^XTER:XTX="^Q"!(XTX="^q"),XTERR^XTER
;
WRT1 ;
S:'$D(IOSL) IOSL=24 D ADD(""),ADD("")
S XTSYM=$S(X="^L":"",1:X),%XTYL=IOSL-4,XTI=0,XTC=1,X="",XTA=XTSYM,XTA=$S(XTA="":"",1:$E(XTA,1,$L(XTA)-1)_$C($A($E(XTA,$L(XTA)))-1)_"z")
;Find start by order thru B X-ref for Symbols, XTA=var name, XTB=var value
WF S:'%XTYL %XTYL=IOSL-4
;S (XTA,XTA1)=$O(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTA)) S XTI=$S(XTSYM="":1,XTA'="":$O(^(XTA,0)),1:0)
S XTA=$O(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTA)) S XTI=$S(XTSYM="":1,XTA'="":$O(^(XTA,0)),1:0) ;p431
I XTA=""!(XTSYM'=""&($E(XTA,1,$L(XTSYM))'=XTSYM)) D:XTSYM'=""&XTC ADD("No such symbol") D:'$G(XTPRNT) MORE^XTER1A Q
S (XTA,XTA1)=^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI,0) ;p431
D WV
;Show the rest in order
F S XTI=$O(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI)) Q:'XTI!(XTOUT) S (XTA,XTA1)=^(XTI,0) Q:$E(XTA,1,$L(XTSYM))'=XTSYM D WV
Q
WV ;Write a variable
S:'%XTYL %XTYL=IOSL-4
S XTB=$S($D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI,"D")):^("D"),1:"*** WARNING: this value was NOT recorded due to an ERROR WITHIN the TRAP ***")
;Check for long variables
S XTL=$G(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI,"L")) I XTL>255 D ADD("**The following variables length is "_XTL_", only displaying first 255.**")
S XTC=0 S:'$G(XTMES)&'$G(XTPRNT) %XTYL=%XTYL-1
D:'%XTYL MORE^XTER1A Q:XTOUT D:'%XTYL ADD("")
S XTA1=XTA1_"=" K XTC1 I XTB?.PUNL,XTB'["\" S XTA1=XTA1_XTB,XTC1=""
;Change control char to \027 format
I '$D(XTC1) S XTC1="" I $P(XTA1," ",2)="" F XTK=1:1 S XTZ=$E(XTB,XTK) Q:XTZ="" S XTC1=XTC1_$S(XTZ'?1C:XTZ,1:"\"_$E($A(XTZ)+1000,2,4)) I XTZ="\" S XTC1=XTC1_"\"
D SET D:XTL>255 ADD("**")
Q
;
SET ;
I ($L(XTA1)+$L(XTC1))<246 S XTA1=XTA1_XTC1,XTC1="" D ADD(XTA1) Q
I $L(XTA1)>245 D ADD($E(XTA1,1,245)) S XTA1=$E(XTA1,246,$L(XTA1)) G SET
I $L(XTA1)>0 D ADD(XTA1_$E(XTC1,1,(245-$L(XTA1)))) S XTC1=$E(XTC1,(245-$L(XTA1)+1),$L(XTC1)) G SET
D ADD($E(XTC1,1,245)) S XTC1=$E(XTC1,246,$L(XTC1)) G SET
Q
;
ADD(STR) ;Add STR to TMP global
S C=C+1,^TMP($J,"XTER",C)=STR
Q
;Header info
DV I $D(XTDV1),XTDV1=1 G DV1
K %XTZLIN
S %XTZE=^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZE"),%XTJOB=$G(^("J")),%XTIO=$G(^("I")),%XTZH=$G(^("ZH")),%XTZH1=$G(^("H")),%XTZGR=$G(^("GR")) S:$D(^("LINE")) %XTZLIN=^("LINE")
I %XTZH1>0 S %H=%XTZH1 D YMD^%DTC S Y=X_% D DD^%DT S $P(%XTZH1,"^",2)=$P(Y,"@",1)_" "_$P(Y,"@",2)
F %XTI=1:1:9 S %XTZH(%XTI)=$P(%XTZH,"^",%XTI)
S %XTZH(3)=$P(%XTZH1,U,2)
S %XTUCI=$P(%XTJOB,U,4)
;Build output
S X="Process ID: "_$P(%XTJOB,U,5)_" ("_$P(%XTJOB,U)_")",X=X_$E(XTBLNK,1,40-$L(X))_%XTZH(3)
D ADD(""),ADD(X)
S %XTZ="Username\Process Name\UCI/VOL\\$ZA\$ZB\Current $IO\Current $ZIO\CPU time\Page Faults\Direct I/O\Buffered I/O"
S %XTZ(1)=$P(%XTJOB,U,3),%XTZ(2)=$P(%XTJOB,U,2),%XTZ(3)=$S(%XTUCI]"":"["_%XTUCI_"]",1:"")
S %XTZ(4)="",%XTZ(5)=$J($P(%XTIO,U,2),3),%XTZ(6)=$J($P(%XTIO,U,3),3)
S %XTZ(7)=$P(%XTIO,U),%XTZ(8)=$P(%XTIO,U,4,99),%XTZ(9)=$J(%XTZH(1),6)
S %XTZ(10)=$J(%XTZH(4),10),%XTZ(11)=$J(%XTZH(7),10),%XTZ(12)=$J(%XTZH(8),10)
F %XTI=1:1:12 D
. I %XTI#2 S X=""
. S:%XTZ(%XTI)'?." " X=X_$P(%XTZ,"\",%XTI)_": "_%XTZ(%XTI) S:%XTI#2 X=$E(X_$E(XTBLNK,1,40),1,40)
. I '(%XTI#2),X'?." " D ADD(""),ADD(X)
. Q
DV1 S XTDV1=1 D ADD(""),ADD("$ZE= "_%XTZE)
D:%XTZGR'="" ADD(""),ADD("Last Global Ref: "_%XTZGR) ;p431
K X I $D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZE2")) S X=^("ZE2")
I $D(X) D ADD(""),ADD("%ZTER encountered an error while logging this error -- "),ADD("This may have caused some LOCAL VARIABLES to be lost."),ADD("This error was: "_X)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTER1 5529 printed Dec 13, 2024@02:40:44 Page 2
XTER1 ;ISC-SF.SEA/JLI - Kernel Error Trap Display ;09/27/10 15:31
+1 ;;8.0;KERNEL;**8,392,431**;Jul 10, 1995;Build 35
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 SET XTDV1=0
WRT SET XTOUT=0
if '$DATA(XTBLNK)
SET $PIECE(XTBLNK," ",133)=" "
if '$DATA(C)
SET C=0
if C=0
KILL ^TMP($JOB,"XTER")
+1 DO DV
+2 IF '$DATA(%XTZLIN)
SET %XTY=$PIECE(%XTZE,",")
SET %XTX=$PIECE(%XTY,"^")
if %XTX[">"
SET %XTX=$PIECE(%XTX,">",2)
+3 IF '$DATA(%XTZLIN)
IF %XTX'=""
SET X=$PIECE($PIECE(%XTY,"^",2),":")
IF X'=""
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+4 NEW XCNP,DIF
+5 SET XCNP=0
SET DIF="^TMP($J,""XTER1"","
XECUTE ^%ZOSF("LOAD")
SET %XTY=$PIECE(%XTX,"+",1)
Begin DoDot:2
+6 IF %XTY'=""
FOR X=0:0
SET X=$ORDER(^TMP($JOB,"XTER1",X))
if X'>0
QUIT
IF $PIECE(^(X,0)," ")=%XTY
SET X=X+$PIECE(%XTX,"+",2)
SET %XTZLIN=^TMP($JOB,"XTER1",X,0)
QUIT
+7 IF %XTY=""
SET X=+$PIECE(%XTX,"+",2)
if X'>0
QUIT
SET %XTZLIN=^TMP($JOB,"XTER1",X,0)
End DoDot:2
End DoDot:1
+8 if '$DATA(%XTZLIN)
SET %XTZLIN=""
KILL ^TMP($JOB,"XTER1")
+9 IF %XTZLIN'=""
DO ADD("")
DO ADD(%XTZLIN)
+10 ;I '$D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B")) F XTI=0:0 S XTI=$O(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI)) Q:XTI'>0 S XTSYM=^(XTI,0),^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTSYM,XTI)=""
+11 ;p431
IF '$DATA(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B"))
Begin DoDot:1
+12 FOR XTI=0:0
SET XTI=$ORDER(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI))
if XTI'>0
QUIT
SET XTSYM=$PIECE(^(XTI,0),"(")
if '$DATA(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTSYM))
SET ^(XTSYM,XTI)=""
End DoDot:1
+13 ;I IO'=IO(0) S XTDV1=0 D DV ;p431
+14 if '$GET(XTMES)&'$GET(XTPRNT)
DO WRITER^XTER1A
+15 IF IO'=""
IF IO'=IO(0)!$GET(XTPRNT)
USE IO
if $EXTRACT($GET(IOST))="C"
WRITE @IOF
SET X="^L"
GOTO WRTA
+16 IF $GET(XTMES)
SET X="^L"
GOTO WRTA
+17 ;
+18 KILL ^TMP($JOB,"XTER")
SET C=0
+19 READ !!,"Which symbol? > ",XTX:DTIME
if '$TEST!(XTX="")
SET XTX="^"
+20 ;uppercase
if $EXTRACT(XTX,1)="^"
SET XTX=$TRANSLATE(XTX,"ilmpqr","ILMPQR")
+21 if XTX>0!(XTX="^")
GOTO XTERR^XTER
if XTX="^Q"
GOTO END^XTER
if XTX="^M"
GOTO MESG^XTER1A
if XTX="^P"
GOTO PRNT^XTER1A
SET X=XTX
SET XTX=""
SET XTOUT=0
+22 IF X="^I"
DO EN^XTER1B
GOTO WRT
+23 IF X["?"
SET XTF="1,2,10,7,13,14,15,8,9"
DO HELP^XTER
GOTO WRT
+24 IF X="$"
SET XTDV1=0
DO DV
GOTO WRT
+25 IF X="^R"
GOTO RESTOR^XTER2
+26 ;
WRTA ;Show All (^L)
+1 DO WRT1
if '$DATA(XTX)
SET XTX=""
+2 if $GET(XTMES)!$GET(XTPRNT)
QUIT
if IO=IO(0)&(XTX'="^Q")&(XTX'="^q")
GOTO WRT
+3 USE IO(0)
if XTX="^Q"!(XTX="^q")
GOTO END^XTER
GOTO XTERR^XTER
+4 ;
WRT1 ;
+1 if '$DATA(IOSL)
SET IOSL=24
DO ADD("")
DO ADD("")
+2 SET XTSYM=$SELECT(X="^L":"",1:X)
SET %XTYL=IOSL-4
SET XTI=0
SET XTC=1
SET X=""
SET XTA=XTSYM
SET XTA=$SELECT(XTA="":"",1:$EXTRACT(XTA,1,$LENGTH(XTA)-1)_$CHAR($ASCII($EXTRACT(XTA,$LENGTH(XTA)))-1)_"z")
+3 ;Find start by order thru B X-ref for Symbols, XTA=var name, XTB=var value
WF if '%XTYL
SET %XTYL=IOSL-4
+1 ;S (XTA,XTA1)=$O(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTA)) S XTI=$S(XTSYM="":1,XTA'="":$O(^(XTA,0)),1:0)
+2 ;p431
SET XTA=$ORDER(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV","B",XTA))
SET XTI=$SELECT(XTSYM="":1,XTA'="":$ORDER(^(XTA,0)),1:0)
+3 IF XTA=""!(XTSYM'=""&($EXTRACT(XTA,1,$LENGTH(XTSYM))'=XTSYM))
if XTSYM'=""&XTC
DO ADD("No such symbol")
if '$GET(XTPRNT)
DO MORE^XTER1A
QUIT
+4 ;p431
SET (XTA,XTA1)=^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI,0)
+5 DO WV
+6 ;Show the rest in order
+7 FOR
SET XTI=$ORDER(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI))
if 'XTI!(XTOUT)
QUIT
SET (XTA,XTA1)=^(XTI,0)
if $EXTRACT(XTA,1,$LENGTH(XTSYM))'=XTSYM
QUIT
DO WV
+8 QUIT
WV ;Write a variable
+1 if '%XTYL
SET %XTYL=IOSL-4
+2 SET XTB=$SELECT($DATA(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI,"D")):^("D"),1:"*** WARNING: this value was NOT recorded due to an ERROR WITHIN the TRAP ***")
+3 ;Check for long variables
+4 SET XTL=$GET(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZV",XTI,"L"))
IF XTL>255
DO ADD("**The following variables length is "_XTL_", only displaying first 255.**")
+5 SET XTC=0
if '$GET(XTMES)&'$GET(XTPRNT)
SET %XTYL=%XTYL-1
+6 if '%XTYL
DO MORE^XTER1A
if XTOUT
QUIT
if '%XTYL
DO ADD("")
+7 SET XTA1=XTA1_"="
KILL XTC1
IF XTB?.PUNL
IF XTB'["\"
SET XTA1=XTA1_XTB
SET XTC1=""
+8 ;Change control char to \027 format
+9 IF '$DATA(XTC1)
SET XTC1=""
IF $PIECE(XTA1," ",2)=""
FOR XTK=1:1
SET XTZ=$EXTRACT(XTB,XTK)
if XTZ=""
QUIT
SET XTC1=XTC1_$SELECT(XTZ'?1C:XTZ,1:"\"_$EXTRACT($ASCII(XTZ)+1000,2,4))
IF XTZ="\"
SET XTC1=XTC1_"\"
+10 DO SET
if XTL>255
DO ADD("**")
+11 QUIT
+12 ;
SET ;
+1 IF ($LENGTH(XTA1)+$LENGTH(XTC1))<246
SET XTA1=XTA1_XTC1
SET XTC1=""
DO ADD(XTA1)
QUIT
+2 IF $LENGTH(XTA1)>245
DO ADD($EXTRACT(XTA1,1,245))
SET XTA1=$EXTRACT(XTA1,246,$LENGTH(XTA1))
GOTO SET
+3 IF $LENGTH(XTA1)>0
DO ADD(XTA1_$EXTRACT(XTC1,1,(245-$LENGTH(XTA1))))
SET XTC1=$EXTRACT(XTC1,(245-$LENGTH(XTA1)+1),$LENGTH(XTC1))
GOTO SET
+4 DO ADD($EXTRACT(XTC1,1,245))
SET XTC1=$EXTRACT(XTC1,246,$LENGTH(XTC1))
GOTO SET
+5 QUIT
+6 ;
ADD(STR) ;Add STR to TMP global
+1 SET C=C+1
SET ^TMP($JOB,"XTER",C)=STR
+2 QUIT
+3 ;Header info
DV IF $DATA(XTDV1)
IF XTDV1=1
GOTO DV1
+1 KILL %XTZLIN
+2 SET %XTZE=^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZE")
SET %XTJOB=$GET(^("J"))
SET %XTIO=$GET(^("I"))
SET %XTZH=$GET(^("ZH"))
SET %XTZH1=$GET(^("H"))
SET %XTZGR=$GET(^("GR"))
if $DATA(^("LINE"))
SET %XTZLIN=^("LINE")
+3 IF %XTZH1>0
SET %H=%XTZH1
DO YMD^%DTC
SET Y=X_%
DO DD^%DT
SET $PIECE(%XTZH1,"^",2)=$PIECE(Y,"@",1)_" "_$PIECE(Y,"@",2)
+4 FOR %XTI=1:1:9
SET %XTZH(%XTI)=$PIECE(%XTZH,"^",%XTI)
+5 SET %XTZH(3)=$PIECE(%XTZH1,U,2)
+6 SET %XTUCI=$PIECE(%XTJOB,U,4)
+7 ;Build output
+8 SET X="Process ID: "_$PIECE(%XTJOB,U,5)_" ("_$PIECE(%XTJOB,U)_")"
SET X=X_$EXTRACT(XTBLNK,1,40-$LENGTH(X))_%XTZH(3)
+9 DO ADD("")
DO ADD(X)
+10 SET %XTZ="Username\Process Name\UCI/VOL\\$ZA\$ZB\Current $IO\Current $ZIO\CPU time\Page Faults\Direct I/O\Buffered I/O"
+11 SET %XTZ(1)=$PIECE(%XTJOB,U,3)
SET %XTZ(2)=$PIECE(%XTJOB,U,2)
SET %XTZ(3)=$SELECT(%XTUCI]"":"["_%XTUCI_"]",1:"")
+12 SET %XTZ(4)=""
SET %XTZ(5)=$JUSTIFY($PIECE(%XTIO,U,2),3)
SET %XTZ(6)=$JUSTIFY($PIECE(%XTIO,U,3),3)
+13 SET %XTZ(7)=$PIECE(%XTIO,U)
SET %XTZ(8)=$PIECE(%XTIO,U,4,99)
SET %XTZ(9)=$JUSTIFY(%XTZH(1),6)
+14 SET %XTZ(10)=$JUSTIFY(%XTZH(4),10)
SET %XTZ(11)=$JUSTIFY(%XTZH(7),10)
SET %XTZ(12)=$JUSTIFY(%XTZH(8),10)
+15 FOR %XTI=1:1:12
Begin DoDot:1
+16 IF %XTI#2
SET X=""
+17 if %XTZ(%XTI)'?." "
SET X=X_$PIECE(%XTZ,"\",%XTI)_": "_%XTZ(%XTI)
if %XTI#2
SET X=$EXTRACT(X_$EXTRACT(XTBLNK,1,40),1,40)
+18 IF '(%XTI#2)
IF X'?." "
DO ADD("")
DO ADD(X)
+19 QUIT
End DoDot:1
DV1 SET XTDV1=1
DO ADD("")
DO ADD("$ZE= "_%XTZE)
+1 ;p431
if %XTZGR'=""
DO ADD("")
DO ADD("Last Global Ref: "_%XTZGR)
+2 KILL X
IF $DATA(^%ZTER(1,%XTZDAT,1,%XTZNUM,"ZE2"))
SET X=^("ZE2")
+3 IF $DATA(X)
DO ADD("")
DO ADD("%ZTER encountered an error while logging this error -- ")
DO ADD("This may have caused some LOCAL VARIABLES to be lost.")
DO ADD("This error was: "_X)
+4 QUIT
+5 ;
