XTER1A ;ISC-SF.SEA/JLI - VA error reporting ;05/20/10 15:53
;;8.0;KERNEL;**63,112,120,431**;Jul 10, 1995;Build 35
;Per VHA Directive 2004-038, this routine should not be modified.
TWO ;Print two of each error
S XTNUM=2
ONE ;Print one of each error
S:'$D(XTNUM) XTNUM=1
S:'$D(XTNDATE) XTNDATE=$H-1 I '$D(ZTQUEUED) S XTNDAT1=$$HTFM^XLFDT(XTNDATE),XTNDAT2=XTNDAT1 G INT^XTER1A1
K ^TMP($J,"XTER1A") D LISTN,LIST
EXIT K XTNUM,XTNDATE,XTERN,XTERX,X,N,N1,Y,C,XTOUT,Z,I,XTER1AX,XTER1AN,XTER1AN1,%XTZDAT,%XTZNUM,XTMES,XTDV1,XTMES,XTPRNT
Q
LISTN ;Sort errors
F XTERN=0:0 S XTERN=$O(^%ZTER(1,XTNDATE,1,XTERN)) Q:XTERN'>0 I $D(^(XTERN,"ZE")) S XTERX=$E(^("ZE"),1,30),X=^("ZE") D
.S N1=0 F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N="" S N1=N I ^(N)=X Q
.I N="" S ^TMP($J,"XTER1A",XTERX,N1+1)=X,^(N1+1,"CNT")=1,^(1)=XTNDATE_U_XTERN
.E S ^("CNT")=^TMP($J,"XTER1A",XTERX,N,"CNT")+1 I ^("CNT")'>XTNUM S Y=^("CNT"),^(Y)=XTNDATE_U_XTERN
.Q
Q
LIST ;
S XTERX="",C=0,XTOUT=0 K ^TMP($J,"XTER")
;List count of errors
F S XTERX=$O(^TMP($J,"XTER1A",XTERX)) Q:XTERX="" F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N'>0 D
.S X=^TMP($J,"XTER1A",XTERX,N) D ADD(""),ADD("") S Z=$J(^TMP($J,"XTER1A",XTERX,N,"CNT"),8)_" "
.F I=1:60 S Y=$E(X,I,I+59) Q:Y="" D ADD(Z_Y) S Z=" "
.Q
;List errors
S XTER1AX="" F S XTER1AX=$O(^TMP($J,"XTER1A",XTER1AX)) Q:XTER1AX="" F XTER1AN=0:0 S XTER1AN=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN)) Q:XTER1AN'>0 D
.F XTER1AN1=0:0 S XTER1AN1=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN,XTER1AN1)) Q:XTER1AN1'>0 S X=^(XTER1AN1) D
..D ADD("|PAGE|") S %XTZDAT=+X,%XTZNUM=$P(X,U,2),XTDV1=0 S XTMES=1 D WRT^XTER1
D:IO=""&$D(^TMP($J,"XTER")) MESSG D:IO'="" WRITER
K ^TMP($J,"XTER") S C=0 I IO'="" U IO D ^%ZISC
Q
;
MESG ;Send to a Mail message
N DWPK,DWLW,DIC K ^TMP($J,"XTER"),^TMP($J,"XTER1")
W @IOF,!!,"Enter any comments to precede the error listing:"
S DWPK=1,DWLW=75,DIC="^TMP($J,""XTER1"",",DIWESUB="Comments" D EN^DIWE
S C=0 W ! F I=0:0 S I=$O(^TMP($J,"XTER1",I)) Q:I'>0 S C=I,^TMP($J,"XTER",I)=^TMP($J,"XTER1",I,0)
S XTMES=1,XTDV1=0 D WRT^XTER1 D:C>0 MESSG
S C=0,XTX="" K XTMES,^TMP($J,"XTER"),^TMP($J,"XTER1")
G XTERR^XTER
;
PRNT ;Send to Printer
K ^TMP($J,"XTER"),ZTIO,XTDV1
S C=0,%ZIS="MQ" D ^%ZIS I POP D HOME^%ZIS G WRT^XTER1
I $D(IO("Q")) D S XTX="" G XTERR^XTER
. K IO("Q") S ZTRTN="DQPRNT^XTER1A",ZTSAVE("%XTZDAT")="",ZTSAVE("%XTZNUM")="",ZTDESC="XTER1A-PRINT OF ERROR" D ^%ZTLOAD K ZTSK D HOME^%ZIS
;
DQPRNT S XTPRNT=1,XTOUT=0 D WRT^XTER1 U IO D:C>0 WRITER
K ^TMP($J,"XTER"),XTX,XTPRNT S C=0 D ^%ZISC I $D(ZTQUEUED) Q
G XTERR^XTER
;
WRITER ;Write global
F %=0:0 S %=$O(^TMP($J,"XTER",%)) Q:%'>0 W:((IOSL-$Y)'>4&$G(XTPRNT)) @IOF S %1=$S($D(^(%))=1:^(%),1:^(%,0)) D
.I $E(%1,1,6)="|PAGE|" W @IOF S %1=$E(%1,7,$L(%1)) Q:%1=""
.I $E(%1,1,4)="@IOF" W @IOF S %1=$E(%1,5,$L(%1)) Q:%1=""
.F Q:%1="" W !,$E(%1,1,IOM) S %1=$E(%1,IOM+1,$L(%1))
K %,%1
Q
MESSG ;Global to Message
S XMY(DUZ)="",XMDUZ=.5 I '$D(ZTQUEUED) K XMY,XMDUZ
S XMTEXT="^TMP($J,""XTER"",",XMSUB="ERROR - "_$E(%XTZE,1,40) F Q:XMSUB'[U S XMSUB=$P(XMSUB,U)_"~U~"_$P(XMSUB,U,2,99)
D ^XMD K XMY,XMTEXT,XMSUB
Q
;
ADD(STR) ;Add STR to TMP global
S C=C+1,^TMP($J,"XTER",C)=STR
Q
;
MORE Q:$G(XTMES) N DIR,DTOUT,DIRUT,DUOUT
S XTOUT=0,XTX="" D WRITER K ^TMP($J,"XTER") S C=0
I '$D(ZTQUEUED),'$G(XTPRNT),$G(IOST)["C-" D
. S:($D(X)#2) XTMORE=X S DIR(0)="FO^0:50",DIR("A")=" Enter '^' to quit listing, <RETURN> to continue..."
. D ^DIR K DIR S:$D(DTOUT) X="^" S XTX=X S:$D(XTMORE) X=XTMORE K XTMORE
I $D(XTX),$E(XTX)="^" S XTOUT=1 Q
I $G(XTPRNT) W @IOF
Q
;
LST S X=" ",XTQ="" N XTXT,XBLNK S $P(XBLNK," ",80)=" "
T1 S X=$O(^%ZTER(1,%XTZDAT,1,X),-1) R XTQ:0 Q:XTQ'="" G T2:X'>0,T1:'($D(^(X,"ZE"))#2) S XTP=^("ZE"),XTS=""
F S XTS=$O(^TMP($J,"XTERSCR",XTS)) Q:XTS="" I XTP[XTS,XTD S XTD=XTD+1 G T1
;
I '(X#20) S %XTERRX=X D MORE Q:XTOUT Q:XTX>0 D T3 S X=%XTERRX
I ^%ZTER(1,%XTZDAT,1,X,"ZE")["," S %XTERR=$P($P(^("ZE"),",",4),"-",4),%XTERR=$P($P(^("ZE"),",",2),"-",3)_$S(%XTERR="":"",1:"(")_%XTERR_$S(%XTERR="":"",1:")") S XTXT=$J(X,3)_") "_"<"_%XTERR_">"_$P(^("ZE"),",",1)_" "
I ^%ZTER(1,%XTZDAT,1,X,"ZE")'["," S XTXT=$J(X,3)_") "_^("ZE")
S %XTZNUM=X,%="" I $D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"H")) S %H=^("H") D YMD^%DTC S %=$P(%,".",2)_"000000",%=$E(%,1,2)_":"_$E(%,3,4)_":"_$E(%,5,6)
S X=%XTZNUM S XTXT=$S($L(XTXT)>38:XTXT,1:$E(XTXT_XBLNK,1,38))_%
S XTXT=XTXT_" "_$P($S('$D(^%ZTER(1,%XTZDAT,1,X,"J")):"",1:^("J")),U,4)_" "_$J($P($S('$D(^("J")):"",1:^("J")),U,5),7)_" "_$P($S('$D(^("I")):"",1:^("I")),U)
S XTXT=$S($L(XTXT)>51:XTXT,1:$E(XTXT_XBLNK,1,51))_$P(XTP,"\",7)
S XTXT=$S($L(XTXT)>59:XTXT,1:$E(XTXT_XBLNK,1,60))_$P(XTP,"\",3) S XTXT=$S($L(XTXT)>65:XTXT,1:$E(XTXT_XBLNK,1,65))_$P(XTP,"\",4) W !,$E(XTXT,1,79) G T1
T2 I XTD W !!,$S(XTD-1:XTD-1,1:"No")," screened error",$S(XTD-1>1:"s",1:""),!
D MORE
Q
T3 W !!,?11,"$ZE",?41,"Time",?49,"UCI,VOL",?61,"$J",?69,"$I",!
Q
INTRACT ;
G INTRACT^XTER1A1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTER1A 5048 printed Dec 13, 2024@02:40:45 Page 2
XTER1A ;ISC-SF.SEA/JLI - VA error reporting ;05/20/10 15:53
+1 ;;8.0;KERNEL;**63,112,120,431**;Jul 10, 1995;Build 35
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
TWO ;Print two of each error
+1 SET XTNUM=2
ONE ;Print one of each error
+1 if '$DATA(XTNUM)
SET XTNUM=1
+2 if '$DATA(XTNDATE)
SET XTNDATE=$HOROLOG-1
IF '$DATA(ZTQUEUED)
SET XTNDAT1=$$HTFM^XLFDT(XTNDATE)
SET XTNDAT2=XTNDAT1
GOTO INT^XTER1A1
+3 KILL ^TMP($JOB,"XTER1A")
DO LISTN
DO LIST
EXIT KILL XTNUM,XTNDATE,XTERN,XTERX,X,N,N1,Y,C,XTOUT,Z,I,XTER1AX,XTER1AN,XTER1AN1,%XTZDAT,%XTZNUM,XTMES,XTDV1,XTMES,XTPRNT
+1 QUIT
LISTN ;Sort errors
+1 FOR XTERN=0:0
SET XTERN=$ORDER(^%ZTER(1,XTNDATE,1,XTERN))
if XTERN'>0
QUIT
IF $DATA(^(XTERN,"ZE"))
SET XTERX=$EXTRACT(^("ZE"),1,30)
SET X=^("ZE")
Begin DoDot:1
+2 SET N1=0
FOR N=0:0
SET N=$ORDER(^TMP($JOB,"XTER1A",XTERX,N))
if N=""
QUIT
SET N1=N
IF ^(N)=X
QUIT
+3 IF N=""
SET ^TMP($JOB,"XTER1A",XTERX,N1+1)=X
SET ^(N1+1,"CNT")=1
SET ^(1)=XTNDATE_U_XTERN
+4 IF '$TEST
SET ^("CNT")=^TMP($JOB,"XTER1A",XTERX,N,"CNT")+1
IF ^("CNT")'>XTNUM
SET Y=^("CNT")
SET ^(Y)=XTNDATE_U_XTERN
+5 QUIT
End DoDot:1
+6 QUIT
LIST ;
+1 SET XTERX=""
SET C=0
SET XTOUT=0
KILL ^TMP($JOB,"XTER")
+2 ;List count of errors
+3 FOR
SET XTERX=$ORDER(^TMP($JOB,"XTER1A",XTERX))
if XTERX=""
QUIT
FOR N=0:0
SET N=$ORDER(^TMP($JOB,"XTER1A",XTERX,N))
if N'>0
QUIT
Begin DoDot:1
+4 SET X=^TMP($JOB,"XTER1A",XTERX,N)
DO ADD("")
DO ADD("")
SET Z=$JUSTIFY(^TMP($JOB,"XTER1A",XTERX,N,"CNT"),8)_" "
+5 FOR I=1:60
SET Y=$EXTRACT(X,I,I+59)
if Y=""
QUIT
DO ADD(Z_Y)
SET Z=" "
+6 QUIT
End DoDot:1
+7 ;List errors
+8 SET XTER1AX=""
FOR
SET XTER1AX=$ORDER(^TMP($JOB,"XTER1A",XTER1AX))
if XTER1AX=""
QUIT
FOR XTER1AN=0:0
SET XTER1AN=$ORDER(^TMP($JOB,"XTER1A",XTER1AX,XTER1AN))
if XTER1AN'>0
QUIT
Begin DoDot:1
+9 FOR XTER1AN1=0:0
SET XTER1AN1=$ORDER(^TMP($JOB,"XTER1A",XTER1AX,XTER1AN,XTER1AN1))
if XTER1AN1'>0
QUIT
SET X=^(XTER1AN1)
Begin DoDot:2
+10 DO ADD("|PAGE|")
SET %XTZDAT=+X
SET %XTZNUM=$PIECE(X,U,2)
SET XTDV1=0
SET XTMES=1
DO WRT^XTER1
End DoDot:2
End DoDot:1
+11 if IO=""&$DATA(^TMP($JOB,"XTER"))
DO MESSG
if IO'=""
DO WRITER
+12 KILL ^TMP($JOB,"XTER")
SET C=0
IF IO'=""
USE IO
DO ^%ZISC
+13 QUIT
+14 ;
MESG ;Send to a Mail message
+1 NEW DWPK,DWLW,DIC
KILL ^TMP($JOB,"XTER"),^TMP($JOB,"XTER1")
+2 WRITE @IOF,!!,"Enter any comments to precede the error listing:"
+3 SET DWPK=1
SET DWLW=75
SET DIC="^TMP($J,""XTER1"","
SET DIWESUB="Comments"
DO EN^DIWE
+4 SET C=0
WRITE !
FOR I=0:0
SET I=$ORDER(^TMP($JOB,"XTER1",I))
if I'>0
QUIT
SET C=I
SET ^TMP($JOB,"XTER",I)=^TMP($JOB,"XTER1",I,0)
+5 SET XTMES=1
SET XTDV1=0
DO WRT^XTER1
if C>0
DO MESSG
+6 SET C=0
SET XTX=""
KILL XTMES,^TMP($JOB,"XTER"),^TMP($JOB,"XTER1")
+7 GOTO XTERR^XTER
+8 ;
PRNT ;Send to Printer
+1 KILL ^TMP($JOB,"XTER"),ZTIO,XTDV1
+2 SET C=0
SET %ZIS="MQ"
DO ^%ZIS
IF POP
DO HOME^%ZIS
GOTO WRT^XTER1
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 KILL IO("Q")
SET ZTRTN="DQPRNT^XTER1A"
SET ZTSAVE("%XTZDAT")=""
SET ZTSAVE("%XTZNUM")=""
SET ZTDESC="XTER1A-PRINT OF ERROR"
DO ^%ZTLOAD
KILL ZTSK
DO HOME^%ZIS
End DoDot:1
SET XTX=""
GOTO XTERR^XTER
+5 ;
DQPRNT SET XTPRNT=1
SET XTOUT=0
DO WRT^XTER1
USE IO
if C>0
DO WRITER
+1 KILL ^TMP($JOB,"XTER"),XTX,XTPRNT
SET C=0
DO ^%ZISC
IF $DATA(ZTQUEUED)
QUIT
+2 GOTO XTERR^XTER
+3 ;
WRITER ;Write global
+1 FOR %=0:0
SET %=$ORDER(^TMP($JOB,"XTER",%))
if %'>0
QUIT
if ((IOSL-$Y)'>4&$GET(XTPRNT))
WRITE @IOF
SET %1=$SELECT($DATA(^(%))=1:^(%),1:^(%,0))
Begin DoDot:1
+2 IF $EXTRACT(%1,1,6)="|PAGE|"
WRITE @IOF
SET %1=$EXTRACT(%1,7,$LENGTH(%1))
if %1=""
QUIT
+3 IF $EXTRACT(%1,1,4)="@IOF"
WRITE @IOF
SET %1=$EXTRACT(%1,5,$LENGTH(%1))
if %1=""
QUIT
+4 FOR
if %1=""
QUIT
WRITE !,$EXTRACT(%1,1,IOM)
SET %1=$EXTRACT(%1,IOM+1,$LENGTH(%1))
End DoDot:1
+5 KILL %,%1
+6 QUIT
MESSG ;Global to Message
+1 SET XMY(DUZ)=""
SET XMDUZ=.5
IF '$DATA(ZTQUEUED)
KILL XMY,XMDUZ
+2 SET XMTEXT="^TMP($J,""XTER"","
SET XMSUB="ERROR - "_$EXTRACT(%XTZE,1,40)
FOR
if XMSUB'[U
QUIT
SET XMSUB=$PIECE(XMSUB,U)_"~U~"_$PIECE(XMSUB,U,2,99)
+3 DO ^XMD
KILL XMY,XMTEXT,XMSUB
+4 QUIT
+5 ;
ADD(STR) ;Add STR to TMP global
+1 SET C=C+1
SET ^TMP($JOB,"XTER",C)=STR
+2 QUIT
+3 ;
MORE if $GET(XTMES)
QUIT
NEW DIR,DTOUT,DIRUT,DUOUT
+1 SET XTOUT=0
SET XTX=""
DO WRITER
KILL ^TMP($JOB,"XTER")
SET C=0
+2 IF '$DATA(ZTQUEUED)
IF '$GET(XTPRNT)
IF $GET(IOST)["C-"
Begin DoDot:1
+3 if ($DATA(X)#2)
SET XTMORE=X
SET DIR(0)="FO^0:50"
SET DIR("A")=" Enter '^' to quit listing, <RETURN> to continue..."
+4 DO ^DIR
KILL DIR
if $DATA(DTOUT)
SET X="^"
SET XTX=X
if $DATA(XTMORE)
SET X=XTMORE
KILL XTMORE
End DoDot:1
+5 IF $DATA(XTX)
IF $EXTRACT(XTX)="^"
SET XTOUT=1
QUIT
+6 IF $GET(XTPRNT)
WRITE @IOF
+7 QUIT
+8 ;
LST SET X=" "
SET XTQ=""
NEW XTXT,XBLNK
SET $PIECE(XBLNK," ",80)=" "
T1 SET X=$ORDER(^%ZTER(1,%XTZDAT,1,X),-1)
READ XTQ:0
if XTQ'=""
QUIT
if X'>0
GOTO T2
if '($DATA(^(X,"ZE"))#2)
GOTO T1
SET XTP=^("ZE")
SET XTS=""
+1 FOR
SET XTS=$ORDER(^TMP($JOB,"XTERSCR",XTS))
if XTS=""
QUIT
IF XTP[XTS
IF XTD
SET XTD=XTD+1
GOTO T1
+2 ;
+3 IF '(X#20)
SET %XTERRX=X
DO MORE
if XTOUT
QUIT
if XTX>0
QUIT
DO T3
SET X=%XTERRX
+4 IF ^%ZTER(1,%XTZDAT,1,X,"ZE")[","
SET %XTERR=$PIECE($PIECE(^("ZE"),",",4),"-",4)
SET %XTERR=$PIECE($PIECE(^("ZE"),",",2),"-",3)_$SELECT(%XTERR="":"",1:"(")_%XTERR_$SELECT(%XTERR="":"",1:")")
SET XTXT=$JUSTIFY(X,3)_") "_"<"_%XTERR_">"_$PIECE(^("ZE"),",",1)_" "
+5 IF ^%ZTER(1,%XTZDAT,1,X,"ZE")'[","
SET XTXT=$JUSTIFY(X,3)_") "_^("ZE")
+6 SET %XTZNUM=X
SET %=""
IF $DATA(^%ZTER(1,%XTZDAT,1,%XTZNUM,"H"))
SET %H=^("H")
DO YMD^%DTC
SET %=$PIECE(%,".",2)_"000000"
SET %=$EXTRACT(%,1,2)_":"_$EXTRACT(%,3,4)_":"_$EXTRACT(%,5,6)
+7 SET X=%XTZNUM
SET XTXT=$SELECT($LENGTH(XTXT)>38:XTXT,1:$EXTRACT(XTXT_XBLNK,1,38))_%
+8 SET XTXT=XTXT_" "_$PIECE($SELECT('$DATA(^%ZTER(1,%XTZDAT,1,X,"J")):"",1:^("J")),U,4)_" "_$JUSTIFY($PIECE($SELECT('$DATA(^("J")):"",1:^("J")),U,5),7)_" "_$PIECE($SELECT('$DATA(^("I")):"",1:^("I")),U)
+9 SET XTXT=$SELECT($LENGTH(XTXT)>51:XTXT,1:$EXTRACT(XTXT_XBLNK,1,51))_$PIECE(XTP,"\",7)
+10 SET XTXT=$SELECT($LENGTH(XTXT)>59:XTXT,1:$EXTRACT(XTXT_XBLNK,1,60))_$PIECE(XTP,"\",3)
SET XTXT=$SELECT($LENGTH(XTXT)>65:XTXT,1:$EXTRACT(XTXT_XBLNK,1,65))_$PIECE(XTP,"\",4)
WRITE !,$EXTRACT(XTXT,1,79)
GOTO T1
T2 IF XTD
WRITE !!,$SELECT(XTD-1:XTD-1,1:"No")," screened error",$SELECT(XTD-1>1:"s",1:""),!
+1 DO MORE
+2 QUIT
T3 WRITE !!,?11,"$ZE",?41,"Time",?49,"UCI,VOL",?61,"$J",?69,"$I",!
+1 QUIT
INTRACT ;
+1 GOTO INTRACT^XTER1A1
