- 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 Jan 18, 2025@02:59:32 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"