HLCSRPT2 ;ISC-SF/RAH-TRANS LOG ERROR LIST ;08/25/2010
;;1.6;HEALTH LEVEL SEVEN;**50,85,107,145,151**;Oct 13, 1995;Build 1
;Per VHA Directive 2004-038, this routine should not be modified.
;Calls to SAVEDDB^DDBR2, USAVEDDB^DDBR2, PSR^DDBR0, and WP^DDBR2 supported by IA#2540 & IA#3594
;
Q
;
EN ; Entry point for reporting error messages.
;
; All NEWs below added by HL*1.6*85
N BLDOFF,BLDON,DY,ERRDTB,ERRDTE,HLCSCLNT,HLCSDTE,HLCSDTP
N HLCSEVN,HLCSEVN1,HLCSEVN2,HLCSHDR,HLCSK,HLCSLINK
N HLCSLNK,HLCSMID,HLCSMX,HLCSNREC,HLCSPTR,HLCSRNO,HLCSSRVR
N HLCSTITL,HLCSTYP,HLERR,IEN773,LAST773,LASTPDT
N LPIENS,NOREC,NUMERR,OLD773,OLDPDT,RVOFF,RVON,SPACE
N SPACE20,SPACE25,SPACE30,SPACE80,STOP,TYPEINFO,VERS22
;
D CLEANGBL ;HL*1.6*85
;
S (STOP,NOREC)=""
D SCREEN^HLCSRPT
S HLCSNREC=BLDON_" ===>>> NO MATCHING RECORDS <<<=== "_BLDOFF
S HLCSTITL="#773-IEN Message-ID Procd Log-Link Msg:Evn IO Sndg-Apl Rcvr-Apl" ;HL*1.6*85
S HLCSPTR=1,HLCSRNO=1
S VERS22=""
I 22'>+$$VERSION^XPDUTL("DI")!($$PATCH^XPDUTL("DI*21.0*32")) S VERS22="YES" ;HL*1.6*85
I VERS22'="YES" D
. S ^TMP("DDBPF1Z",$J)="D SHOWMSG^HLCSRPT2 Q"
. S HLCSTITL=HLCSTITL_" ERR"
E S HLCSTITL=HLCSTITL_" "
S ^TMP($J,"LIST","MESSAGE")="^TMP($J,""MESSAGE"",HLCSRNO)"
S ^TMP($J,"LIST",HLCSTITL_" ERR")="^TMP(""TLOG"",$J)" ;HL*1.6*85
;
REEN ; Internal Re-entry Point
S STOP=""
D WHATERR Q:(+$G(STOP))
QUIT:'$$SETUP^HLCSRPT4 ;-> HL*1.6*85
I TYPEINFO=2 S HLCSTITL="#773-IEN Message-ID Procd Log-Link Error-type " ;HL*1.6*85
D ERRSRCH
I ERRDTE[9999999 S ERRDTE=$$NOW^XLFDT
I +$G(STOP) D EXIT Q
I +$G(NOREC) W !!,HLCSNREC,!! S DIR(0)="E" D ^DIR K DIR,X,Y D EXIT Q
D DISPLAY^HLCSRPT ;HL*1.6*85
D CLEANGBL ;HL*1.6*85
D EXIT
S STOP=1
Q
;
CLEANGBL ; New subroutine added by HL*1.6*85 to clean up globals
N GBL
F GBL="LIST","MESSAGE" KILL ^TMP($J,GBL)
F GBL="DDBPF1Z","DDBLST","TLOG","TMPLOG" KILL ^TMP(GBL,$J)
QUIT
;
WHATERR ; Ask for one error code; with default of all
W @IOF,! S HLCSHDR="Error Type Selection" D HLCSBAR
S X="",HLCSER="ALL"
S DIR(0)="PAO^771.7:AEO",DIR("A")="Select Error Type: ALL//"
D ^DIR S:($D(DTOUT)!($D(DUOUT))) STOP=1
I +$G(STOP) K DIR,X,Y Q
I X="" K DIR,X,Y Q
I Y=-1 W !,X_" NOT VALID " K DIR,X,Y G WHATERR
S HLCSTER1=$P(Y,U,1),HLCSTER2=$P(Y,U,2) K DIR,X,Y
S HLCSER=1
Q
;
ERRSRCH ; Find and report the 'errored' messages (Multiple HL*1.6*85 changes start here)
; ERRDTB,ERRDTE,NUMERR -- req
N NEXT,CT
W !!,"PLEASE WAIT, THIS CAN TAKE AWHILE..."
;
;HL*1.6*85 - LOADERR loads all errors, using the user-supplied
; parameters, and places them in ^TMP. Below, the code
; now loops thru ^TMP instead of ^HLMA (which happened
; in LOADERR.)
D LOADERR^HLCSRPT4
;
; Looping starts here...
S HLCSI=0,HLCSST=0,HLCSLN=0
F S HLCSI=$O(^TMP("ERRLST",$J,HLCSI)) Q:HLCSI'>0 D
. S HLCSN=HLCSI,HLCSJ=0
. F S HLCSJ=$O(^TMP("ERRLST",$J,HLCSI,HLCSJ)) Q:HLCSJ'>0 D
.. ;HL*1.6*85 changes end here, until noted otherwise below.
..
.. I '$D(^HLMA(HLCSJ,0)) Q
.. S HLCSX=^HLMA(HLCSJ,0),HLCSDTE=$P(HLCSX,U,1)
.. I $D(^HLMA(HLCSJ,"S")) S HLCSDTP=$P(^HLMA(HLCSJ,"S"),U,1)
.. E S HLCSDTP=""
.. I $D(^HLMA(HLCSJ,"P")) S HLCSY=^HLMA(HLCSJ,"P")
.. E S HLCSY=""
.. I HLCSER=1,(HLCSTER1'=$P(HLCSY,U,4)) Q
.. S HLCSER1=$P(HLCSY,U,4),HLCSER2=HLCSER1
.. I HLCSER1'="",($D(^HL(771.7,HLCSER1,0))) S HLCSER1=$P(^HL(771.7,HLCSER1,0),U,1)
.. S HLCSERMS=$P(HLCSY,U,3)
.. S HLCSLINK=$P(HLCSX,U,7) S HLCSLNK=" "
.. I HLCSLINK'="",($D(^HLCS(870,HLCSLINK,0))) S HLCSLNK=$P(^HLCS(870,HLCSLINK,0),U,1)
.. ; patch HL*1.6*145 start
.. ; S HLCSEVN1=$P(HLCSX,U,13) I HLCSEVN1'="",($D(^HL(771.2,HLCSEVN1,0))) S HLCSEVN1=$P(^HL(771.2,HLCSEVN1,0),U,1)
.. ; S HLCSEVN2=$P(HLCSX,U,14) I HLCSEVN2'="",($D(^HL(779.001,HLCSEVN2,0))) S HLCSEVN2=$P(^HL(779.001,HLCSEVN2,0),U,1)
.. N SEG
.. D HEADSEG^HLCSRPT1(HLCSJ,.SEG)
.. S HLCSEVN1=$G(SEG("MESSAGE TYPE"))
.. S HLCSEVN2=$G(SEG("EVENT TYPE"))
.. ; I HLCSEVN1="" S HLCSEVN1=$$MSGEVN^HLCSRPT5(HLCSJ,2) ;HL*1.6*85
.. ; I HLCSEVN2="" S HLCSEVN2=$$MSGEVN^HLCSRPT5(HLCSJ,2) ;HL*1.6*85
.. ; patch HL*1.6*145 end
.. I $L(HLCSEVN1)<3 S HLCSEVN1=HLCSEVN1_" ",HLCSEVN1=$E(HLCSEVN1,1,3)
.. I $L(HLCSEVN2)<3 S HLCSEVN2=HLCSEVN2_" ",HLCSEVN2=$E(HLCSEVN2,1,3)
.. S HLCSEVN=HLCSEVN1_":"_HLCSEVN2
.. D ERRRPT^HLCSRPT5 ;HL*1.6*85 - Code overrun moved
.. Q
.Q
KILL ^TMP("ERRLST",$J) ;HL*1.6*85
D TMPLOG^HLCSRPT4 ;HL*1.6*85 Reset ^TMP("TMPLOG",$J) to ^TMP("TLOG",$J)
I '$D(^TMP("TLOG",$J,1)) S NOREC=1 Q
;HL*1.6*85 - HLCSTITL already set above ;S HLCSTITL="IEN Record # MESSAGE ID # Log Link Msg:Evn IO Sndg Apl Rcvr Apl"
I '$D(VERS22) S HLCSTITL=HLCSTITL_" ERR"
E S HLCSTITL=HLCSTITL_" "
D TEST
Q
;
SHOWMSG ; Enable switching to specific message (used by PF1Z).
; If FM version 22 installed, uses VERS22 code, instead.
W @IOF
S DIR(0)="F:AE",DIR("A")="Enter Record Number: "
D ^DIR Q:$D(DIRUT)
I Y=-1!(X="") Q
S HLCSRNO=X I '$D(^HLMA(HLCSRNO,0)) D Q
. W !!,BLDON," ==> NO SUCH RECORD NUMBER <== ",BLDOFF H 3
S HLCSPTR=$P(^HLMA(HLCSRNO,0),"^",1)
S XXY=HLCSRNO,XXZ=HLCSPTR D VERS22(XXY,XXZ)
D SWITCH
Q
SWITCH ; Non-standard Fileman Browser calls covered by IA# 2540.
N DDBLN,DDBZ,DIC,DIR,X,Y,DIRUT,DIROUT,DUOUT,DILN
S DILN=DDBRSA(DDBRSA,"DDBSRL")-2
S:$G(DDBLST)="" DDBLST="^TMP(""DDBLST"",$J)" S DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
I $D(@DDBLST) D
.I $O(@DDBLST@(" "),-1)=1,$G(@DDBLST@(1,"DDBSA"))=DDBSA Q
.S DDBZ=$G(@DDBLST@("A",DDBSA),0)
.S Y=2
.D SAVEDDB^DDBR2(DDBLST,DDBLN),USAVEDDB^DDBR2(DDBLST,+Y)
.S DIROUT=1
N DDBLNA
I $G(DDBLNA,-1)=-1 G PS
I $G(DDBLNA(6))=DDBSA G PS ;if current doc re-selected
I $G(DDBLNA(6))]"",$D(@DDBLST@("APSA",DDBSA)) G PS ;on list
D:DDBLNA>0 SAVEDDB^DDBR2(DDBLST,DDBLN),WP^DDBR2(.DDBLNA)
PS D PSR^DDBR0(1)
Q
;
VERS22(XXY,XXZ) ; this is modified code from SHOWMSG^HLCSRPT1.
; Each node, ^tmp($j,"message",record_ien), invokes this code
; to compile a 'virtual w-p document' when a message is browsed.
I $D(^HLMA(XXY,"MSH",0)) D
.S ^TMP($J,"MESSAGE",XXY,0)=^HLMA(XXY,"MSH",0)
.S YY1=$P(^HLMA(XXY,"MSH",0),U,3),YY2=$P(^HLMA(XXY,"MSH",0),U,4)
E S ^TMP($J,"MESSAGE",XXY,0)="^^1^1" S (YY1,YY2)=1
S XLINE=^HLMA(XXY,0)
S LINE="Record #: "_XXY_" ",LINE=$E(LINE,1,30)
S LINE=LINE_"Message #: "_$P(XLINE,U,2)
S ^TMP($J,"MESSAGE",XXY,1,0)=LINE
S DTE=$P(XLINE,U,1) I $P($G(^HL(772,DTE,0)),U,1)'="" S DTE=$P(^HL(772,DTE,0),U,1),DTE=$E(DTE,4,7)_$E(DTE,2,3)_"."_$P(DTE,".",2)_" "
I $D(^HLMA(XXY,"S")),$P(^HLMA(XXY,"S"),U,1)'="" S DTP=$P(^HLMA(XXY,"S"),U,1) S DTP=$E(DTP,4,7)_$E(DTP,2,3)_"."_$P(DTP,".",2)
E S DTP=" "
S LINE="D/T Entered: "_DTE,LINE=$E(LINE,1,30)_"D/T Processed: "_DTP
S ^TMP($J,"MESSAGE",XXY,2,0)=LINE K DTE,DTP
S LINE="Logical Link: " I $P(XLINE,U,7)'="",($G(^HLCS(870,$P(XLINE,U,7),0))) S LINE=LINE_$P(^HLCS(870,$P(XLINE,U,7),0),U,1)
S LINE=LINE_" ",LINE=$E(LINE,1,30)
S LINE=LINE_"Ack To MSG#: " I $P(XLINE,U,6)'="",$G(^HLMA($P(XLINE,U,6),0)) S LINE=LINE_$P(^HLMA($P(XLINE,U,6),0),U,2)
S ^TMP($J,"MESSAGE",XXY,3,0)=LINE
S DTS="" I $P($G(^HLMA(XXY,"P")),U,2)'="" S DTS=$P(^HLMA(XXY,"P"),U,2),DTS=$E(DTS,4,7)_$E(DTS,2,3)_"."_$P(DTS,".",2)
S LINE="D/T STATUS: "_DTS_" ",LINE=$E(LINE,1,30),LINE=LINE_"STATUS: "
I $P(^HLMA(XXY,"P"),U,2)'="",($G(^HL(771.6,+$P(^HLMA(XXY,"P"),U,1),0))) S LINE=LINE_$P(^HL(771.6,+$P(^HLMA(XXY,"P"),U,1),0),U,1)
S ^TMP($J,"MESSAGE",XXY,4,0)=LINE K DTS
S LINE="ERR MSG: " I $P(^HLMA(XXY,"P"),U,3)'="" S LINE=LINE_$E($P(^HLMA(XXY,"P"),U,3),1,20)
S LINE=LINE_" ",LINE=$E(LINE,1,30)_"ERR TYPE: "
I $P(^HLMA(XXY,"P"),U,4)'="",($D(^HL(771.7,+$P(^HLMA(XXY,"P"),U,4),0))) S LINE=LINE_$P(^HL(771.7,+$P(^HLMA(XXY,"P"),U,4),0),U,1)
S ^TMP($J,"MESSAGE",XXY,5,0)=LINE
S LINE="Sending Appl: " I $P(XLINE,U,11)'="",($D(^HL(771,$P(XLINE,U,11),0))) S LINE=LINE_$P(^HL(771,$P(XLINE,U,11),0),U,1)
S ^TMP($J,"MESSAGE",XXY,6,0)=LINE
S LINE="Receiving Appl: " I $P(XLINE,U,12)'="",($D(^HL(771,$P(XLINE,U,12),0))) S LINE=LINE_$P(^HL(771,$P(XLINE,U,12),0),U,1)
S ^TMP($J,"MESSAGE",XXY,7,0)=LINE
; patch HL*1.6*145 start
; S LINE="Message Type: " I $P(XLINE,U,13)'="",($D(^HL(771.2,$P(XLINE,U,13),0))) S LINE=LINE_$P(^HL(771.2,$P(XLINE,U,13),0),U,1)
N SEG
D HEADSEG^HLCSRPT1(XXY,.SEG)
S LINE="Message Type: "_$G(SEG("MESSAGE TYPE"))
S LINE=LINE_" ",LINE=$E(LINE,1,30)_"Event Type: "
; I $P(XLINE,U,14)'="",($D(^HL(779.001,$P(XLINE,U,14),0))) S LINE=LINE_$P(^HL(779.001,$P(XLINE,U,14),0),U,1)
S LINE=LINE_$G(SEG("EVENT TYPE"))
; patch HL*1.6*145 end
S ^TMP($J,"MESSAGE",XXY,8,0)=LINE K LINE,XLINE
S ^TMP($J,"MESSAGE",XXY,9,0)="MESSAGE HEADER: "
S LN2=10
I $D(^HLMA(XXY,"MSH",0)) D
.S LN1=.5
.F S LN1=$O(^HLMA(XXY,"MSH",LN1)) Q:LN1="" D
.. S ^TMP($J,"MESSAGE",XXY,LN2,0)=^HLMA(XXY,"MSH",LN1,0)
.. ;HL*1.6*107 start: to fix the multiple lines per segment
.. ;S LN2=LN2+1,LN1=LN1+1
.. S LN2=LN2+1
.. ;HL*1.6*107 end
E S ^TMP($J,"MESSAGE",XXY,LN2,0)=" No Header in MSG Admin File (#773)" S LN2=LN2+1
S LN1=.5
S ^TMP($J,"MESSAGE",XXY,LN2,0)="MESSAGE TEXT: ",LN2=LN2+1
I $D(^HL(772,XXZ,"IN",0)) D
.F S LN1=$O(^HL(772,XXZ,"IN",LN1)) Q:(LN1="") D
.. S ^TMP($J,"MESSAGE",XXY,LN2,0)=^HL(772,XXZ,"IN",LN1,0)
.. ;HL*1.6*107 start: to fix the multiple lines per segment
.. ;S LN2=LN2+1,LN1=LN1+1
.. S LN2=LN2+1
.. ;HL*1.6*107 end
..Q
E S ^TMP($J,"MESSAGE",XXY,LN2,0)=" No Message in MSG Text File (#772)" S LN2=LN2+1
S (YY1,YY2)=LN2-1
S Y1Y2=YY1_"^"_YY2
S $P(^TMP($J,"MESSAGE",XXY,0),U,3,4)=Y1Y2
K LN1,LN2,Y1Y2,YY1,YY2
Q
;
EXIT D EXIT^HLCSRPT6 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
HLCSBAR D HLCSBAR^HLCSRPT6 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
TEST D TEST^HLCSRPT6 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSRPT2 10098 printed Dec 13, 2024@01:56:59 Page 2
HLCSRPT2 ;ISC-SF/RAH-TRANS LOG ERROR LIST ;08/25/2010
+1 ;;1.6;HEALTH LEVEL SEVEN;**50,85,107,145,151**;Oct 13, 1995;Build 1
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Calls to SAVEDDB^DDBR2, USAVEDDB^DDBR2, PSR^DDBR0, and WP^DDBR2 supported by IA#2540 & IA#3594
+4 ;
+5 QUIT
+6 ;
EN ; Entry point for reporting error messages.
+1 ;
+2 ; All NEWs below added by HL*1.6*85
+3 NEW BLDOFF,BLDON,DY,ERRDTB,ERRDTE,HLCSCLNT,HLCSDTE,HLCSDTP
+4 NEW HLCSEVN,HLCSEVN1,HLCSEVN2,HLCSHDR,HLCSK,HLCSLINK
+5 NEW HLCSLNK,HLCSMID,HLCSMX,HLCSNREC,HLCSPTR,HLCSRNO,HLCSSRVR
+6 NEW HLCSTITL,HLCSTYP,HLERR,IEN773,LAST773,LASTPDT
+7 NEW LPIENS,NOREC,NUMERR,OLD773,OLDPDT,RVOFF,RVON,SPACE
+8 NEW SPACE20,SPACE25,SPACE30,SPACE80,STOP,TYPEINFO,VERS22
+9 ;
+10 ;HL*1.6*85
DO CLEANGBL
+11 ;
+12 SET (STOP,NOREC)=""
+13 DO SCREEN^HLCSRPT
+14 SET HLCSNREC=BLDON_" ===>>> NO MATCHING RECORDS <<<=== "_BLDOFF
+15 ;HL*1.6*85
SET HLCSTITL="#773-IEN Message-ID Procd Log-Link Msg:Evn IO Sndg-Apl Rcvr-Apl"
+16 SET HLCSPTR=1
SET HLCSRNO=1
+17 SET VERS22=""
+18 ;HL*1.6*85
IF 22'>+$$VERSION^XPDUTL("DI")!($$PATCH^XPDUTL("DI*21.0*32"))
SET VERS22="YES"
+19 IF VERS22'="YES"
Begin DoDot:1
+20 SET ^TMP("DDBPF1Z",$JOB)="D SHOWMSG^HLCSRPT2 Q"
+21 SET HLCSTITL=HLCSTITL_" ERR"
End DoDot:1
+22 IF '$TEST
SET HLCSTITL=HLCSTITL_" "
+23 SET ^TMP($JOB,"LIST","MESSAGE")="^TMP($J,""MESSAGE"",HLCSRNO)"
+24 ;HL*1.6*85
SET ^TMP($JOB,"LIST",HLCSTITL_" ERR")="^TMP(""TLOG"",$J)"
+25 ;
REEN ; Internal Re-entry Point
+1 SET STOP=""
+2 DO WHATERR
if (+$GET(STOP))
QUIT
+3 ;-> HL*1.6*85
if '$$SETUP^HLCSRPT4
QUIT
+4 ;HL*1.6*85
IF TYPEINFO=2
SET HLCSTITL="#773-IEN Message-ID Procd Log-Link Error-type "
+5 DO ERRSRCH
+6 IF ERRDTE[9999999
SET ERRDTE=$$NOW^XLFDT
+7 IF +$GET(STOP)
DO EXIT
QUIT
+8 IF +$GET(NOREC)
WRITE !!,HLCSNREC,!!
SET DIR(0)="E"
DO ^DIR
KILL DIR,X,Y
DO EXIT
QUIT
+9 ;HL*1.6*85
DO DISPLAY^HLCSRPT
+10 ;HL*1.6*85
DO CLEANGBL
+11 DO EXIT
+12 SET STOP=1
+13 QUIT
+14 ;
CLEANGBL ; New subroutine added by HL*1.6*85 to clean up globals
+1 NEW GBL
+2 FOR GBL="LIST","MESSAGE"
KILL ^TMP($JOB,GBL)
+3 FOR GBL="DDBPF1Z","DDBLST","TLOG","TMPLOG"
KILL ^TMP(GBL,$JOB)
+4 QUIT
+5 ;
WHATERR ; Ask for one error code; with default of all
+1 WRITE @IOF,!
SET HLCSHDR="Error Type Selection"
DO HLCSBAR
+2 SET X=""
SET HLCSER="ALL"
+3 SET DIR(0)="PAO^771.7:AEO"
SET DIR("A")="Select Error Type: ALL//"
+4 DO ^DIR
if ($DATA(DTOUT)!($DATA(DUOUT)))
SET STOP=1
+5 IF +$GET(STOP)
KILL DIR,X,Y
QUIT
+6 IF X=""
KILL DIR,X,Y
QUIT
+7 IF Y=-1
WRITE !,X_" NOT VALID "
KILL DIR,X,Y
GOTO WHATERR
+8 SET HLCSTER1=$PIECE(Y,U,1)
SET HLCSTER2=$PIECE(Y,U,2)
KILL DIR,X,Y
+9 SET HLCSER=1
+10 QUIT
+11 ;
ERRSRCH ; Find and report the 'errored' messages (Multiple HL*1.6*85 changes start here)
+1 ; ERRDTB,ERRDTE,NUMERR -- req
+2 NEW NEXT,CT
+3 WRITE !!,"PLEASE WAIT, THIS CAN TAKE AWHILE..."
+4 ;
+5 ;HL*1.6*85 - LOADERR loads all errors, using the user-supplied
+6 ; parameters, and places them in ^TMP. Below, the code
+7 ; now loops thru ^TMP instead of ^HLMA (which happened
+8 ; in LOADERR.)
+9 DO LOADERR^HLCSRPT4
+10 ;
+11 ; Looping starts here...
+12 SET HLCSI=0
SET HLCSST=0
SET HLCSLN=0
+13 FOR
SET HLCSI=$ORDER(^TMP("ERRLST",$JOB,HLCSI))
if HLCSI'>0
QUIT
Begin DoDot:1
+14 SET HLCSN=HLCSI
SET HLCSJ=0
+15 FOR
SET HLCSJ=$ORDER(^TMP("ERRLST",$JOB,HLCSI,HLCSJ))
if HLCSJ'>0
QUIT
Begin DoDot:2
+16 ;HL*1.6*85 changes end here, until noted otherwise below.
+17 +18 IF '$DATA(^HLMA(HLCSJ,0))
QUIT
+19 SET HLCSX=^HLMA(HLCSJ,0)
SET HLCSDTE=$PIECE(HLCSX,U,1)
+20 IF $DATA(^HLMA(HLCSJ,"S"))
SET HLCSDTP=$PIECE(^HLMA(HLCSJ,"S"),U,1)
+21 IF '$TEST
SET HLCSDTP=""
+22 IF $DATA(^HLMA(HLCSJ,"P"))
SET HLCSY=^HLMA(HLCSJ,"P")
+23 IF '$TEST
SET HLCSY=""
+24 IF HLCSER=1
IF (HLCSTER1'=$PIECE(HLCSY,U,4))
QUIT
+25 SET HLCSER1=$PIECE(HLCSY,U,4)
SET HLCSER2=HLCSER1
+26 IF HLCSER1'=""
IF ($DATA(^HL(771.7,HLCSER1,0)))
SET HLCSER1=$PIECE(^HL(771.7,HLCSER1,0),U,1)
+27 SET HLCSERMS=$PIECE(HLCSY,U,3)
+28 SET HLCSLINK=$PIECE(HLCSX,U,7)
SET HLCSLNK=" "
+29 IF HLCSLINK'=""
IF ($DATA(^HLCS(870,HLCSLINK,0)))
SET HLCSLNK=$PIECE(^HLCS(870,HLCSLINK,0),U,1)
+30 ; patch HL*1.6*145 start
+31 ; S HLCSEVN1=$P(HLCSX,U,13) I HLCSEVN1'="",($D(^HL(771.2,HLCSEVN1,0))) S HLCSEVN1=$P(^HL(771.2,HLCSEVN1,0),U,1)
+32 ; S HLCSEVN2=$P(HLCSX,U,14) I HLCSEVN2'="",($D(^HL(779.001,HLCSEVN2,0))) S HLCSEVN2=$P(^HL(779.001,HLCSEVN2,0),U,1)
+33 NEW SEG
+34 DO HEADSEG^HLCSRPT1(HLCSJ,.SEG)
+35 SET HLCSEVN1=$GET(SEG("MESSAGE TYPE"))
+36 SET HLCSEVN2=$GET(SEG("EVENT TYPE"))
+37 ; I HLCSEVN1="" S HLCSEVN1=$$MSGEVN^HLCSRPT5(HLCSJ,2) ;HL*1.6*85
+38 ; I HLCSEVN2="" S HLCSEVN2=$$MSGEVN^HLCSRPT5(HLCSJ,2) ;HL*1.6*85
+39 ; patch HL*1.6*145 end
+40 IF $LENGTH(HLCSEVN1)<3
SET HLCSEVN1=HLCSEVN1_" "
SET HLCSEVN1=$EXTRACT(HLCSEVN1,1,3)
+41 IF $LENGTH(HLCSEVN2)<3
SET HLCSEVN2=HLCSEVN2_" "
SET HLCSEVN2=$EXTRACT(HLCSEVN2,1,3)
+42 SET HLCSEVN=HLCSEVN1_":"_HLCSEVN2
+43 ;HL*1.6*85 - Code overrun moved
DO ERRRPT^HLCSRPT5
+44 QUIT
End DoDot:2
+45 QUIT
End DoDot:1
+46 ;HL*1.6*85
KILL ^TMP("ERRLST",$JOB)
+47 ;HL*1.6*85 Reset ^TMP("TMPLOG",$J) to ^TMP("TLOG",$J)
DO TMPLOG^HLCSRPT4
+48 IF '$DATA(^TMP("TLOG",$JOB,1))
SET NOREC=1
QUIT
+49 ;HL*1.6*85 - HLCSTITL already set above ;S HLCSTITL="IEN Record # MESSAGE ID # Log Link Msg:Evn IO Sndg Apl Rcvr Apl"
+50 IF '$DATA(VERS22)
SET HLCSTITL=HLCSTITL_" ERR"
+51 IF '$TEST
SET HLCSTITL=HLCSTITL_" "
+52 DO TEST
+53 QUIT
+54 ;
SHOWMSG ; Enable switching to specific message (used by PF1Z).
+1 ; If FM version 22 installed, uses VERS22 code, instead.
+2 WRITE @IOF
+3 SET DIR(0)="F:AE"
SET DIR("A")="Enter Record Number: "
+4 DO ^DIR
if $DATA(DIRUT)
QUIT
+5 IF Y=-1!(X="")
QUIT
+6 SET HLCSRNO=X
IF '$DATA(^HLMA(HLCSRNO,0))
Begin DoDot:1
+7 WRITE !!,BLDON," ==> NO SUCH RECORD NUMBER <== ",BLDOFF
HANG 3
End DoDot:1
QUIT
+8 SET HLCSPTR=$PIECE(^HLMA(HLCSRNO,0),"^",1)
+9 SET XXY=HLCSRNO
SET XXZ=HLCSPTR
DO VERS22(XXY,XXZ)
+10 DO SWITCH
+11 QUIT
SWITCH ; Non-standard Fileman Browser calls covered by IA# 2540.
+1 NEW DDBLN,DDBZ,DIC,DIR,X,Y,DIRUT,DIROUT,DUOUT,DILN
+2 SET DILN=DDBRSA(DDBRSA,"DDBSRL")-2
+3 if $GET(DDBLST)=""
SET DDBLST="^TMP(""DDBLST"",$J)"
SET DDBLN=$SELECT($DATA(@DDBLST@("A",DDBSA)):^(DDBSA),1:$ORDER(@DDBLST@(" "),-1)+1)
+4 IF $DATA(@DDBLST)
Begin DoDot:1
+5 IF $ORDER(@DDBLST@(" "),-1)=1
IF $GET(@DDBLST@(1,"DDBSA"))=DDBSA
QUIT
+6 SET DDBZ=$GET(@DDBLST@("A",DDBSA),0)
+7 SET Y=2
+8 DO SAVEDDB^DDBR2(DDBLST,DDBLN)
DO USAVEDDB^DDBR2(DDBLST,+Y)
+9 SET DIROUT=1
End DoDot:1
+10 NEW DDBLNA
+11 IF $GET(DDBLNA,-1)=-1
GOTO PS
+12 ;if current doc re-selected
IF $GET(DDBLNA(6))=DDBSA
GOTO PS
+13 ;on list
IF $GET(DDBLNA(6))]""
IF $DATA(@DDBLST@("APSA",DDBSA))
GOTO PS
+14 if DDBLNA>0
DO SAVEDDB^DDBR2(DDBLST,DDBLN)
DO WP^DDBR2(.DDBLNA)
PS DO PSR^DDBR0(1)
+1 QUIT
+2 ;
VERS22(XXY,XXZ) ; this is modified code from SHOWMSG^HLCSRPT1.
+1 ; Each node, ^tmp($j,"message",record_ien), invokes this code
+2 ; to compile a 'virtual w-p document' when a message is browsed.
+3 IF $DATA(^HLMA(XXY,"MSH",0))
Begin DoDot:1
+4 SET ^TMP($JOB,"MESSAGE",XXY,0)=^HLMA(XXY,"MSH",0)
+5 SET YY1=$PIECE(^HLMA(XXY,"MSH",0),U,3)
SET YY2=$PIECE(^HLMA(XXY,"MSH",0),U,4)
End DoDot:1
+6 IF '$TEST
SET ^TMP($JOB,"MESSAGE",XXY,0)="^^1^1"
SET (YY1,YY2)=1
+7 SET XLINE=^HLMA(XXY,0)
+8 SET LINE="Record #: "_XXY_" "
SET LINE=$EXTRACT(LINE,1,30)
+9 SET LINE=LINE_"Message #: "_$PIECE(XLINE,U,2)
+10 SET ^TMP($JOB,"MESSAGE",XXY,1,0)=LINE
+11 SET DTE=$PIECE(XLINE,U,1)
IF $PIECE($GET(^HL(772,DTE,0)),U,1)'=""
SET DTE=$PIECE(^HL(772,DTE,0),U,1)
SET DTE=$EXTRACT(DTE,4,7)_$EXTRACT(DTE,2,3)_"."_$PIECE(DTE,".",2)_" "
+12 IF $DATA(^HLMA(XXY,"S"))
IF $PIECE(^HLMA(XXY,"S"),U,1)'=""
SET DTP=$PIECE(^HLMA(XXY,"S"),U,1)
SET DTP=$EXTRACT(DTP,4,7)_$EXTRACT(DTP,2,3)_"."_$PIECE(DTP,".",2)
+13 IF '$TEST
SET DTP=" "
+14 SET LINE="D/T Entered: "_DTE
SET LINE=$EXTRACT(LINE,1,30)_"D/T Processed: "_DTP
+15 SET ^TMP($JOB,"MESSAGE",XXY,2,0)=LINE
KILL DTE,DTP
+16 SET LINE="Logical Link: "
IF $PIECE(XLINE,U,7)'=""
IF ($GET(^HLCS(870,$PIECE(XLINE,U,7),0)))
SET LINE=LINE_$PIECE(^HLCS(870,$PIECE(XLINE,U,7),0),U,1)
+17 SET LINE=LINE_" "
SET LINE=$EXTRACT(LINE,1,30)
+18 SET LINE=LINE_"Ack To MSG#: "
IF $PIECE(XLINE,U,6)'=""
IF $GET(^HLMA($PIECE(XLINE,U,6),0))
SET LINE=LINE_$PIECE(^HLMA($PIECE(XLINE,U,6),0),U,2)
+19 SET ^TMP($JOB,"MESSAGE",XXY,3,0)=LINE
+20 SET DTS=""
IF $PIECE($GET(^HLMA(XXY,"P")),U,2)'=""
SET DTS=$PIECE(^HLMA(XXY,"P"),U,2)
SET DTS=$EXTRACT(DTS,4,7)_$EXTRACT(DTS,2,3)_"."_$PIECE(DTS,".",2)
+21 SET LINE="D/T STATUS: "_DTS_" "
SET LINE=$EXTRACT(LINE,1,30)
SET LINE=LINE_"STATUS: "
+22 IF $PIECE(^HLMA(XXY,"P"),U,2)'=""
IF ($GET(^HL(771.6,+$PIECE(^HLMA(XXY,"P"),U,1),0)))
SET LINE=LINE_$PIECE(^HL(771.6,+$PIECE(^HLMA(XXY,"P"),U,1),0),U,1)
+23 SET ^TMP($JOB,"MESSAGE",XXY,4,0)=LINE
KILL DTS
+24 SET LINE="ERR MSG: "
IF $PIECE(^HLMA(XXY,"P"),U,3)'=""
SET LINE=LINE_$EXTRACT($PIECE(^HLMA(XXY,"P"),U,3),1,20)
+25 SET LINE=LINE_" "
SET LINE=$EXTRACT(LINE,1,30)_"ERR TYPE: "
+26 IF $PIECE(^HLMA(XXY,"P"),U,4)'=""
IF ($DATA(^HL(771.7,+$PIECE(^HLMA(XXY,"P"),U,4),0)))
SET LINE=LINE_$PIECE(^HL(771.7,+$PIECE(^HLMA(XXY,"P"),U,4),0),U,1)
+27 SET ^TMP($JOB,"MESSAGE",XXY,5,0)=LINE
+28 SET LINE="Sending Appl: "
IF $PIECE(XLINE,U,11)'=""
IF ($DATA(^HL(771,$PIECE(XLINE,U,11),0)))
SET LINE=LINE_$PIECE(^HL(771,$PIECE(XLINE,U,11),0),U,1)
+29 SET ^TMP($JOB,"MESSAGE",XXY,6,0)=LINE
+30 SET LINE="Receiving Appl: "
IF $PIECE(XLINE,U,12)'=""
IF ($DATA(^HL(771,$PIECE(XLINE,U,12),0)))
SET LINE=LINE_$PIECE(^HL(771,$PIECE(XLINE,U,12),0),U,1)
+31 SET ^TMP($JOB,"MESSAGE",XXY,7,0)=LINE
+32 ; patch HL*1.6*145 start
+33 ; S LINE="Message Type: " I $P(XLINE,U,13)'="",($D(^HL(771.2,$P(XLINE,U,13),0))) S LINE=LINE_$P(^HL(771.2,$P(XLINE,U,13),0),U,1)
+34 NEW SEG
+35 DO HEADSEG^HLCSRPT1(XXY,.SEG)
+36 SET LINE="Message Type: "_$GET(SEG("MESSAGE TYPE"))
+37 SET LINE=LINE_" "
SET LINE=$EXTRACT(LINE,1,30)_"Event Type: "
+38 ; I $P(XLINE,U,14)'="",($D(^HL(779.001,$P(XLINE,U,14),0))) S LINE=LINE_$P(^HL(779.001,$P(XLINE,U,14),0),U,1)
+39 SET LINE=LINE_$GET(SEG("EVENT TYPE"))
+40 ; patch HL*1.6*145 end
+41 SET ^TMP($JOB,"MESSAGE",XXY,8,0)=LINE
KILL LINE,XLINE
+42 SET ^TMP($JOB,"MESSAGE",XXY,9,0)="MESSAGE HEADER: "
+43 SET LN2=10
+44 IF $DATA(^HLMA(XXY,"MSH",0))
Begin DoDot:1
+45 SET LN1=.5
+46 FOR
SET LN1=$ORDER(^HLMA(XXY,"MSH",LN1))
if LN1=""
QUIT
Begin DoDot:2
+47 SET ^TMP($JOB,"MESSAGE",XXY,LN2,0)=^HLMA(XXY,"MSH",LN1,0)
+48 ;HL*1.6*107 start: to fix the multiple lines per segment
+49 ;S LN2=LN2+1,LN1=LN1+1
+50 SET LN2=LN2+1
+51 ;HL*1.6*107 end
End DoDot:2
End DoDot:1
+52 IF '$TEST
SET ^TMP($JOB,"MESSAGE",XXY,LN2,0)=" No Header in MSG Admin File (#773)"
SET LN2=LN2+1
+53 SET LN1=.5
+54 SET ^TMP($JOB,"MESSAGE",XXY,LN2,0)="MESSAGE TEXT: "
SET LN2=LN2+1
+55 IF $DATA(^HL(772,XXZ,"IN",0))
Begin DoDot:1
+56 FOR
SET LN1=$ORDER(^HL(772,XXZ,"IN",LN1))
if (LN1="")
QUIT
Begin DoDot:2
+57 SET ^TMP($JOB,"MESSAGE",XXY,LN2,0)=^HL(772,XXZ,"IN",LN1,0)
+58 ;HL*1.6*107 start: to fix the multiple lines per segment
+59 ;S LN2=LN2+1,LN1=LN1+1
+60 SET LN2=LN2+1
+61 ;HL*1.6*107 end
+62 QUIT
End DoDot:2
End DoDot:1
+63 IF '$TEST
SET ^TMP($JOB,"MESSAGE",XXY,LN2,0)=" No Message in MSG Text File (#772)"
SET LN2=LN2+1
+64 SET (YY1,YY2)=LN2-1
+65 SET Y1Y2=YY1_"^"_YY2
+66 SET $PIECE(^TMP($JOB,"MESSAGE",XXY,0),U,3,4)=Y1Y2
+67 KILL LN1,LN2,Y1Y2,YY1,YY2
+68 QUIT
+69 ;
EXIT ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
DO EXIT^HLCSRPT6
QUIT
HLCSBAR ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
DO HLCSBAR^HLCSRPT6
QUIT
TEST ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
DO TEST^HLCSRPT6
QUIT
