HLOPING.m

HLOPING ;ALB/CJM - HLO PING UTILITY 10/4/94 1pm ; 07/12/2012

 ;;1.6;HEALTH LEVEL SEVEN;**147,155,158,172**;Oct 13, 1995;Build 11

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 ;

PING ;

 I '$G(DUZ) W !,"Your DUZ must be set!" Q

 N LINK,CONF,HLCSTATE,PORT,LINK,HLODONE

 S HLODONE=0

 I '(($P($$VERSION^%ZOSV(1),"/",1)[("Cache"))!($$VERSION^%ZOSV(1)["IRIS")) D  Q

 .W !!,"   Sorry, this tool can only be used under Cache or IRIS",!!

 W !,"What HL Logical Link do you want to test?"

 S LINK=$$ASKLINK^HLOUSR

 Q:LINK=""

 I $$NOPING(LINK) W !,"That link does not allowing PINGING!" D PAUSE^VALM1 Q

 S PORT=$$ASKPORT(LINK)

 Q:'PORT

 L +^HLB("QUEUE","OUT",LINK_":"_PORT,"HLOPING"_$J):1

 D STOPQUE^HLOQUE("OUT","HLOPING"_$J)

 D BREAKS

 D CHECKAPP

 I $$ADDMSG(LINK) D

 .ZB /INTERRUPT:NORMAL ;disable CTRL-C breaks

 .S WORK("QUEUE")="HLOPING"_$J,WORK("LINK")=LINK_":"_PORT

 .D DOWORK^HLOCLNT(.WORK)

 .D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)

 .;

 .U $PRINCIPAL

 D PURGE(LINK_":"_PORT)

 ZB /CLEAR

 L -^HLB("QUEUE","OUT",LINK_":"_PORT,"HLOPING"_$J)

 D STARTQUE^HLOQUE("OUT","HLOPING"_$J)

 Q

 ;

NOPING(LINK) ;

 N IEN,RETURN

 S RETURN=1

 S IEN=$O(^HLCS(870,"B",LINK,0))

 I IEN S RETURN=$P($G(^HLCS(870,IEN,0)),"^",24)

 Q RETURN

 ;

ASKPORT(LINK) ;

 N IEN,NODE,HLOPORT,HL7PORT,DIR,X,Y

 S IEN=$O(^HLCS(870,"B",LINK,0))

 Q:'IEN ""

 S NODE=$G(^HLCS(870,IEN,400))

 S HLOPORT=$P(NODE,"^",8)

 S:'HLOPORT HLOPORT=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":5001,1:5026)

 S HL7PORT=$P(NODE,"^",2)

 S:'HL7PORT HL7PORT=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":5000,1:5025)

 W !,"Do you want to PING the port used by HLO or the one used by HL7 1.6?"

 S DIR(0)="S^1:HLO     --> Port #"_HLOPORT_";2:HL7 1.6 --> Port #"_HL7PORT

 S DIR("B")=1

 D ^DIR

 Q:'X ""

 Q:$D(DUOUT) ""

 Q:X=1 HLOPORT

 Q:X=2 HL7PORT

 Q ""

ADDMSG(LINK) ;

 N PARMS,MSG,SEG,ERROR

 S PARMS("MESSAGE TYPE")="ZZZ"

 S PARMS("EVENT")="ZZZ"

 I '$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR) W !,"ERROR",ERROR Q 0

 D SET^HLOAPI(.SEG,"NTE",0)

 D SET^HLOAPI(.SEG,"This is a PING message to test connectivity. Sender DUZ: "_$G(DUZ),1)

 I '$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR) W !,"ERROR",ERROR Q 0

 S PARMS("SENDING APPLICATION")="HLO PING CLIENT",WHOTO("RECEIVING APPLICATION")="HLO PING SERVER",WHOTO("FACILITY LINK NAME")=LINK

 S PARMS("ACCEPT ACK TYPE")="AL"

 S PARMS("APP ACK TYPE")="NE"

 S PARMS("QUEUE")="HLOPING"_$J

 I '$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR) W !,"There is a problem in the setup!",!,ERROR Q 0

 Q 1

 ;

PURGE(LINK) ;

 N IEN

 S IEN=0

 F  S IEN=$O(^HLB("QUEUE","OUT",LINK,"HLOPING"_$J,IEN)) Q:'IEN  D DEQUE^HLOQUE(LINK,"HLOPING"_$J,"OUT",IEN),SETPURGE^HLOUSR7(IEN)

 Q

 ;

BREAKS ;

 ZB /CLEAR

 ;

 ZB SEND^HLOAPI1:"N":1:"S HLMSTATE(""STATUS"",""PORT"")="_PORT

 ZB CHECKWHO^HLOASUB1:"N":1:"S WHO(""PORT"")="_PORT

 ZB ZB25^HLOASUB1:"N":1:"D ZB25^HLOPING"

 ;set break in $$STOPPED^HLOQUE to circumvent shutdown of the queue

 ZB ZB0^HLOQUE:"N":1:"S RET=0"

 ;set break in $$IFSHUT^HLOTLNK to circumvent shutdown of the link

 ZB ZB0^HLOTLNK:"N":1:"S RET=0"

 ;set break at ZB1 in client ($$CONNECT)

 ;

 ZB ZB1^HLOCLNT1:"N":1:"D WRITE^HLOPING(""Trying to connect..."")"

 ;

 ;set break at ZB2 in client (end of $$CONNECT)

 ZB ZB2^HLOCLNT1:"N":1:"D ZB2^HLOPING"

 ;

 ;set break at ZB6 in client (start of $$TRANSMIT^HLOCLNT1)

 ZB ZB6^HLOCLNT1:"N":1:"D WRITE^HLOPING(""Sending PING ..."")"

 ;set break at ZB7 in client (end of $$TRANSMIT^HLOCLNT1)

 ZB ZB7^HLOCLNT1:"N":1:"D WRITE^HLOPING(""PING sent!"")"

 ;set break at ZB8 in client (start of $$READACK^HLOCLNT1)

 ZB ZB8^HLOCLNT1:"N":1:"D WRITE^HLOPING(""Reading acknowledgment...."")"

 ;set break at ZB9 in client (end of $$READACK^HLOCLNT1)

 ;

 ZB ZB9^HLOCLNT1:"N":1:"D ZB9^HLOPING"

 ;

 ;set break at ZB4 in client (FOR loop on the outgoing queue)

 ZB ZB4^HLOCLNT:"N":1:"S SUCCESS=0 I 'HLODONE S (SUCCESS,HLODONE)=1"

 ;

 ;set status to SU so that the PING doesn't appear on the error report

 ZB ZB22^HLOCLNT:"N":1:"S $P(UPDATE,""^"",3)=""SU"",$P(UPDATE,""^"",4)=1"

 ;

 ZB ZB24^HLOCLNT1:"N":1:"D ZB24^HLOPING"

 ZB ZB27^HLOT:"N":1:"D ZB27^HLOPING"

 ;

 ;set break at ZB3 in client (ERROR TRAP)

 ZB ZB3^HLOCLNT:"N":1:"D ZB3^HLOPING"

 Q

 ;

CHECKAPP ;

 I '$O(^HLD(779.2,"C","HLO PING CLIENT",0)) D

 .N DATA,ERROR

 .S DATA(.01)="HLO PING CLIENT"

 .D ADD^HLOASUB1(779.2,,.DATA)

 Q

WRITE(MSG) ;

 N OLD

 S OLD=$IO

 U $PRINCIPAL

 W !,MSG

 U OLD

 Q

ZB2 ;

 D WRITE($S('HLCSTATE("CONNECTED"):"Unable to Connect!",1:"Connected!"))

 ;!!!!!!!!!!!!

 ;F I=1:1:15 H 1

 Q

ZB3 ;

 N CON,MSG

 S CON=($ZA\8192#2)

 S MSG="Error encountered, $ECODE="_$ECODE

 D WRITE(MSG)

 S MSG=$S(CON:"           TCP connection still active",1:"          TCP connection was dropped")

 D WRITE(MSG)

 D ^%ZTER

 Q

ZB9 ;

 I $G(SUCCESS) D

 .D WRITE("Acknowledgment received!")

 E  D

 .D WRITE("Acknowledgment NOT returned!")

 ;!!!!!!!!!!!!

 ;H 50

 Q

ZB24 ;

 S HLCSTATE("LINK","SHUTDOWN")=0

 Q

ZB25 ;

 I '$L(PARMS("RECEIVING FACILITY",2)),'PARMS("RECEIVING FACILITY",1) S PARMS("RECEIVING FACILITY",2)="REMOTE FACILITY TO PING"

 Q

 ;

ZB27 ;

 Q:'$G(HLCSTATE("LOCK FAILED"))

 D WRITE("Remote server is single threaded and is locked by another process!")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---HLOPING   5269     printed  Mar 13, 2025@21:03:48                                                                                                                                                                                                     Page 2

HLOPING   ;ALB/CJM - HLO PING UTILITY 10/4/94 1pm ; 07/12/2012

 +1       ;;1.6;HEALTH LEVEL SEVEN;**147,155,158,172**;Oct 13, 1995;Build 11

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ;

PING      ;

 +1        IF '$GET(DUZ)

               WRITE !,"Your DUZ must be set!"

               QUIT 

 +2        NEW LINK,CONF,HLCSTATE,PORT,LINK,HLODONE

 +3        SET HLODONE=0

 +4        IF '(($PIECE($$VERSION^%ZOSV(1),"/",1)[("Cache"))!($$VERSION^%ZOSV(1)["IRIS"))

               Begin DoDot:1

 +5                WRITE !!,"   Sorry, this tool can only be used under Cache or IRIS",!!

               End DoDot:1

               QUIT 

 +6        WRITE !,"What HL Logical Link do you want to test?"

 +7        SET LINK=$$ASKLINK^HLOUSR

 +8        if LINK=""

               QUIT 

 +9        IF $$NOPING(LINK)

               WRITE !,"That link does not allowing PINGING!"

               DO PAUSE^VALM1

               QUIT 

 +10       SET PORT=$$ASKPORT(LINK)

 +11       if 'PORT

               QUIT 

 +12       LOCK +^HLB("QUEUE","OUT",LINK_":"_PORT,"HLOPING"_$JOB):1

 +13       DO STOPQUE^HLOQUE("OUT","HLOPING"_$JOB)

 +14       DO BREAKS

 +15       DO CHECKAPP

 +16       IF $$ADDMSG(LINK)

               Begin DoDot:1

 +17      ;disable CTRL-C breaks