HLMA ;AISC/SAW - Message Administration Module ;02/26/2009 15:42
;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132,122,140,142,168**;Oct 13, 1995;Build 6
;Per VA Directive 6402, this routine should not be modified.
GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ;
;Entry point to generate a deferred message
;
;This is a subroutine call with parameter passing. It returns a
;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows
;as follows: 1st message ID^error code^error description
;If no error occurs, only the first piece is returned equal to a unique
;ID for the 1st message. If message was sent to more than 1 subscriber
;than the other message IDs will be in the array HLRESLT(n)=ID
;Otherwise, three pieces are returned with the
;first piece equal to the message ID, if one was assigned, otherwise 0
;
;Required Input Parameters
; HLEID = Name or IEN of event driver protocol in the Protocol file
; HLARYTYP = Array type. One of the following codes:
; LM = local array containing a single message
; LB = local array containig a batch of messages
; GM = global array containing a single message
; GB = global array containing a batch of messages
; HLFORMAT = Format of array, 1 for pre-formatted in HL7 format,
; otherwise 0
;NOTE: The parameter HLRESLT must be passed by reference
; HLRESLT = The variable that will be returned to the calling
; application as descibed above
;Optional Parameters
; HLMTIEN = IEN of entry in Message Text file where the message
; being generated is to be stored. This parameter is
; only passed for a batch type message
;NOTE: The parameter HLP used for the following parameters must be
; passed by reference
; HLP("SECURITY") = A 1 to 40 character string
; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string
; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91
; HLP("EXCLUDE SUBSCRIBER",<n=1,2,3...>)=<subscriber protocol ien> or
; <subscriber protocol name> - A list of protocols to dynamically
; drop from the event protocol's subscriber multiple.
;
;can't have link open when generating new message
N HLTCP,HLTCPO,HLPRIO,HLMIDAR
; patch HL*1.6*142- to protect application who call this entry
N HLSUP
S HLPRIO="D"
S HLRESLT=""
;Check for required parameters
CONT ;
I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") D G EXIT
. S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point"
I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT
N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)=""
I "GL"'[$E(HLARYTYP) S HLRESLT="0^4^"_$G(^HL(771.7,4,0)) G EXIT
I $L($G(HLP("SECURITY")))>40 S HLRESLT="0^6^"_$G(^HL(771.7,6,0)) G EXIT
I $L($G(HLP("CONTPTR")))>180 S HLRESLT="0^11^"_$G(^HL(771.7,11,0)) G EXIT
I $D(HLL("LINKS")) D G:$G(HLRESLT)]"" EXIT
. N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN
. S I=0
. F S I=$O(HLL("LINKS",I)) Q:'I D Q:$G(HLRESLT)]""
. . S HLPNAM=$P(HLL("LINKS",I),U)
. . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0))
. . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I) Q
. . S HLLNAM=$P(HLL("LINKS",I),U,2)
. . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0))
. . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I) Q
;Extract data from Protocol file
D EVENT^HLUTIL1(HLEID,"15,20,771",.HLN)
S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15))
S HLP("GROUTINE")=$G(HLN(771)) K HLN I HLP("GROUTINE")']"",'HLFORMAT S HLRESLT="0^3^"_$G(^HL(771.7,3,0)) G EXIT
;Create message ID and Message Text IEN if Message Text IEN not
;previously created ('$G(HLMTIEN))
I '$G(HLMTIEN) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
;Get message ID if Message Text IEN already created
I '$G(HLMID) D
.S HLDT=$G(^HL(772,HLMTIEN,0)),HLMID=$P(HLDT,"^",6),HLDT=+HLDT
.S HLDT1=$$HLDATE^HLFNC(HLDT)
S HLMIDAR=0,HLRESLT=HLMID,HLP("DT")=HLDT,HLP("DTM")=HLDT1
;Execute entry action for event driver protocol
I HLENROU]"" X HLENROU
;Invoke transaction processor
K HLDT,HLDT1,HLENROU
D GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP)
;HLMIDAR is array of message IDs, only set for broadcast messages
I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR
S HLRESLT=HLRESLT_"^"_HLRESLT1
;
; patch HL*1.6*122
S HLRESLT("HLMID")=$G(HLMIDAR("HLMID"))
S HLRESLT("IEN773")=$G(HLMIDAR("IEN773"))
;
;Execute exit action for event driver protocol
I HLEXROU]"" X HLEXROU
EXIT ;Update status if Message Text file entry has been created
K HLTCP
I $D(HLMTIEN) D STATUS^HLTF0(HLMTIEN,$S($P(HLRESLT,"^",2):4,1:3),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",2),1:""),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",3),1:""))
K HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU,HLL("LINKS")
Q
DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP) ;
;Entry point to generate an immediate message, must be TCP Logical Link
;Input:
; The same as GENERATE,with one additional subscript to the HLP input
; array:
;
; HLP("OPEN TIMEOUT") (optional, pass by reference) a number between
; 1 and 120 that specifies how many seconds the DIRECT CONNECT should
; try to open a connection before failing. It is killed upon
; completion.
;
N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT
; patch HL*1.6*140- to protect application who call this entry
N IO,IOF,ION,IOT,IOST,POP
S HLRESLT=""
;HLMTIENO=ien passed in, batch message
S HLMTIEN=$G(HLMTIENO)
I $G(HLP("OPEN TIMEOUT")),((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120 Q "0^4^INVALID OPEN TIMEOUT PARAMETER"
I $G(HLP("OPEN TIMEOUT")) D
.S HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT")
.K HLP("OPEN TIMEOUT")
K HL,HLMTIENO
D INIT^HLFNC2(HLEID,.HL)
I $G(HL) S HLRESLT="0^"_HL Q
S HLPRIO="I" D CONT
;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2
S HLMTIENO=HLMTIEN,HLMTIEN=$G(HLMTIENR)
;Set special HL variables
S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
Q
;
CLOSE(LOGLINK) ;close connection that was open in tag DIRECT
Q
PING ;ping another VAMC to test Link
;set HLQUIET =1 to skip writes
;look for HLTPUT to get turnaround time over network.
N DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM
N HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2
S HLQUIET=$G(HLQUIET)
S HLCS="",HCSTRACE="C: ",POP=1,INPUT="INPUT",OUTPUT="OUTPUT"
S DIC="^HLCS(870,",DIC(0)="QEAMZ"
D ^DIC Q:Y<0
S HLDP=+Y,HLDPNM=Y(0,0),HLDPDM=$P($$PARAM^HLCS2,U,2)
;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q
D SETUP^HLCSAC G:HLCS PINGQ
; patch HL*1.6*122
G:$$DONTPING^HLMA4 PINGQ
;PING header=MSH^PING^domain^PING^logical link^datetime
S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H)
D OPEN^HLCSAC
I HLCS D DNS G:HLCS PINGQ
D
. N $ETRAP,$ESTACK S $ETRAP="D PINGERR^HLMA"
. ;non-standard HL7 header; start block,header,end block
. S HLX1=$H
. ;
. ; HL*1.6*122 start
. ; replace flush character '!' with @IOF (! or #)
. ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
. ; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
. ; W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF
. W $C(11)_INPUT(1)_$C(28)_$C(13),@HLTCPLNK("IOF")
. ; HL*1.6*122 end
. ;
. ;read response
. R X:HLDREAD
. S HLX2=$H
. S X=$P(X,$C(28)),HLCS=$S(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response")
. ;Get roundtrip time
. K HLTPUT I X]"" S HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2)
D CLOSE^%ZISTCP
PINGQ ;write back status and quit
I 'HLQUIET W !,HLCS,!
Q
PINGERR ;process errors from PING
S $ETRAP="G UNWIND^%ZTER",HLCS="-1^Error"
;I $ZE["READ" S HLCS="-1^Error during read"
;I $ZE["WRITE" S HLCS="-1^Error during write"
; HL*1.6*115, SACC compliance
I $$EC^%ZOSV["READ" S HLCS="-1^Error during read"
I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write"
G UNWIND^%ZTER
DNS ;
;openfail-try DNS lookup-Link must contain point to Domain Name
S POP=$G(POP)
S HLQUIET=$G(HLQUIET)
I 'HLQUIET W !,"Calling DNS"
N HLDOM,HLIP S HLCS=""
S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
; patch HL*1.6*122 start
S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
I 'HLDOM,($L(HLDOM("DNS"),".")<3) D Q
. I 'HLQUIET W !,"Domain Unknown"
. S HLCS="-1^Connection Fail"
; patch HL*1.6*122 end
I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
; patch HL*1.6*122
; I HLDOM]"" D Q:'POP
I HLDOM]""!($L(HLDOM("DNS"),".")>2) D Q:'POP
. I HLDOM["DOMAIN.EXT"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".DOMAIN.EXT")_".DOMAIN.EXT"
. I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
. I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
. ; patch HL*1.6*122
. I ($L(HLDOM("DNS"),".")>2) S HLDOM=HLDOM("DNS")
. I 'HLQUIET W !,"Domain, "_HLDOM
. I 'HLQUIET W !,"Port: ",HLTCPORT
. S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
. I HLIP]"",'HLQUIET W !,"DNS Returned: ",HLIP
. I HLIP]"" D
. . ;If more than one IP returned, try each, cache successful open
. . N HLI,HLJ,HLIP1
. . F HLJ=1:1:$L(HLIP,",") D Q:'POP
. . . S HLIP1=$P(HLIP,",",HLJ)
. . . F HLI=1:1:HLDRETR W:'HLQUIET !,"Trying ",HLIP1 D CALL^%ZISTCP(HLIP1,HLTCPORT,1) Q:'POP
. . . I 'POP S $P(^HLCS(870,HLDP,400),U)=HLIP1
. . . U IO
I POP S HLCS="-1^DNS Lookup Failed"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLMA 9678 printed Dec 13, 2024@01:58:17 Page 2
HLMA ;AISC/SAW - Message Administration Module ;02/26/2009 15:42
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132,122,140,142,168**;Oct 13, 1995;Build 6
+2 ;Per VA Directive 6402, this routine should not be modified.
GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ;
+1 ;Entry point to generate a deferred message
+2 ;
+3 ;This is a subroutine call with parameter passing. It returns a
+4 ;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows
+5 ;as follows: 1st message ID^error code^error description
+6 ;If no error occurs, only the first piece is returned equal to a unique
+7 ;ID for the 1st message. If message was sent to more than 1 subscriber
+8 ;than the other message IDs will be in the array HLRESLT(n)=ID
+9 ;Otherwise, three pieces are returned with the
+10 ;first piece equal to the message ID, if one was assigned, otherwise 0
+11 ;
+12 ;Required Input Parameters
+13 ; HLEID = Name or IEN of event driver protocol in the Protocol file
+14 ; HLARYTYP = Array type. One of the following codes:
+15 ; LM = local array containing a single message
+16 ; LB = local array containig a batch of messages
+17 ; GM = global array containing a single message
+18 ; GB = global array containing a batch of messages
+19 ; HLFORMAT = Format of array, 1 for pre-formatted in HL7 format,
+20 ; otherwise 0
+21 ;NOTE: The parameter HLRESLT must be passed by reference
+22 ; HLRESLT = The variable that will be returned to the calling
+23 ; application as descibed above
+24 ;Optional Parameters
+25 ; HLMTIEN = IEN of entry in Message Text file where the message
+26 ; being generated is to be stored. This parameter is
+27 ; only passed for a batch type message
+28 ;NOTE: The parameter HLP used for the following parameters must be
+29 ; passed by reference
+30 ; HLP("SECURITY") = A 1 to 40 character string
+31 ; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string
+32 ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91
+33 ; HLP("EXCLUDE SUBSCRIBER",<n=1,2,3...>)=<subscriber protocol ien> or
+34 ; <subscriber protocol name> - A list of protocols to dynamically
+35 ; drop from the event protocol's subscriber multiple.
+36 ;
+37 ;can't have link open when generating new message
+38 NEW HLTCP,HLTCPO,HLPRIO,HLMIDAR
+39 ; patch HL*1.6*142- to protect application who call this entry
+40 NEW HLSUP
+41 SET HLPRIO="D"
+42 SET HLRESLT=""
+43 ;Check for required parameters
CONT ;
+1 IF $GET(HLEID)']""!($GET(HLARYTYP)']"")!($GET(HLFORMAT)']"")
Begin DoDot:1
+2 SET HLRESLT="0^7^"_$GET(^HL(771.7,7,0))_" at GENERATE^HLMA entry point"
End DoDot:1
GOTO EXIT
+3 IF 'HLEID
SET HLEID=$ORDER(^ORD(101,"B",HLEID,0))
IF 'HLEID
SET HLRESLT="0^1^"_$GET(^HL(771.7,1,0))
GOTO EXIT
+4 NEW HLRESLT1,HLRESLTA
SET (HLRESLTA,HLRESLT1)=""
+5 IF "GL"'[$EXTRACT(HLARYTYP)
SET HLRESLT="0^4^"_$GET(^HL(771.7,4,0))
GOTO EXIT
+6 IF $LENGTH($GET(HLP("SECURITY")))>40
SET HLRESLT="0^6^"_$GET(^HL(771.7,6,0))
GOTO EXIT
+7 IF $LENGTH($GET(HLP("CONTPTR")))>180
SET HLRESLT="0^11^"_$GET(^HL(771.7,11,0))
GOTO EXIT
+8 IF $DATA(HLL("LINKS"))
Begin DoDot:1
+9 NEW I,HLPNAM,HLPIEN,HLLNAM,HLLIEN
+10 SET I=0
+11 FOR
SET I=$ORDER(HLL("LINKS",I))
if 'I
QUIT
Begin DoDot:2
+12 SET HLPNAM=$PIECE(HLL("LINKS",I),U)
+13 SET HLPIEN=+$ORDER(^ORD(101,"B",HLPNAM,0))
+14 IF $PIECE($GET(^ORD(101,HLPIEN,0)),U,4)'="S"
SET HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I)
QUIT
+15 SET HLLNAM=$PIECE(HLL("LINKS",I),U,2)
+16 SET HLLIEN=+$ORDER(^HLCS(870,"B",HLLNAM,0))
+17 IF '$DATA(^HLCS(870,HLLIEN,0))
SET HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I)
QUIT
End DoDot:2
if $GET(HLRESLT)]""
QUIT
End DoDot:1
if $GET(HLRESLT)]""
GOTO EXIT
+18 ;Extract data from Protocol file
+19 DO EVENT^HLUTIL1(HLEID,"15,20,771",.HLN)
+20 SET HLENROU=$GET(HLN(20))
SET HLEXROU=$GET(HLN(15))
+21 SET HLP("GROUTINE")=$GET(HLN(771))
KILL HLN
IF HLP("GROUTINE")']""
IF 'HLFORMAT
SET HLRESLT="0^3^"_$GET(^HL(771.7,3,0))
GOTO EXIT
+22 ;Create message ID and Message Text IEN if Message Text IEN not
+23 ;previously created ('$G(HLMTIEN))
+24 IF '$GET(HLMTIEN)
DO CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
+25 ;Get message ID if Message Text IEN already created
+26 IF '$GET(HLMID)
Begin DoDot:1
+27 SET HLDT=$GET(^HL(772,HLMTIEN,0))
SET HLMID=$PIECE(HLDT,"^",6)
SET HLDT=+HLDT
+28 SET HLDT1=$$HLDATE^HLFNC(HLDT)
End DoDot:1
+29 SET HLMIDAR=0
SET HLRESLT=HLMID
SET HLP("DT")=HLDT
SET HLP("DTM")=HLDT1
+30 ;Execute entry action for event driver protocol
+31 IF HLENROU]""
XECUTE HLENROU
+32 ;Invoke transaction processor
+33 KILL HLDT,HLDT1,HLENROU
+34 DO GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP)
+35 ;HLMIDAR is array of message IDs, only set for broadcast messages
+36 IF HLMIDAR
KILL HLMIDAR("N")
MERGE HLRESLT=HLMIDAR
+37 SET HLRESLT=HLRESLT_"^"_HLRESLT1
+38 ;
+39 ; patch HL*1.6*122
+40 SET HLRESLT("HLMID")=$GET(HLMIDAR("HLMID"))
+41 SET HLRESLT("IEN773")=$GET(HLMIDAR("IEN773"))
+42 ;
+43 ;Execute exit action for event driver protocol
+44 IF HLEXROU]""
XECUTE HLEXROU
EXIT ;Update status if Message Text file entry has been created
+1 KILL HLTCP
+2 IF $DATA(HLMTIEN)
DO STATUS^HLTF0(HLMTIEN,$SELECT($PIECE(HLRESLT,"^",2):4,1:3),$SELECT($PIECE(HLRESLT,"^",2):$PIECE(HLRESLT,"^",2),1:""),$SELECT($PIECE(HLRESLT,"^",2):$PIECE(HLRESLT,"^",3),1:""))
+3 KILL HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU,HLL("LINKS")
+4 QUIT
DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP) ;
+1 ;Entry point to generate an immediate message, must be TCP Logical Link
+2 ;Input:
+3 ; The same as GENERATE,with one additional subscript to the HLP input
+4 ; array:
+5 ;
+6 ; HLP("OPEN TIMEOUT") (optional, pass by reference) a number between
+7 ; 1 and 120 that specifies how many seconds the DIRECT CONNECT should
+8 ; try to open a connection before failing. It is killed upon
+9 ; completion.
+10 ;
+11 NEW HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT
+12 ; patch HL*1.6*140- to protect application who call this entry
+13 NEW IO,IOF,ION,IOT,IOST,POP
+14 SET HLRESLT=""
+15 ;HLMTIENO=ien passed in, batch message
+16 SET HLMTIEN=$GET(HLMTIENO)
+17 IF $GET(HLP("OPEN TIMEOUT"))
IF ((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120
QUIT "0^4^INVALID OPEN TIMEOUT PARAMETER"
+18 IF $GET(HLP("OPEN TIMEOUT"))
Begin DoDot:1
+19 SET HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT")
+20 KILL HLP("OPEN TIMEOUT")
End DoDot:1
+21 KILL HL,HLMTIENO
+22 DO INIT^HLFNC2(HLEID,.HL)
+23 IF $GET(HL)
SET HLRESLT="0^"_HL
QUIT
+24 SET HLPRIO="I"
DO CONT
+25 ;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2
+26 SET HLMTIENO=HLMTIEN
SET HLMTIEN=$GET(HLMTIENR)
+27 ;Set special HL variables
+28 SET HLQUIT=0
SET HLNODE=""
SET HLNEXT="D HLNEXT^HLCSUTL"
+29 QUIT
+30 ;
CLOSE(LOGLINK) ;close connection that was open in tag DIRECT
+1 QUIT
PING ;ping another VAMC to test Link
+1 ;set HLQUIET =1 to skip writes
+2 ;look for HLTPUT to get turnaround time over network.
+3 NEW DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM
+4 NEW HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2
+5 SET HLQUIET=$GET(HLQUIET)
+6 SET HLCS=""
SET HCSTRACE="C: "
SET POP=1
SET INPUT="INPUT"
SET OUTPUT="OUTPUT"
+7 SET DIC="^HLCS(870,"
SET DIC(0)="QEAMZ"
+8 DO ^DIC
if Y<0
QUIT
+9 SET HLDP=+Y
SET HLDPNM=Y(0,0)
SET HLDPDM=$PIECE($$PARAM^HLCS2,U,2)
+10 ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q
+11 DO SETUP^HLCSAC
if HLCS
GOTO PINGQ
+12 ; patch HL*1.6*122
+13 if $$DONTPING^HLMA4
GOTO PINGQ
+14 ;PING header=MSH^PING^domain^PING^logical link^datetime
+15 SET INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($HOROLOG)
+16 DO OPEN^HLCSAC
+17 IF HLCS
DO DNS
if HLCS
GOTO PINGQ
+18 Begin DoDot:1
+19 NEW $ETRAP,$ESTACK
SET $ETRAP="D PINGERR^HLMA"
+20 ;non-standard HL7 header; start block,header,end block
+21 SET HLX1=$HOROLOG
+22 ;
+23 ; HL*1.6*122 start
+24 ; replace flush character '!' with @IOF (! or #)
+25 ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
+26 ; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
+27 ; W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF
+28 WRITE $CHAR(11)_INPUT(1)_$CHAR(28)_$CHAR(13),@HLTCPLNK("IOF")
+29 ; HL*1.6*122 end
+30 ;
+31 ;read response
+32 READ X:HLDREAD
+33 SET HLX2=$HOROLOG
+34 SET X=$PIECE(X,$CHAR(28))
SET HLCS=$SELECT(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response")
+35 ;Get roundtrip time
+36 KILL HLTPUT
IF X]""
SET HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2)
End DoDot:1
+37 DO CLOSE^%ZISTCP
PINGQ ;write back status and quit
+1 IF 'HLQUIET
WRITE !,HLCS,!
+2 QUIT
PINGERR ;process errors from PING
+1 SET $ETRAP="G UNWIND^%ZTER"
SET HLCS="-1^Error"
+2 ;I $ZE["READ" S HLCS="-1^Error during read"
+3 ;I $ZE["WRITE" S HLCS="-1^Error during write"
+4 ; HL*1.6*115, SACC compliance
+5 IF $$EC^%ZOSV["READ"
SET HLCS="-1^Error during read"
+6 IF $$EC^%ZOSV["WRITE"
SET HLCS="-1^Error during write"
+7 GOTO UNWIND^%ZTER
DNS ;
+1 ;openfail-try DNS lookup-Link must contain point to Domain Name
+2 SET POP=$GET(POP)
+3 SET HLQUIET=$GET(HLQUIET)
+4 IF 'HLQUIET
WRITE !,"Calling DNS"
+5 NEW HLDOM,HLIP
SET HLCS=""
+6 SET HLDOM=$PIECE(^HLCS(870,HLDP,0),U,7)
+7 ; patch HL*1.6*122 start
+8 SET HLDOM("DNS")=$PIECE($GET(^HLCS(870,+$GET(HLDP),0)),"^",8)
+9 ; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
+10 IF 'HLDOM
IF ($LENGTH(HLDOM("DNS"),".")<3)
Begin DoDot:1
+11 IF 'HLQUIET
WRITE !,"Domain Unknown"
+12 SET HLCS="-1^Connection Fail"
End DoDot:1
QUIT
+13 ; patch HL*1.6*122 end
+14 IF HLDOM
SET HLDOM=$PIECE(^DIC(4.2,HLDOM,0),U)
+15 ; patch HL*1.6*122
+16 ; I HLDOM]"" D Q:'POP
+17 IF HLDOM]""!($LENGTH(HLDOM("DNS"),".")>2)
Begin DoDot:1
+18 IF HLDOM["DOMAIN.EXT"&(HLDOM'[".MED.")
SET HLDOM=$PIECE(HLDOM,".DOMAIN.EXT")_".DOMAIN.EXT"
+19 IF HLTCPORT=5000
SET HLDOM="HL7."_HLDOM
+20 IF HLTCPORT=5500
SET HLDOM="MPI."_HLDOM
+21 ; patch HL*1.6*122
+22 IF ($LENGTH(HLDOM("DNS"),".")>2)
SET HLDOM=HLDOM("DNS")
+23 IF 'HLQUIET
WRITE !,"Domain, "_HLDOM
+24 IF 'HLQUIET
WRITE !,"Port: ",HLTCPORT
+25 SET HLIP=$$ADDRESS^XLFNSLK(HLDOM)
+26 IF HLIP]""
IF 'HLQUIET
WRITE !,"DNS Returned: ",HLIP
+27 IF HLIP]""
Begin DoDot:2
+28 ;If more than one IP returned, try each, cache successful open
+29 NEW HLI,HLJ,HLIP1
+30 FOR HLJ=1:1:$LENGTH(HLIP,",")
Begin DoDot:3
+31 SET HLIP1=$PIECE(HLIP,",",HLJ)
+32 FOR HLI=1:1:HLDRETR
if 'HLQUIET
WRITE !,"Trying ",HLIP1
DO CALL^%ZISTCP(HLIP1,HLTCPORT,1)
if 'POP
QUIT
+33 IF 'POP
SET $PIECE(^HLCS(870,HLDP,400),U)=HLIP1
+34 USE IO
End DoDot:3
if 'POP
QUIT
End DoDot:2
End DoDot:1
if 'POP
QUIT
+35 IF POP
SET HLCS="-1^DNS Lookup Failed"
