HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;08/03/2011
;;1.6;HEALTH LEVEL SEVEN;**76,77,133,122,153,157**;OCT 13, 1995;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
;
OPENA ;
; called from $$OPEN^HLCSTCP2 and this sub-routine OPENA
;
; **P153 START CJM
; Reset the TCP Address incase DNS changed it without a successful connection
K HLDOM
S HLTCPADD=$P(^HLCS(870,HLDP,400),U)
;
RETRY ;
; **P153 END CJM
;
I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
S POP=1
;
; patch HL*1.6*122 start
; variable HLDRETR=re-transmit attemps (#870,200.02)
; variable HLTCPLNK("TIMEOUT")=timeout for 3rd parameter of CALL^%ZISTCP()
; defined in HLCSTCP routine
;
I '$G(HLDRETR("COUNT")) S HLDRETR("COUNT")=1
I '$G(HLTCPLNK("TIMEOUT")) S HLTCPLNK("TIMEOUT")=5
S HLDRETR("COUNT-2")=HLDRETR("COUNT")+HLDRETR
; patch 133
; I $G(HLDIRECT("OPEN TIMEOUT")) D
; .S HLI=1
; .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
; E D
; .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
I $G(HLDIRECT("OPEN TIMEOUT")) D
. D MON^HLCSTCP("Open")
. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
. ; give site one more chance to override the application setup
. I $G(POP),(HLTCPLNK("TIMEOUT")>HLDIRECT("OPEN TIMEOUT")) D
.. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
E D
. N COUNT
. ; try to connect HLDRETR times
. F HLDRETR("COUNT")=HLDRETR("COUNT"):1:HLDRETR("COUNT-2") D Q:('POP)!($$STOP^HLCSTCP)
.. D MON^HLCSTCP("Open")
.. ; D CALL^%ZISTCP(HLTCPADD,HLTCPORT)
.. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
.. ;open error
.. I POP D
... D CC^HLCSTCP2("Openfail")
... H $S(HLDRETR("COUNT")=1:0,HLDRETR("COUNT")<10:1,1:8)
... I '$D(^XTMP("HL7-Openfail",$J)) D
.... S ^XTMP("HL7-Openfail",0)=$$FMADD^XLFDT($$NOW^XLFDT,3)_"^"_$$NOW^XLFDT
.... S ^XTMP("HL7-Openfail",$J,"COUNT","FIRST")=HLDRETR("COUNT")_"^"_$$NOW^XLFDT
... S COUNT=$P($G(^XTMP("HL7-Openfail",$J,"COUNT","LAST")),"^")+1
... S ^XTMP("HL7-Openfail",$J,"COUNT","LAST")=COUNT_"^"_$$NOW^XLFDT
;
;set # of opens back in msg
; I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLDRETR("COUNT")
; patch HL*1.6*122 end
;
;device open
I 'POP S HLPORT=IO D Q $S($G(HLERROR)]"":0,1:1)
. N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" ;HL*1.6*77
. ;if address came from DNS, set back into LL
. I $D(HLIP) S $P(^HLCS(870,HLDP,400),U)=HLTCPADD
. ; write and read to check if still open
. ; patch HL*1.6*157: HLOS is from calling $$OS^%ZOSV
. ; Q:HLOS'["OpenM" X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode
. Q:(HLOS'["VMS")&(HLOS'["UNIX") X "U IO:(::""-M"")" ; must be Cache + packet mode
. Q:$P(^HLCS(870,HLDP,400),U,7)'="Y" ; must want to SAY HELO
. U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1
;openfail-try DNS lookup
;
; patch HL*1.6*122 start
;I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
I '$D(HLDOM) D
. S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U)
. S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
. D:HLDOM]""!($L(HLDOM("DNS"),".")>2) DNS
;
Q:$$STOP^HLCSTCP 0
;HLIP=ip add. from DNS call, get first one and try open again
;
; **P153 START CJM
;I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD RETRY
; **P153 END CJM
;
; open error
;cleanup and close
; patch 133
I $G(HLDIRECT("OPEN TIMEOUT")) D
. D MON^HLCSTCP("Openfail")
. I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
E D
. D CC^HLCSTCP2("Openfail")
Q 0
; patch HL*1.6*122 end
;
;
;following code was removed, site's complained of to many alerts
;couldn't open, send 1 alert
;I '$G(HLPORTA) D
;. ;send alert
;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
;. ;get mailgroup from file 869.3
;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z=""
;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries."
;. D SETUP^XQALERT
;open error
;D CC("Openfail") H 3
;Q 0
;
;
DNS ;VA domains must have "med" inserted.
;All domains must use port 5000 and are prepended with "HL7"
;non-VA DNS lookups will succeed if site uses port 5000 and
;configure their local DNS with "HL7.yourdomain.com" and entries
;are created in the logical link file and domain file.
D MON^HLCSTCP("DNS Lkup")
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 start
I $L($G(HLDOM("DNS")),".")>2 D
. S HLDOM=HLDOM("DNS")
; patch HL*1.6*122 end
;
S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
K:HLIP="" HLIP
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSTCP3 4908 printed Nov 22, 2024@17:07:15 Page 2
HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;08/03/2011
+1 ;;1.6;HEALTH LEVEL SEVEN;**76,77,133,122,153,157**;OCT 13, 1995;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
OPENA ;
+1 ; called from $$OPEN^HLCSTCP2 and this sub-routine OPENA
+2 ;
+3 ; **P153 START CJM
+4 ; Reset the TCP Address incase DNS changed it without a successful connection
+5 KILL HLDOM
+6 SET HLTCPADD=$PIECE(^HLCS(870,HLDP,400),U)
+7 ;
RETRY ;
+1 ; **P153 END CJM
+2 ;
+3 IF $GET(HLMSG)
IF $DATA(^HLMA(HLMSG,"P"))
SET HLPORTA=+$PIECE(^("P"),U,6)
+4 SET POP=1
+5 ;
+6 ; patch HL*1.6*122 start
+7 ; variable HLDRETR=re-transmit attemps (#870,200.02)
+8 ; variable HLTCPLNK("TIMEOUT")=timeout for 3rd parameter of CALL^%ZISTCP()
+9 ; defined in HLCSTCP routine
+10 ;
+11 IF '$GET(HLDRETR("COUNT"))
SET HLDRETR("COUNT")=1
+12 IF '$GET(HLTCPLNK("TIMEOUT"))
SET HLTCPLNK("TIMEOUT")=5
+13 SET HLDRETR("COUNT-2")=HLDRETR("COUNT")+HLDRETR
+14 ; patch 133
+15 ; I $G(HLDIRECT("OPEN TIMEOUT")) D
+16 ; .S HLI=1
+17 ; .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
+18 ; E D
+19 ; .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
+20 IF $GET(HLDIRECT("OPEN TIMEOUT"))
Begin DoDot:1
+21 DO MON^HLCSTCP("Open")
+22 DO CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
+23 ; give site one more chance to override the application setup
+24 IF $GET(POP)
IF (HLTCPLNK("TIMEOUT")>HLDIRECT("OPEN TIMEOUT"))
Begin DoDot:2
+25 DO CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
End DoDot:2
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 NEW COUNT
+28 ; try to connect HLDRETR times
+29 FOR HLDRETR("COUNT")=HLDRETR("COUNT"):1:HLDRETR("COUNT-2")
Begin DoDot:2
+30 DO MON^HLCSTCP("Open")
+31 ; D CALL^%ZISTCP(HLTCPADD,HLTCPORT)
+32 DO CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
+33 ;open error
+34 IF POP
Begin DoDot:3
+35 DO CC^HLCSTCP2("Openfail")
+36 HANG $SELECT(HLDRETR("COUNT")=1:0,HLDRETR("COUNT")<10:1,1:8)
+37 IF '$DATA(^XTMP("HL7-Openfail",$JOB))
Begin DoDot:4
+38 SET ^XTMP("HL7-Openfail",0)=$$FMADD^XLFDT($$NOW^XLFDT,3)_"^"_$$NOW^XLFDT
+39 SET ^XTMP("HL7-Openfail",$JOB,"COUNT","FIRST")=HLDRETR("COUNT")_"^"_$$NOW^XLFDT
End DoDot:4
+40 SET COUNT=$PIECE($GET(^XTMP("HL7-Openfail",$JOB,"COUNT","LAST")),"^")+1
+41 SET ^XTMP("HL7-Openfail",$JOB,"COUNT","LAST")=COUNT_"^"_$$NOW^XLFDT
End DoDot:3
End DoDot:2
if ('POP)!($$STOP^HLCSTCP)
QUIT
End DoDot:1
+42 ;
+43 ;set # of opens back in msg
+44 ; I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
+45 IF $GET(HLMSG)
IF $DATA(^HLMA(HLMSG,"P"))
SET $PIECE(^("P"),U,6)=HLDRETR("COUNT")
+46 ; patch HL*1.6*122 end
+47 ;
+48 ;device open
+49 IF 'POP
SET HLPORT=IO
Begin DoDot:1
+50 ;HL*1.6*77
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLCSTCP2"
+51 ;if address came from DNS, set back into LL
+52 IF $DATA(HLIP)
SET $PIECE(^HLCS(870,HLDP,400),U)=HLTCPADD
+53 ; write and read to check if still open
+54 ; patch HL*1.6*157: HLOS is from calling $$OS^%ZOSV
+55 ; Q:HLOS'["OpenM" X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode
+56 ; must be Cache + packet mode
if (HLOS'["VMS")&(HLOS'["UNIX")
QUIT
XECUTE "U IO:(::""-M"")"
+57 ; must want to SAY HELO
if $PIECE(^HLCS(870,HLDP,400),U,7)'="Y"
QUIT
+58 USE IO
WRITE "HELO "_$$KSP^XUPARAM("WHERE"),!
READ X:1
End DoDot:1
QUIT $SELECT($GET(HLERROR)]"":0,1:1)
+59 ;openfail-try DNS lookup
+60 ;
+61 ; patch HL*1.6*122 start
+62 ;I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
+63 IF '$DATA(HLDOM)
Begin DoDot:1
+64 SET HLDOM=+$PIECE(^HLCS(870,HLDP,0),U,7)
SET HLDOM=$PIECE($GET(^DIC(4.2,HLDOM,0)),U)
+65 SET HLDOM("DNS")=$PIECE($GET(^HLCS(870,+$GET(HLDP),0)),"^",8)
+66 if HLDOM]""!($LENGTH(HLDOM("DNS"),".")>2)
DO DNS
End DoDot:1
+67 ;
+68 if $$STOP^HLCSTCP
QUIT 0
+69 ;HLIP=ip add. from DNS call, get first one and try open again
+70 ;
+71 ; **P153 START CJM
+72 ;I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
+73 IF $DATA(HLIP)
SET HLTCPADD=$PIECE(HLIP,",")
SET HLIP=$PIECE(HLIP,",",2,99)
if HLTCPADD
GOTO RETRY
+74 ; **P153 END CJM
+75 ;
+76 ; open error
+77 ;cleanup and close
+78 ; patch 133
+79 IF $GET(HLDIRECT("OPEN TIMEOUT"))
Begin DoDot:1
+80 DO MON^HLCSTCP("Openfail")
+81 IF $DATA(HLPORT)
DO CLOSE^%ZISTCP
KILL HLPORT
End DoDot:1
+82 IF '$TEST
Begin DoDot:1
+83 DO CC^HLCSTCP2("Openfail")
End DoDot:1
+84 QUIT 0
+85 ; patch HL*1.6*122 end
+86 ;
+87 ;
+88 ;following code was removed, site's complained of to many alerts
+89 ;couldn't open, send 1 alert
+90 ;I '$G(HLPORTA) D
+91 ;. ;send alert
+92 ;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+93 ;. ;get mailgroup from file 869.3
+94 ;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z=""
+95 ;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries."
+96 ;. D SETUP^XQALERT
+97 ;open error
+98 ;D CC("Openfail") H 3
+99 ;Q 0
+100 ;
+101 ;
DNS ;VA domains must have "med" inserted.
+1 ;All domains must use port 5000 and are prepended with "HL7"
+2 ;non-VA DNS lookups will succeed if site uses port 5000 and
+3 ;configure their local DNS with "HL7.yourdomain.com" and entries
+4 ;are created in the logical link file and domain file.
+5 DO MON^HLCSTCP("DNS Lkup")
+6 IF HLDOM["DOMAIN.EXT"&(HLDOM'[".MED.")
SET HLDOM=$PIECE(HLDOM,".DOMAIN.EXT")_".DOMAIN.EXT"
+7 IF HLTCPORT=5000
SET HLDOM="HL7."_HLDOM
+8 IF HLTCPORT=5500
SET HLDOM="MPI."_HLDOM
+9 ;
+10 ; patch HL*1.6*122 start
+11 IF $LENGTH($GET(HLDOM("DNS")),".")>2
Begin DoDot:1
+12 SET HLDOM=HLDOM("DNS")
End DoDot:1
+13 ; patch HL*1.6*122 end
+14 ;
+15 SET HLIP=$$ADDRESS^XLFNSLK(HLDOM)
+16 if HLIP=""
KILL HLIP
+17 QUIT
+18 ;
