- 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 Feb 19, 2025@00:07:12 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
