- 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 Feb 18, 2025@23:25:37 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