%ZTER ; ISC-SF.SEA/JLI - KERNEL ERROR TRAP TO LOG ERRORS ;09/06/2017
;;8.0;KERNEL;**8,18,32,24,36,63,73,79,86,112,118,162,275,392,455,431,582,685**;JUL 10, 1995;Build 2
;Per VA Directive 6402, this routine should not be modified.
S ^TMP("$ZE",$J,1)=$$LGR^%ZOSV
S ^TMP("$ZE",$J,0)=$$EC^%ZOSV
S ^TMP("$ZE",$J,2)=$ETRAP,$ETRAP="D ERR^%ZTER"
S ^TMP("$ZE",$J,3)=$ZA_"~#~"_$ZB
I (^TMP("$ZE",$J,0)["-ALLOC,")!(^TMP("$ZE",$J,0)["<STORE>")!(^TMP("$ZE",$J,0)["-MEMORY") D
. I '$D(XUALLOC) D
. . K (%ZTERLGR,DUZ,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,DA,D0,DI,DIC,DIE)
. S %ZTER13A="ALLOC"
Z1 K XUALLOC
S %ZTERZE=^TMP("$ZE",$J,0),%ZT("^XUTL(""XQ"",$J)")="" S:'$D(%ZTERLGR) %ZTERLGR=^TMP("$ZE",$J,1)
G:$$SCREEN(%ZTERZE,1) EXIT ;Let site screen errors, count don't show
;Get a record.
S %ZTERH1=+$H L +^%ZTER(1,%ZTERH1,0):15
S %ZTER11N=$P($G(^%ZTER(1,%ZTERH1,1,0)),"^",3)
;S %ZTER11N=$P($G(^%ZTER(1,%ZTERH1,0)),"^",2)+1,^%ZTER(1,%ZTERH1,0)=%ZTERH1_"^"_%ZTER11N,^(1,0)="^3.0751^"_%ZTER11N_"^"_%ZTER11N
Z2 S %ZTER11N=%ZTER11N+1 G:$D(^%ZTER(1,%ZTERH1,1,%ZTER11N,0)) Z2
S %ZTER11C=$P($G(^%ZTER(1,%ZTERH1,0)),"^",2)+1
S ^%ZTER(1,%ZTERH1,0)=%ZTERH1_"^"_%ZTER11C,^%ZTER(1,%ZTERH1,1,0)="^3.0751^"_%ZTER11N_"^"_%ZTER11C
I %ZTER11N=1 S ^%ZTER(1,0)="ERROR LOG^3.075^"_%ZTERH1_"^"_($P(^%ZTER(1,0),"^",4)+1)
S %ZTERRT=$NA(^%ZTER(1,%ZTERH1,1,%ZTER11N))
S @%ZTERRT@(0)=%ZTER11N_"^"_$G(%ZTERAPP),^("ZE")=%ZTERZE S:$D(%ZTERLGR) ^("GR")=%ZTERLGR K %ZTERLGR ;p431
L -^%ZTER(1,%ZTERH1,0)
K %ZTER12A,%ZTER12B,%ZTER11C
;Save $ZA and $ZB
S %ZTER12A=$$ENC($P(^TMP("$ZE",$J,3),"~#~",1)),%ZTER12B=$$ENC($P(^TMP("$ZE",$J,3),"~#~",2))
S %ZTER11I=$$UCI()
S @%ZTERRT@("H")=$H,^("J")=$J_"^^^"_%ZTER11I_"^"_$J
S @%ZTERRT@("I")=$I_"^"_%ZTER12A_"^"_%ZTER12B_"^"_$G(IO("ZIO"))_"^"_$X_"^"_$Y_"^"_$P
S %ZTERROR=$$ETXT
S %ZTERCNT=0
D STACK^%ZTER1 ;Save Special Variables
D SAVE("$X $Y",$X_" "_$Y)
I ^%ZOSF("OS")["OpenM" D
. D SAVE("$ZU(56,2)",$ZU(56,2))
. I $ZV["VMS" S $P(@%ZTERRT@("J"),"^",2,3)=$ZF("GETJPI",$J,"PRCNAM")_"^"_$ZF("GETJPI",$J,"USERNAME")
D SAVE("$ZV",$ZV)
;End Special Variables
I ^%ZOSF("OS")["VAX DSM" K %ZTER11A,%ZTER11B D VXD^%ZTER1 I 1
E D
. S %ZTERVAR="%"
. F D VAR:$D(@%ZTERVAR)#2,SUBS:$D(@%ZTERVAR)>9 S %ZTERVAR=$O(@%ZTERVAR) Q:%ZTERVAR=""
D GLOB
S:%ZTERCNT>0 @%ZTERRT@("ZV",0)="^3.0752^"_%ZTERCNT_"^"_%ZTERCNT
S:'$D(^%ZTER(1,"B",%ZTERH1)) ^(%ZTERH1,%ZTERH1)=""
S ^%ZTER(1,%ZTERH1,1,"B",%ZTER11N,%ZTER11N)=""
LIN ;Find the line of the error
S %ZTERY=$P(%ZTERZE,","),%ZTERX=$P(%ZTERY,"^") S:%ZTERX[">" %ZTERX=$P(%ZTERX,">",2)
I %ZTERX'="" D
. N X,XCNP,DIF K ^TMP($J,"XTER1")
. S X=$P($P(%ZTERY,"^",2),":") Q:X="" X ^%ZOSF("TEST") Q:'$T
. S XCNP=0,DIF="^TMP($J,""XTER1""," X ^%ZOSF("LOAD") S %ZTERY=$P(%ZTERX,"+",1)
. I %ZTERY'="" F X=0:0 S X=$O(^TMP($J,"XTER1",X)) Q:X'>0 I $P(^(X,0)," ")=%ZTERY S X=X+$P(%ZTERX,"+",2),%ZTZLIN=$G(^TMP($J,"XTER1",X,0)) Q
. I %ZTERY="" S X=+$P(%ZTERX,"+",2) Q:X'>0 S %ZTZLIN=$G(^TMP($J,"XTER1",X,0))
K ^TMP($J,"XTER1")
S:$D(%ZTZLIN) @%ZTERRT@("LINE")=%ZTZLIN K %ZTZLIN
I %ZTERROR'="",$D(^%ZTER(2,"B",%ZTERROR)) S %ZTERROR=%ZTERROR_"^"_$P(^%ZTER(2,+$O(^(%ZTERROR,0)),0),"^",2)
EXIT ;
D ECNT ;Update the Error Count in the Summary
I $G(%ZTER13A)["ALLOC" HALT ;Don't allow job to go on.
S $EC="",$ET=$G(^TMP("$ZE",$J,2))
K ^TMP("$ZE",$J)
K %ZTER11A,%ZTER11B,%ZTER11D,%ZTER11H,%ZTER11I,%ZTER11L,%ZTER11N,%ZTER11Q,%ZTER11S,%ZTER11Z,%ZTER111,%ZTER112
K %ZTER12A,%ZTER12B,%ZTER13A,%ZTERVAP,%ZTERVAR,%ZTERSUB,%ZTERROR,%ZTERZE
K %ZTERRT,%ZTERH1,%ZTERCNT,%ZTERX,%ZTERY,%ZT
H 1 ;Slow down process
Q
;
VAR I "%ZTER"'=$E(%ZTERVAR,1,5) D SAVE(%ZTERVAR,@%ZTERVAR) Q
Q
;
SAVE(%ZTERN,%ZTERV) ;Save name and value into global, use special variables
S %ZTERCNT=%ZTERCNT+1,@%ZTERRT@("ZV",%ZTERCNT,0)=%ZTERN
I $L(%ZTERV)<256 S @%ZTERRT@("ZV",%ZTERCNT,"D")=%ZTERV Q
;Variable too long for global node
S @%ZTERRT@("ZV",%ZTERCNT,"D")=$E(%ZTERV,1,255),^("L")=$L(%ZTERV)
N %ZTERI
F %ZTERI=1:1 S %ZTERV=$E(%ZTERV,256,$L(%ZTERV)) Q:'$L(%ZTERV) S @%ZTERRT@("ZV",%ZTERCNT,"D",%ZTERI)=$E(%ZTERV,1,255)
Q
;
SUBS ;Save sub-nodes
S %ZTER11S="" Q:"%ZT("=$E(%ZTERVAR,1,4) Q:",%ZTER11S,%ZTER11L,"[(","_%ZTERVAR_",")
S %ZTERVAP=%ZTERVAR_"(",%ZTERSUB="%ZTER11S)"
S %ZTER11S=%ZTERVAR
F S %ZTER11S=$Q(@%ZTER11S) Q:%ZTER11S="" D SAVE(%ZTER11S,@%ZTER11S)
Q
;
GLOB ; save off a list of global subtrees, %ZT is passed in subscripted by name
; %ZTERCNT passed in to count the nodes we traverse
; %ZTERNOD the nodes through which we $QUERY
; %ZTERNAM the names of the global subtrees we're saving
; %ZTEROPN is %ZTERNAM, evaluated, without close paren for $PIECEing
N %ZTERNOD,%ZTERNAM,%ZTEROPN
S %ZTERNAM="" ; the names of the global subtrees we're saving
F S %ZTERNAM=$O(%ZT(%ZTERNAM)) Q:%ZTERNAM="" D
. S %ZTERNOD=$NA(@%ZTERNAM) ; fully evaluate all the subscripts (incl. $J)
. S %ZTEROPN=$E(%ZTERNOD,1,$L(%ZTERNOD)-1) ; save %ZTERNOD w/o close paren
. ;S %ZTERSUB=$QL(%ZTERNOD) ; how many subscripts in the subtree root's name
. F S %ZTERNOD=$Q(@%ZTERNOD) Q:%ZTERNOD="" Q:%ZTERNOD'[%ZTEROPN D ; traverse subtree
. . S %ZTERCNT=%ZTERCNT+1 ; count each node
. . S @%ZTERRT@("ZV",%ZTERCNT,0)=$P(%ZTERNAM,")")_$P(%ZTERNOD,%ZTEROPN,2) ; unevaluated name
. . S @%ZTERRT@("ZV",%ZTERCNT,"D")=$G(@%ZTERNOD) ; value of node
Q
;
ETXT() ;Return the Text of the error
Q $S(%ZTERZE["%DSM-E":$P($P(%ZTERZE,"%DSM-E-",2),","),1:$P($P(%ZTERZE,"<",2),">"))
;
ENC(%ZT1) ;Encode a string with control char in \027 format
N %ZTI,%ZTB,%ZTC S %ZTB=""
F %ZTI=1:1:$L(%ZT1) S %ZTC=$E(%ZT1,%ZTI),%ZTB=%ZTB_$S(%ZTC'?1C:%ZTC,1:"\"_$E($A(%ZTC)+1000,2,4))_","
Q $E(%ZTB,1,$L(%ZTB)-1)
;
UCI() ;Return the UCI, Changed to Box:Volume p431
N Y S Y=""
D GETENV^%ZOSV S Y=$P(Y,"^",4)
Q Y
;
APPERROR(%ZTERNM) ;Caller gives name to Error. p431
S ^TMP("$ZE",$J,1)=$$LGR^%ZOSV
S ^TMP("$ZE",$J,0)=%ZTERNM
S ^TMP("$ZE",$J,2)=$ETRAP,$ETRAP="D ERR^%ZTER"
S ^TMP("$ZE",$J,3)=$ZA_"~#~"_$ZB
S %ZTERAPP=1
G Z1
;
ERR ;Handle an error in %ZTER
I $D(%ZTERH1),$D(%ZTER11N) S ^%ZTER(1,%ZTERH1,1,%ZTER11N,"ZE2")="%ZTER error: "_$ECODE
;Should ^TMP("$ZE",$J) be killed here
HALT
;
ECNT ;Add to the error count
S %ZTER11A=$$FMT(%ZTERZE),%ZTER11N=0
I $L(%ZTER11A) L +^%ZTER(3.077,0):15 D L -^%ZTER(3.077,0)
. S %ZTER11N=$O(^%ZTER(3.077,"B",$E(%ZTER11A,1,30),0))
. I '%ZTER11N F Q:%ZTER11N D
. . S %ZTER11N=$P($G(^%ZTER(3.077,0)),"^",3)+1,$P(^(0),"^",2,4)="3.077^"_%ZTER11N_"^"_%ZTER11N
. . I $D(^%ZTER(3.077,%ZTER11N,0)) S %ZTER11N=0 Q
. . S ^%ZTER(3.077,%ZTER11N,0)=%ZTER11A,^%ZTER(3.077,"B",$E(%ZTER11A,1,30),%ZTER11N)=""
. . Q
. I '$D(^%ZTER(3.077,%ZTER11N,4,0)) S ^(0)="^3.0775"
. S %ZTER11H=$H,%ZTER11S=($P(%ZTER11H,",",2)\3600)+1,%ZTER11H=+%ZTER11H
. S $P(^%ZTER(3.077,%ZTER11N,4,%ZTER11H,0),"~",%ZTER11S)=$P($G(^%ZTER(3.077,%ZTER11N,4,%ZTER11H,0)),"~",%ZTER11S)+1
. I $P($G(^%ZTER(3.077,%ZTER11N,0)),"^",2)="" S $P(^%ZTER(3.077,%ZTER11N,0),"^",2)=$$HTFM^XLFDT($H) ;P582
. S $P(^%ZTER(3.077,%ZTER11N,0),"^",3)=$$HTFM^XLFDT($H) ;P583
. Q
Q
;
;Output format 'Tag+offset^Routine, <error code>'
FMT(%ZTE) ;Format the error text
I $E(%ZTE,1,2)="<>" S %ZTE=$E(%ZTE,3,999)
S %ZTE=$TR(%ZTE,"^","~")
I %ZTE["<"&($P(%ZTE,"<",2)[">") S %ZTE=$P($P(%ZTE,">",2)," ")_", "_$P(%ZTE,">")_">"
Q %ZTE
;
SCREEN(ERR,%ZT3) ;Screen out certain errors.
N %ZTA,%ZTE,%ZTI,%ZTJ,%ZTH,%ZTR S:'$D(ERR) ERR=$$EC^%ZOSV
I '$L(ERR) Q 0 ;Record
;Set error text format
S %ZTH=+$H,%ZTE=$$FMT(ERR)
;Find error in summary
S %ZTI=$O(^%ZTER(3.077,"B",$E(%ZTE,1,30),0)),%ZTR=$G(^%ZTER(3.077,+%ZTI,4,%ZTH,0)),%ZTJ=0 ; edit form %ZTE to $E(%ZTE,1,30) p685
F %ZTA=1:1:24 S %ZTJ=%ZTJ+$P(%ZTR,"~",%ZTA)
;Check the limit on the number of errors to record.
I $P($G(^XTV(8989.3,1,"ZTER")),"^",1)'="",%ZTJ'<(+$P($G(^XTV(8989.3,1,"ZTER"),"10"),"^",1)) Q 1 ;Don't record
;Check error screens
S %ZTE="",%ZTI=0
;See if error is in list.
F %ZTJ=2,1 D Q:%ZTI>0
. F %ZTI=0:0 S %ZTI=$O(^%ZTER(2,"AC",%ZTJ,%ZTI)) Q:%ZTI="" S %ZTE=$S($G(^%ZTER(2,%ZTI,2))]"":^(2),1:$P(^(0),"^")) Q:ERR[%ZTE
. Q
;Next see if we should count the error
I %ZTI>0 S %ZTE=$G(^%ZTER(2,%ZTI,0)) D Q $P(%ZTE,"^",3)=2 ;See if we skip the recording of the error.
. Q:(%ZTJ=1)&('$G(%ZT3))
. I $P(%ZTE,"^",4) L +^%ZTER(2,%ZTI):10 S ^(3)=$G(^%ZTER(2,%ZTI,3))+1 L -^%ZTER(2,%ZTI)
. Q
Q 0 ;record error
;
UNWIND ;Unwind stack for new error trap. Called by app code.
S $ECODE="" S $ETRAP="D UNW^%ZTER Q:'$QUIT Q -9" S $ECODE=",U1,"
UNW Q:$ESTACK>1 S $ECODE="" Q
;
NEWERR() ;Does this OS support the M95 error trapping
Q 1 ;All current M system now support 95 error trapping
;
ABORT ;Pop the stack all the way.
S $ETRAP="Q:$ST>1 S $ECODE="""" Q"
Q
;
POST ;Do the post-init
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZTER 8960 printed Jan 18, 2025@03:17:06 Page 2
%ZTER ; ISC-SF.SEA/JLI - KERNEL ERROR TRAP TO LOG ERRORS ;09/06/2017
+1 ;;8.0;KERNEL;**8,18,32,24,36,63,73,79,86,112,118,162,275,392,455,431,582,685**;JUL 10, 1995;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 SET ^TMP("$ZE",$JOB,1)=$$LGR^%ZOSV
+4 SET ^TMP("$ZE",$JOB,0)=$$EC^%ZOSV
+5 SET ^TMP("$ZE",$JOB,2)=$ETRAP
SET $ETRAP="D ERR^%ZTER"
+6 SET ^TMP("$ZE",$JOB,3)=$ZA_"~#~"_$ZB
+7 IF (^TMP("$ZE",$JOB,0)["-ALLOC,")!(^TMP("$ZE",$JOB,0)["<STORE>")!(^TMP("$ZE",$JOB,0)["-MEMORY")
Begin DoDot:1
+8 IF '$DATA(XUALLOC)
Begin DoDot:2
+9 KILL (%ZTERLGR,DUZ,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,DA,D0,DI,DIC,DIE)
End DoDot:2
+10 SET %ZTER13A="ALLOC"
End DoDot:1
Z1 KILL XUALLOC
+1 SET %ZTERZE=^TMP("$ZE",$JOB,0)
SET %ZT("^XUTL(""XQ"",$J)")=""
if '$DATA(%ZTERLGR)
SET %ZTERLGR=^TMP("$ZE",$JOB,1)
+2 ;Let site screen errors, count don't show
if $$SCREEN(%ZTERZE,1)
GOTO EXIT
+3 ;Get a record.
+4 SET %ZTERH1=+$HOROLOG
LOCK +^%ZTER(1,%ZTERH1,0):15
+5 SET %ZTER11N=$PIECE($GET(^%ZTER(1,%ZTERH1,1,0)),"^",3)
+6 ;S %ZTER11N=$P($G(^%ZTER(1,%ZTERH1,0)),"^",2)+1,^%ZTER(1,%ZTERH1,0)=%ZTERH1_"^"_%ZTER11N,^(1,0)="^3.0751^"_%ZTER11N_"^"_%ZTER11N
Z2 SET %ZTER11N=%ZTER11N+1
if $DATA(^%ZTER(1,%ZTERH1,1,%ZTER11N,0))
GOTO Z2
+1 SET %ZTER11C=$PIECE($GET(^%ZTER(1,%ZTERH1,0)),"^",2)+1
+2 SET ^%ZTER(1,%ZTERH1,0)=%ZTERH1_"^"_%ZTER11C
SET ^%ZTER(1,%ZTERH1,1,0)="^3.0751^"_%ZTER11N_"^"_%ZTER11C
+3 IF %ZTER11N=1
SET ^%ZTER(1,0)="ERROR LOG^3.075^"_%ZTERH1_"^"_($PIECE(^%ZTER(1,0),"^",4)+1)
+4 SET %ZTERRT=$NAME(^%ZTER(1,%ZTERH1,1,%ZTER11N))
+5 ;p431
SET @%ZTERRT@(0)=%ZTER11N_"^"_$GET(%ZTERAPP)
SET ^("ZE")=%ZTERZE
if $DATA(%ZTERLGR)
SET ^("GR")=%ZTERLGR
KILL %ZTERLGR
+6 LOCK -^%ZTER(1,%ZTERH1,0)
+7 KILL %ZTER12A,%ZTER12B,%ZTER11C
+8 ;Save $ZA and $ZB
+9 SET %ZTER12A=$$ENC($PIECE(^TMP("$ZE",$JOB,3),"~#~",1))
SET %ZTER12B=$$ENC($PIECE(^TMP("$ZE",$JOB,3),"~#~",2))
+10 SET %ZTER11I=$$UCI()
+11 SET @%ZTERRT@("H")=$HOROLOG
SET ^("J")=$JOB_"^^^"_%ZTER11I_"^"_$JOB
+12 SET @%ZTERRT@("I")=$IO_"^"_%ZTER12A_"^"_%ZTER12B_"^"_$GET(IO("ZIO"))_"^"_$X_"^"_$Y_"^"_$PRINCIPAL
+13 SET %ZTERROR=$$ETXT
+14 SET %ZTERCNT=0
+15 ;Save Special Variables
DO STACK^%ZTER1
+16 DO SAVE("$X $Y",$X_" "_$Y)
+17 IF ^%ZOSF("OS")["OpenM"
Begin DoDot:1
+18 DO SAVE("$ZU(56,2)",$ZU(56,2))
+19 IF $ZV["VMS"
SET $PIECE(@%ZTERRT@("J"),"^",2,3)=$ZF("GETJPI",$JOB,"PRCNAM")_"^"_$ZF("GETJPI",$JOB,"USERNAME")
End DoDot:1
+20 DO SAVE("$ZV",$ZV)
+21 ;End Special Variables
+22 IF ^%ZOSF("OS")["VAX DSM"
KILL %ZTER11A,%ZTER11B
DO VXD^%ZTER1
IF 1
+23 IF '$TEST
Begin DoDot:1
+24 SET %ZTERVAR="%"
+25 FOR
if $DATA(@%ZTERVAR)#2
DO VAR
if $DATA(@%ZTERVAR)>9
DO SUBS
SET %ZTERVAR=$ORDER(@%ZTERVAR)
if %ZTERVAR=""
QUIT
End DoDot:1
+26 DO GLOB
+27 if %ZTERCNT>0
SET @%ZTERRT@("ZV",0)="^3.0752^"_%ZTERCNT_"^"_%ZTERCNT
+28 if '$DATA(^%ZTER(1,"B",%ZTERH1))
SET ^(%ZTERH1,%ZTERH1)=""
+29 SET ^%ZTER(1,%ZTERH1,1,"B",%ZTER11N,%ZTER11N)=""
LIN ;Find the line of the error
+1 SET %ZTERY=$PIECE(%ZTERZE,",")
SET %ZTERX=$PIECE(%ZTERY,"^")
if %ZTERX[">"
SET %ZTERX=$PIECE(%ZTERX,">",2)
+2 IF %ZTERX'=""
Begin DoDot:1
+3 NEW X,XCNP,DIF
KILL ^TMP($JOB,"XTER1")
+4 SET X=$PIECE($PIECE(%ZTERY,"^",2),":")
if X=""
QUIT
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+5 SET XCNP=0
SET DIF="^TMP($J,""XTER1"","
XECUTE ^%ZOSF("LOAD")
SET %ZTERY=$PIECE(%ZTERX,"+",1)
+6 IF %ZTERY'=""
FOR X=0:0
SET X=$ORDER(^TMP($JOB,"XTER1",X))
if X'>0
QUIT
IF $PIECE(^(X,0)," ")=%ZTERY
SET X=X+$PIECE(%ZTERX,"+",2)
SET %ZTZLIN=$GET(^TMP($JOB,"XTER1",X,0))
QUIT
+7 IF %ZTERY=""
SET X=+$PIECE(%ZTERX,"+",2)
if X'>0
QUIT
SET %ZTZLIN=$GET(^TMP($JOB,"XTER1",X,0))
End DoDot:1
+8 KILL ^TMP($JOB,"XTER1")
+9 if $DATA(%ZTZLIN)
SET @%ZTERRT@("LINE")=%ZTZLIN
KILL %ZTZLIN
+10 IF %ZTERROR'=""
IF $DATA(^%ZTER(2,"B",%ZTERROR))
SET %ZTERROR=%ZTERROR_"^"_$PIECE(^%ZTER(2,+$ORDER(^(%ZTERROR,0)),0),"^",2)
EXIT ;
+1 ;Update the Error Count in the Summary
DO ECNT
+2 ;Don't allow job to go on.
IF $GET(%ZTER13A)["ALLOC"
HALT
+3 SET $ECODE=""
SET $ETRAP=$GET(^TMP("$ZE",$JOB,2))
+4 KILL ^TMP("$ZE",$JOB)
+5 KILL %ZTER11A,%ZTER11B,%ZTER11D,%ZTER11H,%ZTER11I,%ZTER11L,%ZTER11N,%ZTER11Q,%ZTER11S,%ZTER11Z,%ZTER111,%ZTER112
+6 KILL %ZTER12A,%ZTER12B,%ZTER13A,%ZTERVAP,%ZTERVAR,%ZTERSUB,%ZTERROR,%ZTERZE
+7 KILL %ZTERRT,%ZTERH1,%ZTERCNT,%ZTERX,%ZTERY,%ZT
+8 ;Slow down process
HANG 1
+9 QUIT
+10 ;
VAR IF "%ZTER"'=$EXTRACT(%ZTERVAR,1,5)
DO SAVE(%ZTERVAR,@%ZTERVAR)
QUIT
+1 QUIT
+2 ;
SAVE(%ZTERN,%ZTERV) ;Save name and value into global, use special variables
+1 SET %ZTERCNT=%ZTERCNT+1
SET @%ZTERRT@("ZV",%ZTERCNT,0)=%ZTERN
+2 IF $LENGTH(%ZTERV)<256
SET @%ZTERRT@("ZV",%ZTERCNT,"D")=%ZTERV
QUIT
+3 ;Variable too long for global node
+4 SET @%ZTERRT@("ZV",%ZTERCNT,"D")=$EXTRACT(%ZTERV,1,255)
SET ^("L")=$LENGTH(%ZTERV)
+5 NEW %ZTERI
+6 FOR %ZTERI=1:1
SET %ZTERV=$EXTRACT(%ZTERV,256,$LENGTH(%ZTERV))
if '$LENGTH(%ZTERV)
QUIT
SET @%ZTERRT@("ZV",%ZTERCNT,"D",%ZTERI)=$EXTRACT(%ZTERV,1,255)
+7 QUIT
+8 ;
SUBS ;Save sub-nodes
+1 SET %ZTER11S=""
if "%ZT("=$EXTRACT(%ZTERVAR,1,4)
QUIT
if ",%ZTER11S,%ZTER11L,"[(","_%ZTERVAR_",")
QUIT
+2 SET %ZTERVAP=%ZTERVAR_"("
SET %ZTERSUB="%ZTER11S)"
+3 SET %ZTER11S=%ZTERVAR
+4 FOR
SET %ZTER11S=$QUERY(@%ZTER11S)
if %ZTER11S=""
QUIT
DO SAVE(%ZTER11S,@%ZTER11S)
+5 QUIT
+6 ;
GLOB ; save off a list of global subtrees, %ZT is passed in subscripted by name
+1 ; %ZTERCNT passed in to count the nodes we traverse
+2 ; %ZTERNOD the nodes through which we $QUERY
+3 ; %ZTERNAM the names of the global subtrees we're saving
+4 ; %ZTEROPN is %ZTERNAM, evaluated, without close paren for $PIECEing
+5 NEW %ZTERNOD,%ZTERNAM,%ZTEROPN
+6 ; the names of the global subtrees we're saving
SET %ZTERNAM=""
+7 FOR
SET %ZTERNAM=$ORDER(%ZT(%ZTERNAM))
if %ZTERNAM=""
QUIT
Begin DoDot:1
+8 ; fully evaluate all the subscripts (incl. $J)
SET %ZTERNOD=$NAME(@%ZTERNAM)
+9 ; save %ZTERNOD w/o close paren
SET %ZTEROPN=$EXTRACT(%ZTERNOD,1,$LENGTH(%ZTERNOD)-1)
+10 ;S %ZTERSUB=$QL(%ZTERNOD) ; how many subscripts in the subtree root's name
+11 ; traverse subtree
FOR
SET %ZTERNOD=$QUERY(@%ZTERNOD)
if %ZTERNOD=""
QUIT
if %ZTERNOD'[%ZTEROPN
QUIT
Begin DoDot:2
+12 ; count each node
SET %ZTERCNT=%ZTERCNT+1
+13 ; unevaluated name
SET @%ZTERRT@("ZV",%ZTERCNT,0)=$PIECE(%ZTERNAM,")")_$PIECE(%ZTERNOD,%ZTEROPN,2)
+14 ; value of node
SET @%ZTERRT@("ZV",%ZTERCNT,"D")=$GET(@%ZTERNOD)
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
ETXT() ;Return the Text of the error
+1 QUIT $SELECT(%ZTERZE["%DSM-E":$PIECE($PIECE(%ZTERZE,"%DSM-E-",2),","),1:$PIECE($PIECE(%ZTERZE,"<",2),">"))
+2 ;
ENC(%ZT1) ;Encode a string with control char in \027 format
+1 NEW %ZTI,%ZTB,%ZTC
SET %ZTB=""
+2 FOR %ZTI=1:1:$LENGTH(%ZT1)
SET %ZTC=$EXTRACT(%ZT1,%ZTI)
SET %ZTB=%ZTB_$SELECT(%ZTC'?1C:%ZTC,1:"\"_$EXTRACT($ASCII(%ZTC)+1000,2,4))_","
+3 QUIT $EXTRACT(%ZTB,1,$LENGTH(%ZTB)-1)
+4 ;
UCI() ;Return the UCI, Changed to Box:Volume p431
+1 NEW Y
SET Y=""
+2 DO GETENV^%ZOSV
SET Y=$PIECE(Y,"^",4)
+3 QUIT Y
+4 ;
APPERROR(%ZTERNM) ;Caller gives name to Error. p431
+1 SET ^TMP("$ZE",$JOB,1)=$$LGR^%ZOSV
+2 SET ^TMP("$ZE",$JOB,0)=%ZTERNM
+3 SET ^TMP("$ZE",$JOB,2)=$ETRAP
SET $ETRAP="D ERR^%ZTER"
+4 SET ^TMP("$ZE",$JOB,3)=$ZA_"~#~"_$ZB
+5 SET %ZTERAPP=1
+6 GOTO Z1
+7 ;
ERR ;Handle an error in %ZTER
+1 IF $DATA(%ZTERH1)
IF $DATA(%ZTER11N)
SET ^%ZTER(1,%ZTERH1,1,%ZTER11N,"ZE2")="%ZTER error: "_$ECODE
+2 ;Should ^TMP("$ZE",$J) be killed here
+3 HALT
+4 ;
ECNT ;Add to the error count
+1 SET %ZTER11A=$$FMT(%ZTERZE)
SET %ZTER11N=0
+2 IF $LENGTH(%ZTER11A)
LOCK +^%ZTER(3.077,0):15
Begin DoDot:1
+3 SET %ZTER11N=$ORDER(^%ZTER(3.077,"B",$EXTRACT(%ZTER11A,1,30),0))
+4 IF '%ZTER11N
FOR
if %ZTER11N
QUIT
Begin DoDot:2
+5 SET %ZTER11N=$PIECE($GET(^%ZTER(3.077,0)),"^",3)+1
SET $PIECE(^(0),"^",2,4)="3.077^"_%ZTER11N_"^"_%ZTER11N
+6 IF $DATA(^%ZTER(3.077,%ZTER11N,0))
SET %ZTER11N=0
QUIT
+7 SET ^%ZTER(3.077,%ZTER11N,0)=%ZTER11A
SET ^%ZTER(3.077,"B",$EXTRACT(%ZTER11A,1,30),%ZTER11N)=""
+8 QUIT
End DoDot:2
+9 IF '$DATA(^%ZTER(3.077,%ZTER11N,4,0))
SET ^(0)="^3.0775"
+10 SET %ZTER11H=$HOROLOG
SET %ZTER11S=($PIECE(%ZTER11H,",",2)\3600)+1
SET %ZTER11H=+%ZTER11H
+11 SET $PIECE(^%ZTER(3.077,%ZTER11N,4,%ZTER11H,0),"~",%ZTER11S)=$PIECE($GET(^%ZTER(3.077,%ZTER11N,4,%ZTER11H,0)),"~",%ZTER11S)+1
+12 ;P582
IF $PIECE($GET(^%ZTER(3.077,%ZTER11N,0)),"^",2)=""
SET $PIECE(^%ZTER(3.077,%ZTER11N,0),"^",2)=$$HTFM^XLFDT($HOROLOG)
+13 ;P583
SET $PIECE(^%ZTER(3.077,%ZTER11N,0),"^",3)=$$HTFM^XLFDT($HOROLOG)
+14 QUIT
End DoDot:1
LOCK -^%ZTER(3.077,0)
+15 QUIT
+16 ;
+17 ;Output format 'Tag+offset^Routine, <error code>'
FMT(%ZTE) ;Format the error text
+1 IF $EXTRACT(%ZTE,1,2)="<>"
SET %ZTE=$EXTRACT(%ZTE,3,999)
+2 SET %ZTE=$TRANSLATE(%ZTE,"^","~")
+3 IF %ZTE["<"&($PIECE(%ZTE,"<",2)[">")
SET %ZTE=$PIECE($PIECE(%ZTE,">",2)," ")_", "_$PIECE(%ZTE,">")_">"
+4 QUIT %ZTE
+5 ;
SCREEN(ERR,%ZT3) ;Screen out certain errors.
+1 NEW %ZTA,%ZTE,%ZTI,%ZTJ,%ZTH,%ZTR
if '$DATA(ERR)
SET ERR=$$EC^%ZOSV
+2 ;Record
IF '$LENGTH(ERR)
QUIT 0
+3 ;Set error text format
+4 SET %ZTH=+$HOROLOG
SET %ZTE=$$FMT(ERR)
+5 ;Find error in summary
+6 ; edit form %ZTE to $E(%ZTE,1,30) p685
SET %ZTI=$ORDER(^%ZTER(3.077,"B",$EXTRACT(%ZTE,1,30),0))
SET %ZTR=$GET(^%ZTER(3.077,+%ZTI,4,%ZTH,0))
SET %ZTJ=0
+7 FOR %ZTA=1:1:24
SET %ZTJ=%ZTJ+$PIECE(%ZTR,"~",%ZTA)
+8 ;Check the limit on the number of errors to record.
+9 ;Don't record
IF $PIECE($GET(^XTV(8989.3,1,"ZTER")),"^",1)'=""
IF %ZTJ'<(+$PIECE($GET(^XTV(8989.3,1,"ZTER"),"10"),"^",1))
QUIT 1
+10 ;Check error screens
+11 SET %ZTE=""
SET %ZTI=0
+12 ;See if error is in list.
+13 FOR %ZTJ=2,1
Begin DoDot:1
+14 FOR %ZTI=0:0
SET %ZTI=$ORDER(^%ZTER(2,"AC",%ZTJ,%ZTI))
if %ZTI=""
QUIT
SET %ZTE=$SELECT($GET(^%ZTER(2,%ZTI,2))]"":^(2),1:$PIECE(^(0),"^"))
if ERR[%ZTE
QUIT
+15 QUIT
End DoDot:1
if %ZTI>0
QUIT
+16 ;Next see if we should count the error
+17 ;See if we skip the recording of the error.
IF %ZTI>0
SET %ZTE=$GET(^%ZTER(2,%ZTI,0))
Begin DoDot:1
+18 if (%ZTJ=1)&('$GET(%ZT3))
QUIT
+19 IF $PIECE(%ZTE,"^",4)
LOCK +^%ZTER(2,%ZTI):10
SET ^(3)=$GET(^%ZTER(2,%ZTI,3))+1
LOCK -^%ZTER(2,%ZTI)
+20 QUIT
End DoDot:1
QUIT $PIECE(%ZTE,"^",3)=2
+21 ;record error
QUIT 0
+22 ;
UNWIND ;Unwind stack for new error trap. Called by app code.
+1 SET $ECODE=""
SET $ETRAP="D UNW^%ZTER Q:'$QUIT Q -9"
SET $ECODE=",U1,"
UNW if $ESTACK>1
QUIT
SET $ECODE=""
QUIT
+1 ;
NEWERR() ;Does this OS support the M95 error trapping
+1 ;All current M system now support 95 error trapping
QUIT 1
+2 ;
ABORT ;Pop the stack all the way.
+1 SET $ETRAP="Q:$ST>1 S $ECODE="""" Q"
+2 QUIT
+3 ;
POST ;Do the post-init
