HLOSTRAC ;OIFO-OAK/RBN/CJM - HLO SERVER TRACE Tool ; 02/22/2011
;;1.6;HEALTH LEVEL SEVEN;**146,147,153,172**;Oct 13, 1995;Build 11
;Per VA Directive 6402, this routine should not be modified.
;;
;; HLO SERVER TRACE Tool
;; *** For troubleshooting HLO server issues ***
;; The HLO server runs in the foreground and writes trace
;; statements to the screen.
;;
TRACE ;
N CONF,HLOTRACE
S HLOTRACE("COUNT")=0
S HLOTRACE("ERRORS")=0
I '$G(DUZ) W !,"Your DUZ must be set!" Q
D OWNSKEY^XUSRB(.CONF,"XUPROG",DUZ)
I 'CONF(0) D Q
. W !!," Sorry, you are not authorized to use this tool.",!!
I '(($P($$VERSION^%ZOSV(1),"/",1)[("Cache"))!($$VERSION^%ZOSV(1)["IRIS")) D Q D Q
.W !!," Sorry, this tool can only be used under Cache or IRIS",!!
N IEN,LINK,PORT
S IEN=+$O(^HLD(779.1,0))
D:IEN
.S LINK=$P($G(^HLD(779.1,IEN,0)),"^",10)
.S LINK=$P($G(^HLCS(870,LINK,0)),"^")
S:'$L($G(LINK)) LINK="HLO DEFAULT LISTENER"
W !,"What port do you want to listen on while in server trace mode?"
W !,"The port must be free. If a server already has it opened then the"
W !,"server needs to be stopped before starting in server trace mode."
S PORT=$$ASKPORT^HLOUSRA(LINK)
Q:'PORT
D SETBREAKS
;
ZB ZB999^HLOSRVR:"N":1:"S LINK(""PORT"")=PORT,LINK(""SERVER"")=""1^S"",LINK(""LLP"")=""TCP"""
;
W !!,"Starting the server, hit the CTRL-C key to stop the server...",!!
READ D
.N $ETRAP,$ESTACK
.S $ETRAP="G ERROR^HLOSTRAC"
.D SERVER^HLOSRVR(LINK)
.U $PRINCIPAL
.W !,"DONE!"
ZB /CLEAR
Q
;
SETBREAKS ;
ZB /CLEAR
ZB /INTERRUPT:NORMAL
;
;!!!! for debuggng only
;ZB ERROR^HLOSTRAC
;!!!!!!
;
;
;report errors
ZB ZB1^HLOSRVR:"N":1:"S $ETRAP=""G ZB3^HLOSTRAC"""
;
;allow Server Trace tool to run even if HLO is shut down
ZB ZB25^HLOPROC:"N":1:"S RET=0"
ZB READMSG^HLOSRVR1:"N":1:"D READMSG^HLOSTRAC"
ZB PARSEHDR^HLOPRS:"N":1:"D PARSEHDR^HLOSTRAC"
ZB DUP^HLOSRVR1:"N":1:"D DUP^HLOSTRAC"
ZB CLOSE^HLOT:"N":1:"D CLOSE^HLOSTRAC"
;set break ZB10 in the client(start of $$READHDR^HLOT)
ZB ZB10^HLOT:"N":1:"D ZB10^HLOSTRAC"
;set break ZB11 in the client(end of $$READHDR^HLOT)
ZB ZB11^HLOT:"N":1:"D ZB11^HLOSTRAC"
;set break ZB12 in the client(start of $$READSEG^HLOT)
ZB ZB12^HLOT:"N":1:"D ZB12^HLOSTRAC"
;set break ZB13 in the client(end of $$READSEG^HLOT)
ZB ZB13^HLOT:"N":1:"D ZB13^HLOSTRAC"
;set break ZB14 in the client(start of $$WRITESEG^HLOT)
ZB ZB14^HLOT:"N":1:"D ZB14^HLOSTRAC"
;set break ZB15 in the client(end of $$WRITESEG^HLOT)
ZB ZB15^HLOT:"N":1:"D ZB15^HLOSTRAC"
;set break ZB16 in the client(start of $$WRITEHDR^HLOT)
ZB ZB16^HLOT:"N":1:"D ZB16^HLOSTRAC"
;set break ZB17 in the client(end of $$WRITEHDR^HLOT)
ZB ZB17^HLOT:"N":1:"D ZB17^HLOSTRAC"
;set break ZB18 in the client(start of $$ENDMSG^HLOT)
ZB ZB18^HLOT:"N":1:"D ZB18^HLOSTRAC"
;set break ZB19 in the server(end of $$ENDMSG^HLOT)
ZB ZB19^HLOT:"N":1:"D ZB19^HLOSTRAC"
ZB ZB25^HLOTCP:"N":1:"D ZB25^HLOSTRAC"
ZB ZB26^HLOTCP:"N":1:"D ZB26^HLOSTRAC"
;
ZB ZB27^HLOTCP:"N":1:"D ZB27^HLOSTRAC"
;
ZB ZB28^HLOTCP:"N":1:"D ZB28^HLOSTRAC"
;set break ZB29 in the server(after parsing the message header)
ZB ZB29^HLOSRVR1:"N":1:"D ZB29^HLOSTRAC"
;set break ZB30 in the server(afterchecking if duplicate)
ZB ZB30^HLOSRVR1:"N":1:"D ZB30^HLOSTRAC"
ZB ZB31^HLOTCP:"N":1:"D WRITE^HLOTRACE(""Beginning READ over TCP..."")"
ZB ZB32^HLOTCP:"N":1:"D ZB32^HLOTRACE"
Q
;
WRITE(MSG) ;
N OLD
S OLD=$IO
U $PRINCIPAL
W !,?5,"Time: ",$$NOW^XLFDT," ",MSG
U OLD
Q
WRITE2(MSG,VALUE) ;
N OLD,I
S OLD=$IO
U $PRINCIPAL
W !,?5,"Time: ",$$NOW^XLFDT," ",MSG
S I=0
W:$O(VALUE(0)) !
F S I=$O(VALUE(I)) Q:'I W VALUE(I)
U OLD
Q
WRITE3(MSG) ;
N OLD
S OLD=$IO
U $PRINCIPAL
W !,MSG
U OLD
Q
READMSG ;
;
S HLOTRACE("COUNT")=HLOTRACE("COUNT")+1
S HLOTRACE("ERRORS")=0
I HLOTRACE("COUNT")>10 D
.N OLD,SEND
.S OLD=$IO
.U $PRINCIPAL
.W !
.S SEND=$$ASKYESNO^HLOUSR2("Do you want to trace more message transmissions","NO")
.I 'SEND S $ECODE=",UHLOSTOP,"
.U OLD
W !
D WRITE3^HLOSTRAC("Beginning to read next message...")
Q
PARSEHDR ;
D WRITE^HLOSTRAC("Parsing the message header...")
Q
DUP ;
D WRITE^HLOSTRAC("Checking if duplicate message...")
Q
CLOSE ;
D WRITE^HLOSTRAC("Closing the port...")
Q
;
ERROR ;
I ($ECODE["EDITED") Q:$QUIT "" Q
I ($ECODE["ZINTERRUPT") Q:$QUIT "" Q
D WRITE^HLOSTRAC("*** ERROR *** : "_$ECODE)
S HLOTRACE("ERRORS")=HLOTRACE("ERRORS")+1
I HLOTRACE("ERRORS")>5 Q:$QUIT "" Q
S $ECODE=""
G READ^HLOSTRAC
Q:$QUIT "" Q
Q
ZB10 ;
D WRITE^HLOSTRAC("Getting message header...")
Q
ZB11 I $D(HDR) D WRITE2^HLOSTRAC(" Header follows...",.HDR)
D WRITE^HLOSTRAC($S(SUCCESS:"Got the header!",1:"**** FAILED TO COMPLETE *****"))
Q
ZB12 ;
D WRITE^HLOSTRAC("Getting next segment...")
Q
ZB13 I $D(SEG) D WRITE2^HLOSTRAC(" Segment follows...",.SEG)
D WRITE^HLOSTRAC($S(RETURN:"Got the segment!",$G(HLCSTATE("MESSAGE ENDED")):"No more segments!",1:"**** FAILED TO COMPLETE *****"))
Q
ZB14 ;
D WRITE2^HLOSTRAC("Writing next segment...",.SEG)
Q
ZB15 D WRITE^HLOSTRAC($S(RETURN:"Completed!",1:"**** FAILED TO COMPLETE *****"))
Q
ZB16 ;
D WRITE3^HLOSTRAC("Beginning to write the commit acknowledgment...")
D WRITE2^HLOSTRAC("Writing header segment...",.HDR)
Q
ZB17 D WRITE^HLOSTRAC($S(SUCCESS:"Completed!",1:"**** FAILED TO COMPLETE *****"))
Q
ZB18 ;
D WRITE^HLOSTRAC("Writing message terminators and flushing buffer...")
Q
ZB19 D WRITE^HLOSTRAC($S(RETURN:"Completed!",1:"**** FAILED TO COMPLETE *****"))
Q
ZB25 D WRITE^HLOSTRAC("Opening the port...")
Q
ZB26 D WRITE^HLOSTRAC("Waiting for remote client to connect...")
Q
ZB27 D WRITE^HLOSTRAC("Remote client connected...")
Q
ZB28 D:'$G(HLCSTATE("CONNECTED")) WRITE^HLOSTRAC("**** UNABLE TO OPEN PORT *****")
Q
ZB29 D WRITE3^HLOSTRAC("*** THE MESSAGE HEADER COULD NOT BE PARSED ***")
Q
ZB30 D WRITE3^HLOSTRAC("*** THE MESSAGE IS A DUPLICATE AND WILL BE DISCARDED ***")
D WRITE3^HLOSTRAC("*** THE ORIGINAL COMMIT ACKNOWLEDMENT WILL BE RETURNED ***")
Q
;
ZB3 ;
S $ETRAP="Q:$QUIT """" Q"
D END^HLOSRVR
N CON,MSG
S CON=($ZA\8192#2)
S MSG="Error encountered, $ECODE="_$ECODE
D WRITE^HLOTRACE(MSG)
S MSG=$S(CON:" TCP connection still active",1:" TCP connection was dropped")
D WRITE3^HLOTRACE(MSG)
I ($ECODE["EDITED") Q:$QUIT "" Q
I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
.;
E D
.D ^%ZTER
Q
ZB32 D:('$G(RETURN)) WRITE^HLOTRACE("**** FAILED ****")
D:$G(RETURN) WRITE3^HLOTRACE("")
D:$G(RETURN) WRITE3^HLOTRACE($G(BUF))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOSTRAC 6740 printed Dec 13, 2024@01:59:12 Page 2
HLOSTRAC ;OIFO-OAK/RBN/CJM - HLO SERVER TRACE Tool ; 02/22/2011
+1 ;;1.6;HEALTH LEVEL SEVEN;**146,147,153,172**;Oct 13, 1995;Build 11
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;;
+4 ;; HLO SERVER TRACE Tool
+5 ;; *** For troubleshooting HLO server issues ***
+6 ;; The HLO server runs in the foreground and writes trace
+7 ;; statements to the screen.
+8 ;;
TRACE ;
+1 NEW CONF,HLOTRACE
+2 SET HLOTRACE("COUNT")=0
+3 SET HLOTRACE("ERRORS")=0
+4 IF '$GET(DUZ)
WRITE !,"Your DUZ must be set!"
QUIT
+5 DO OWNSKEY^XUSRB(.CONF,"XUPROG",DUZ)
+6 IF 'CONF(0)
Begin DoDot:1
+7 WRITE !!," Sorry, you are not authorized to use this tool.",!!
End DoDot:1
QUIT
+8 IF '(($PIECE($$VERSION^%ZOSV(1),"/",1)[("Cache"))!($$VERSION^%ZOSV(1)["IRIS"))
Begin DoDot:1
+9 WRITE !!," Sorry, this tool can only be used under Cache or IRIS",!!
End DoDot:1
QUIT D
QUIT
+10 NEW IEN,LINK,PORT
+11 SET IEN=+$ORDER(^HLD(779.1,0))
+12 if IEN
Begin DoDot:1
+13 SET LINK=$PIECE($GET(^HLD(779.1,IEN,0)),"^",10)
+14 SET LINK=$PIECE($GET(^HLCS(870,LINK,0)),"^")
End DoDot:1
+15 if '$LENGTH($GET(LINK))
SET LINK="HLO DEFAULT LISTENER"
+16 WRITE !,"What port do you want to listen on while in server trace mode?"
+17 WRITE !,"The port must be free. If a server already has it opened then the"
+18 WRITE !,"server needs to be stopped before starting in server trace mode."
+19 SET PORT=$$ASKPORT^HLOUSRA(LINK)
+20 if 'PORT
QUIT
+21 DO SETBREAKS
+22 ;
+23
*** ERROR ***
+24 ;
+25 WRITE !!,"Starting the server, hit the CTRL-C key to stop the server...",!!
READ Begin DoDot:1
+1 NEW $ETRAP,$ESTACK
+2 SET $ETRAP="G ERROR^HLOSTRAC"
+3 DO SERVER^HLOSRVR(LINK)
+4 USE $PRINCIPAL
+5 WRITE !,"DONE!"
End DoDot:1
+6
*** ERROR ***
+7 QUIT
+8 ;
SETBREAKS ;
+1
*** ERROR ***
+2
*** ERROR ***
+3 ;
+4 ;!!!! for debuggng only
+5 ;ZB ERROR^HLOSTRAC
+6 ;!!!!!!
+7 ;
+8 ;
+9 ;report errors
+10
*** ERROR ***
+11 ;
+12 ;allow Server Trace tool to run even if HLO is shut down
+13
*** ERROR ***
+14
*** ERROR ***
+15
*** ERROR ***
+16
*** ERROR ***
+17
*** ERROR ***
+18 ;set break ZB10 in the client(start of $$READHDR^HLOT)
+19
*** ERROR ***
+20 ;set break ZB11 in the client(end of $$READHDR^HLOT)
+21
*** ERROR ***
+22 ;set break ZB12 in the client(start of $$READSEG^HLOT)
+23
*** ERROR ***
+24 ;set break ZB13 in the client(end of $$READSEG^HLOT)
+25
*** ERROR ***
+26 ;set break ZB14 in the client(start of $$WRITESEG^HLOT)
+27
*** ERROR ***
+28 ;set break ZB15 in the client(end of $$WRITESEG^HLOT)
+29
*** ERROR ***
+30 ;set break ZB16 in the client(start of $$WRITEHDR^HLOT)
+31
*** ERROR ***
+32 ;set break ZB17 in the client(end of $$WRITEHDR^HLOT)
+33
*** ERROR ***
+34 ;set break ZB18 in the client(start of $$ENDMSG^HLOT)
+35
*** ERROR ***
+36 ;set break ZB19 in the server(end of $$ENDMSG^HLOT)
+37
*** ERROR ***
+38
*** ERROR ***
+39
*** ERROR ***
+40 ;
+41
*** ERROR ***
+42 ;
+43
*** ERROR ***
+44 ;set break ZB29 in the server(after parsing the message header)
+45
*** ERROR ***
+46 ;set break ZB30 in the server(afterchecking if duplicate)
+47
*** ERROR ***
+48
*** ERROR ***
+49
*** ERROR ***
+50 QUIT
+51 ;
WRITE(MSG) ;
+1 NEW OLD
+2 SET OLD=$IO
+3 USE $PRINCIPAL
+4 WRITE !,?5,"Time: ",$$NOW^XLFDT," ",MSG
+5 USE OLD
+6 QUIT
WRITE2(MSG,VALUE) ;
+1 NEW OLD,I
+2 SET OLD=$IO
+3 USE $PRINCIPAL
+4 WRITE !,?5,"Time: ",$$NOW^XLFDT," ",MSG
+5 SET I=0
+6 if $ORDER(VALUE(0))
WRITE !
+7 FOR
SET I=$ORDER(VALUE(I))
if 'I
QUIT
WRITE VALUE(I)
+8 USE OLD
+9 QUIT
WRITE3(MSG) ;
+1 NEW OLD
+2 SET OLD=$IO
+3 USE $PRINCIPAL
+4 WRITE !,MSG
+5 USE OLD
+6 QUIT
READMSG ;
+1 ;
+2 SET HLOTRACE("COUNT")=HLOTRACE("COUNT")+1
+3 SET HLOTRACE("ERRORS")=0
+4 IF HLOTRACE("COUNT")>10
Begin DoDot:1
+5 NEW OLD,SEND
+6 SET OLD=$IO
+7 USE $PRINCIPAL
+8 WRITE !
+9 SET SEND=$$ASKYESNO^HLOUSR2("Do you want to trace more message transmissions","NO")
+10 IF 'SEND
SET $ECODE=",UHLOSTOP,"
+11 USE OLD
End DoDot:1
+12 WRITE !
+13 DO WRITE3^HLOSTRAC("Beginning to read next message...")
+14 QUIT
PARSEHDR ;
+1 DO WRITE^HLOSTRAC("Parsing the message header...")
+2 QUIT
DUP ;
+1 DO WRITE^HLOSTRAC("Checking if duplicate message...")
+2 QUIT
CLOSE ;
+1 DO WRITE^HLOSTRAC("Closing the port...")
+2 QUIT
+3 ;
ERROR ;
+1 IF ($ECODE["EDITED")
if $QUIT
QUIT ""
QUIT
+2 IF ($ECODE["ZINTERRUPT")
if $QUIT
QUIT ""
QUIT
+3 DO WRITE^HLOSTRAC("*** ERROR *** : "_$ECODE)
+4 SET HLOTRACE("ERRORS")=HLOTRACE("ERRORS")+1
+5 IF HLOTRACE("ERRORS")>5
if $QUIT
QUIT ""
QUIT
+6 SET $ECODE=""
+7 GOTO READ^HLOSTRAC
+8 if $QUIT
QUIT ""
QUIT
+9 QUIT
ZB10 ;
+1 DO WRITE^HLOSTRAC("Getting message header...")
+2 QUIT
ZB11 IF $DATA(HDR)
DO WRITE2^HLOSTRAC(" Header follows...",.HDR)
+1 DO WRITE^HLOSTRAC($SELECT(SUCCESS:"Got the header!",1:"**** FAILED TO COMPLETE *****"))
+2 QUIT
ZB12 ;
+1 DO WRITE^HLOSTRAC("Getting next segment...")
+2 QUIT
ZB13 IF $DATA(SEG)
DO WRITE2^HLOSTRAC(" Segment follows...",.SEG)
+1 DO WRITE^HLOSTRAC($SELECT(RETURN:"Got the segment!",$GET(HLCSTATE("MESSAGE ENDED")):"No more segments!",1:"**** FAILED TO COMPLETE *****"))
+2 QUIT
ZB14 ;
+1 DO WRITE2^HLOSTRAC("Writing next segment...",.SEG)
+2 QUIT
ZB15 DO WRITE^HLOSTRAC($SELECT(RETURN:"Completed!",1:"**** FAILED TO COMPLETE *****"))
+1 QUIT
ZB16 ;
+1 DO WRITE3^HLOSTRAC("Beginning to write the commit acknowledgment...")
+2 DO WRITE2^HLOSTRAC("Writing header segment...",.HDR)
+3 QUIT
ZB17 DO WRITE^HLOSTRAC($SELECT(SUCCESS:"Completed!",1:"**** FAILED TO COMPLETE *****"))
+1 QUIT
ZB18 ;
+1 DO WRITE^HLOSTRAC("Writing message terminators and flushing buffer...")
+2 QUIT
ZB19 DO WRITE^HLOSTRAC($SELECT(RETURN:"Completed!",1:"**** FAILED TO COMPLETE *****"))
+1 QUIT
ZB25 DO WRITE^HLOSTRAC("Opening the port...")
+1 QUIT
ZB26 DO WRITE^HLOSTRAC("Waiting for remote client to connect...")
+1 QUIT
ZB27 DO WRITE^HLOSTRAC("Remote client connected...")
+1 QUIT
ZB28 if '$GET(HLCSTATE("CONNECTED"))
DO WRITE^HLOSTRAC("**** UNABLE TO OPEN PORT *****")
+1 QUIT
ZB29 DO WRITE3^HLOSTRAC("*** THE MESSAGE HEADER COULD NOT BE PARSED ***")
+1 QUIT
ZB30 DO WRITE3^HLOSTRAC("*** THE MESSAGE IS A DUPLICATE AND WILL BE DISCARDED ***")
+1 DO WRITE3^HLOSTRAC("*** THE ORIGINAL COMMIT ACKNOWLEDMENT WILL BE RETURNED ***")
+2 QUIT
+3 ;
ZB3 ;
+1 SET $ETRAP="Q:$QUIT """" Q"
+2 DO END^HLOSRVR
+3 NEW CON,MSG
+4 SET CON=($ZA\8192#2)
+5 SET MSG="Error encountered, $ECODE="_$ECODE
+6 DO WRITE^HLOTRACE(MSG)
+7 SET MSG=$SELECT(CON:" TCP connection still active",1:" TCP connection was dropped")
+8 DO WRITE3^HLOTRACE(MSG)
+9 IF ($ECODE["EDITED")
if $QUIT
QUIT ""
QUIT
+10 IF ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR")
Begin DoDot:1
+11 ;
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 DO ^%ZTER
End DoDot:1
+14 QUIT
ZB32 if ('$GET(RETURN))
DO WRITE^HLOTRACE("**** FAILED ****")
+1 if $GET(RETURN)
DO WRITE3^HLOTRACE("")
+2 if $GET(RETURN)
DO WRITE3^HLOTRACE($GET(BUF))
+3 QUIT
