HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;08/04/2011 16:27
;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133,122,140,142,145,153,157**;Oct 13,1995;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
;Sender
;Request connection, send outbound message(s) delimited by MLLP
;Input : HLDP=Logical Link to use
; Set up error trap
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP
;HLRETRY=number of retranmission for this link,HLRETMG=alert sent
S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
;
; patch 122
; patch 133
; set IO(0) to the null device
I $G(^%ZOSF("OS"))]"",^%ZOSF("OS")'["GT.M" D
. S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
. O IO(0) U IO(0)
;
;persistent conection, open connection first, HLPORT=open port
I $G(HLTCPLNK)["Y" F Q:$$OPEN G EXIT:$$STOP^HLCSTCP H 1
F D QUE Q:$$STOP^HLCSTCP D:'HLMSG Q:$G(HLCSOUT)
. ;no messages to send
. D MON^HLCSTCP("Idle") H 3
. ;persistent connection, no retention
. Q:$G(HLTCPLNK)["Y"
. D MON^HLCSTCP("Retention")
. N % I 0
. ;if message comes in or ask to stop
. F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q
. E S HLCSOUT=2 Q
. Q:$$STOP^HLCSTCP
. D MON^HLCSTCP("Idle")
;Close port
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
EXIT Q
;
QUE ; -- Check "OUT" queue for processing IF there is a message do it
; and then check the link if it open or not
N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
N HLTMBUF
D MON^HLCSTCP("CheckOut")
;HLMSG=next msg, set at tag DONE
I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
;
S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
;don't have message text or MSH, kill x-ref and decrement 'to send'
;
; patch HL*1.6*122: MPI-client/server
; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
I 'HLI!'HLJ D Q
. F L +^HLMA("AC","O",HLDP,HLMSG):10 Q:$T H 1
. K ^HLMA("AC","O",HLDP,HLMSG)
. L -^HLMA("AC","O",HLDP,HLMSG)
. D LLCNT^HLCSTCP(HLDP,3,1)
. S HLMSG=0
;
; patch HL*1.6*142 start
; to prevent data contention of end-user from competing with the link
; processes sending data to backup workstations (for BCBU application)
I ($P(^HLMA(HLMSG,0),4)="D"),'$P($G(^HL(772,HLI,"P")),"^",2) D
. N COUNT
. F COUNT=1:1:15 Q:$P($G(^HL(772,HLI,"P")),"^",2) H COUNT
; patch HL*1.6*142 end
;
;update msg status to 'being transmitted'; if cancelled decrement link and quit
I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
;number of retransmissions for message
S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5)
;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown
;quit if restart or shutdown, link is going down
I HLRETRY>HLDRETR D Q:"I"'[HLRETRA
. D MON^HLCSTCP("Error")
. ;only 1 alert per link up time, don't send if restart
. D:'HLRETMG&(HLRETRA'="R")
.. ;send alert
.. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
.. ;get mailgroup from file 869.3
.. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
.. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" HL7 LL "_$P(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$S(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.")
.. D SETUP^XQALERT
. ;quit if action is ignore
. Q:"I"[HLRETRA
. ;this will shutdown this link
. S HLCSOUT=1
. ;action is shutdown, set shutdown flag so LM won't restart
. S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1
. D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param")
I '$$OPEN Q
D MON^HLCSTCP("Send")
; -- data passed in global array, success=1
; patch HL*1.6*142
; time: starts to send this message
S $P(^HLMA(HLMSG,"S"),"^",2)=$$NOW^XLFDT
I $$WRITE(HLMSG)<0 Q
; patch HL*1.6*142
; time: this message has been sent
S $P(^HLMA(HLMSG,"S"),"^",3)=$$NOW^XLFDT
S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1
;update status to awaiting response, decrement link if cancelled
I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
;set transmission count, get ACKTIMEOUT override
S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7)
;get header of message just sent
K HLJ M HLJ=^HLMA(HLMSG,"MSH")
;first component of sending app.
S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH")))
;msg type, msg. id, commit ack, and app. ack parameter
S HLN("TYPE")=$$P^HLTPCK2(.HLJ,1),HLN("MID")=$$P^HLTPCK2(.HLJ,10),HLN("ACAT")=$$P^HLTPCK2(.HLJ,15),HLN("APAT")=$$P^HLTPCK2(.HLJ,16)
;MSA segment, message is a response, can't have an a. ack.
S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE"
;for batch/file with commit ack, reset c. ack and a. ack variables
I "BHS,FHS"[HLN("TYPE") S Z=$E(HLJ(1,0),5),X=$$P^HLTPCK2(.HLJ,9),HLN("ACAT")=$P(X,Z,5),HLN("APAT")=$P(X,Z,6),HLN("MID")=$$P^HLTPCK2(.HLJ,11)
;get event protocol
S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770))
;set link counter to msg sent
D LLCNT^HLCSTCP(HLDP,4)
;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT
I HLN("ACAT")="NE",HLN("APAT")="NE" D Q
.D DONE(3)
.;
.;
.H $G(HLDWAIT)
;
;do structure is to stack error
D
. N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
. ;HL*1.6*87: Read acknowledgement.
. ;Loop to re-read from buffer when receiving incorrect ack.
. F D Q:'+$G(HLREREAD)
.. S HLREREAD=1
.. ;override ack timeout
.. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME")
.. ;check for response, quit if no-response, msg will be resent
.. ;HLRESP=ien 773^ien 772 for response message
.. S HLRESP=$$READ^HLCSTCP1()
.. ;if no response, decrement counter and quit
.. I 'HLRESP D Q
...D LLCNT^HLCSTCP(HLDP,4,1)
...S HLREREAD="0^No Response"
...;check if the port needs to be closed and re-opened before the next re-transmission attempt
...I $G(HLDRETR("CLOSE")) D CLOSE^%ZISTCP K HLPORT
.. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error
.. S X=$$RSP^HLTP31(HLRESP,.HLN)
.. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app)
.. Q:'X
.. ;commit ack - done
.. ; patch HL*1.6*142
.. ; time: this message has received commit ACK
.. S $P(^HLMA(HLMSG,"S"),"^",4)=$$NOW^XLFDT
.. I X=1 D S HLREREAD="0^Commit Ack" Q
... ;don't need app. ack, set status to complete
... I "NE"[HLN("APAT") D Q
....D DONE(3)
....;
... ;response is deferred, set status to awaiting ack
... D DONE(2)
...;
.. ;Error, HLRESLT=error number^error message from HLTP3
.. I X=4 D Q
... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2))
...;
... S HLREREAD="0^Error"
.. ;app ack was successful
.. D DONE(3) S HLREREAD="0^App Ack"
..;
Q
;
DCSEND ;direct connect
; Set up error trap
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
; patch HL*1.6*122
N HLTMBUF
;override ack timeout
I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
; patch HL*1.6*142
; time: starts to send this message
S $P(^HLMA(HLMSG,"S"),"^",2)=$$NOW^XLFDT
I $$WRITE(HLMSG)<0 D:$G(HLERROR)]"" Q ;HL*1.6*77
. D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77
. D LLCNT^HLCSTCP(HLDP,3,1)
; patch HL*1.6*142
; time: this message has been sent
S $P(^HLMA(HLMSG,"S"),"^",3)=$$NOW^XLFDT
D LLCNT^HLCSTCP(HLDP,4)
;do structure is to stack error
D
. N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
. ;HLRESP=ien 773^ien 772 for response message
. S HLRESP=$$READ^HLCSTCP1()
;
; patch HL*1.6*142
; time: this message has received app ACK
S $P(^HLMA(HLMSG,"S"),"^",4)=$$NOW^XLFDT
D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP)
I $G(HLERROR)']"" D
.D MON^HLCSTCP("Idle")
.I '$G(HLRESP) S HLERROR="108^No response"
;Close port
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
Q
;
DONE(ST,ERR,ERRMSG) ;set status to complete
;ST=status, ERR=error ien, ERRMSG=error msg
D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
;
D DEQUE^HLCSREP(HLDP,"O",HLMSG)
;
;check for more msg.
I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0
Q
;
CHKMSG(HLI) ;check status of message and update if not cancelled
;input: HLI=new status, HLMSG=ien of msg in 773
;returns 1=msg was updated, 0=msg has been canceled
N X
;
; New HL*1.6*77 code starting here...
I '$D(^HLMA(HLMSG,"P")) D Q 0
. S HLERROR="2^Missing status field"
. D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
.;
. D DEQUE^HLCSREP(HLDP,"O",HLMSG)
;
; End of HL*1.6*77
;
;get status, quit if msg was cancelled
;
; patch HL*1.6*145
; S X=+^HLMA(HLMSG,"P") Q:X=3 0
S X=+^HLMA(HLMSG,"P")
;
;update status if it is different
I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
;
Q 1
;
WRITE(HLDA) ; write message in HL7 format
; HLDA - ien of message in 773
; - start block $C(11)
; - end block $C(28)
; - record separator $C(13)
;Output(s): 1 - Successful
; -1 - Unsuccessful
;
N HLDA2,HLAR,HLI,LINENO,X,CRCOUNT
S CRCOUNT=0
;set error trap, used when called from HLTP3
;
; New HL*1.6*77 code starts here...
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
I $G(^HLMA(HLDA,0))'>0 D Q -1
. S HLERROR="2^Message Text pointer missing"
S HLDA2=+$G(^HLMA(HLDA,0))
; End of HL*1.6*77 modifications...
;
Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77
; header is in ^HLMA(, message is in ^HL(772,
S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")"
U IO
D W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D
. F S HLI=$O(@HLAR@(HLI)) Q:'HLI S X=$G(^(HLI,0)) D
.. ;first line, need start block char.
.. S:LINENO=1 X=$C(11)_X
.. ; HL*1.6*122
.. ; I X]"" W X,!
.. N LENGTH
.. S LENGTH=$L(X)
.. ; patch HL*1.6*142 start
.. ; buffer should be limited to 510
.. ; I LENGTH>512 D
.. I LENGTH>510 D
... N X1
... ; F Q:LENGTH<512 D
... F Q:LENGTH<511 D
.... ; S X1=$E(X,1,512),X=$E(X,513,999999)
.... S X1=$E(X,1,510),X=$E(X,511,999999)
.... S LENGTH=$L(X)
.... ; patch HL*1.6*140
.... ; W X1,@IOF
.... W X1,@HLTCPLNK("IOF")
.. ; patch HL*1.6*142 end
.. ;
.. ; @HLTCPLNK("IOF") (! or #) for flush character
.. I X]"" W X,@HLTCPLNK("IOF") S CRCOUNT=0
.. ;send CR
.. I X="" W $C(13) S CRCOUNT=CRCOUNT+1
.. ; prevent from maxstring error
.. I CRCOUNT>200 W @HLTCPLNK("IOF") S CRCOUNT=0
.. S LINENO=LINENO+1
; Sends end block for this message
S X=$C(28)_$C(13)
; U IO W X,!
U IO W X,@HLTCPLNK("IOF")
;switch to null device
I $G(IO(0))'="",$G(IO(0))'=IO U IO(0)
Q 1
;
OPEN() ; -- Open TCP/IP device (Client)
;HLPORT=port, defined only if port is open
;HLPORTA=number of attempted opens
I $D(HLPORT) S IO=HLPORT D Q 1
. U IO
. ; patch HL*1.6*157: HLOS is from calling $$OS^%ZOSV
. ; use packet mode on Cache'
. ; I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache'
. I (HLOS["VMS")!(HLOS["UNIX"),^%ZOSF("OS")'["GT.M" X "U IO:(::""-M"")"
N HLDOM,HLI,HLIP,HLPORTA
G OPENA^HLCSTCP3
;
RDERR D RDERR^HLCSTCP4 Q
ERROR D ERROR^HLCSTCP4 Q
;
CC(X) ;cleanup and close
D MON^HLCSTCP(X)
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
; patch HL*1.6*140
; H 2
H 1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSTCP2 11419 printed Sep 23, 2025@19:33:12 Page 2
HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;08/04/2011 16:27
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133,122,140,142,145,153,157**;Oct 13,1995;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Sender
+4 ;Request connection, send outbound message(s) delimited by MLLP
+5 ;Input : HLDP=Logical Link to use
+6 ; Set up error trap
+7 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLCSTCP2"
+8 NEW HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP
+9 ;HLRETRY=number of retranmission for this link,HLRETMG=alert sent
+10 SET HLTCPO=HLDP
SET HLMSG=""
SET (HLRETRY,HLRETMG)=0
+11 ;
+12 ; patch 122
+13 ; patch 133
+14 ; set IO(0) to the null device
+15 IF $GET(^%ZOSF("OS"))]""
IF ^%ZOSF("OS")'["GT.M"
Begin DoDot:1
+16 SET IO(0)=$SELECT(^%ZOSF("OS")["OpenM":$SELECT($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$PRINCIPAL),^%ZOSF("OS")["DSM":"_NLA0:",1:$PRINCIPAL)
+17 OPEN IO(0)
USE IO(0)
End DoDot:1
+18 ;
+19 ;persistent conection, open connection first, HLPORT=open port
+20 IF $GET(HLTCPLNK)["Y"
FOR
if $$OPEN
QUIT
if $$STOP^HLCSTCP
GOTO EXIT
HANG 1
+21 FOR
DO QUE
if $$STOP^HLCSTCP
QUIT
if 'HLMSG
Begin DoDot:1
+22 ;no messages to send
+23 DO MON^HLCSTCP("Idle")
HANG 3
+24 ;persistent connection, no retention
+25 if $GET(HLTCPLNK)["Y"
QUIT
+26 DO MON^HLCSTCP("Retention")
+27 NEW %
IF 0
+28 ;if message comes in or ask to stop
+29 FOR %=1:1:HLTCPRET
HANG 1
IF $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0))
QUIT
+30 IF '$TEST
SET HLCSOUT=2
QUIT
+31 if $$STOP^HLCSTCP
QUIT
+32 DO MON^HLCSTCP("Idle")
End DoDot:1
if $GET(HLCSOUT)
QUIT
+33 ;Close port
+34 IF $DATA(HLPORT)
DO CLOSE^%ZISTCP
KILL HLPORT
EXIT QUIT
+1 ;
QUE ; -- Check "OUT" queue for processing IF there is a message do it
+1 ; and then check the link if it open or not
+2 NEW HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
+3 NEW HLTMBUF
+4 DO MON^HLCSTCP("CheckOut")
+5 ;HLMSG=next msg, set at tag DONE
+6 IF 'HLMSG
SET HLMSG=+$ORDER(^HLMA("AC","O",HLDP,0))
SET HLRETRY=0
if 'HLMSG
QUIT
+7 ;
+8 SET HLI=+$GET(^HLMA(HLMSG,0))
SET HLJ=$ORDER(^("MSH",0))
SET HLTCP=""
+9 ;don't have message text or MSH, kill x-ref and decrement 'to send'
+10 ;
+11 ; patch HL*1.6*122: MPI-client/server
+12 ; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+13 IF 'HLI!'HLJ
Begin DoDot:1
+14 FOR
LOCK +^HLMA("AC","O",HLDP,HLMSG):10
if $TEST
QUIT
HANG 1
+15 KILL ^HLMA("AC","O",HLDP,HLMSG)
+16 LOCK -^HLMA("AC","O",HLDP,HLMSG)
+17 DO LLCNT^HLCSTCP(HLDP,3,1)
+18 SET HLMSG=0
End DoDot:1
QUIT
+19 ;
+20 ; patch HL*1.6*142 start
+21 ; to prevent data contention of end-user from competing with the link
+22 ; processes sending data to backup workstations (for BCBU application)
+23 IF ($PIECE(^HLMA(HLMSG,0),4)="D")
IF '$PIECE($GET(^HL(772,HLI,"P")),"^",2)
Begin DoDot:1
+24 NEW COUNT
+25 FOR COUNT=1:1:15
if $PIECE($GET(^HL(772,HLI,"P")),"^",2)
QUIT
HANG COUNT
End DoDot:1
+26 ; patch HL*1.6*142 end
+27 ;
+28 ;update msg status to 'being transmitted'; if cancelled decrement link and quit
+29 IF '$$CHKMSG(1.5)
DO LLCNT^HLCSTCP(HLDP,3,1)
SET HLMSG=0
QUIT
+30 ;number of retransmissions for message
+31 SET HLRETRM=+$PIECE(^HLMA(HLMSG,"P"),U,5)
+32 ;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown
+33 ;quit if restart or shutdown, link is going down
+34 IF HLRETRY>HLDRETR
Begin DoDot:1
+35 DO MON^HLCSTCP("Error")
+36 ;only 1 alert per link up time, don't send if restart
+37 if 'HLRETMG&(HLRETRA'="R")
Begin DoDot:2
+38 ;send alert
+39 NEW XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+40 ;get mailgroup from file 869.3
+41 SET HLRETMG=1
SET Z=$PIECE($$PARAM^HLCS2,U,8)
if Z=""
QUIT
+42 SET XQA("G."_Z)=""
SET XQAMSG=$$HTE^XLFDT($HOROLOG,2)_" HL7 LL "_$PIECE(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$SELECT(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.")
+43 DO SETUP^XQALERT
End DoDot:2
+44 ;quit if action is ignore
+45 if "I"[HLRETRA
QUIT
+46 ;this will shutdown this link
+47 SET HLCSOUT=1
+48 ;action is shutdown, set shutdown flag so LM won't restart
+49 if HLRETRA="S"
SET $PIECE(^HLCS(870,HLDP,0),U,15)=1
+50 DO STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param")
End DoDot:1
if "I"'[HLRETRA
QUIT
+51 IF '$$OPEN
QUIT
+52 DO MON^HLCSTCP("Send")
+53 ; -- data passed in global array, success=1
+54 ; patch HL*1.6*142
+55 ; time: starts to send this message
+56 SET $PIECE(^HLMA(HLMSG,"S"),"^",2)=$$NOW^XLFDT
+57 IF $$WRITE(HLMSG)<0
QUIT
+58 ; patch HL*1.6*142
+59 ; time: this message has been sent
+60 SET $PIECE(^HLMA(HLMSG,"S"),"^",3)=$$NOW^XLFDT
+61 SET (HLTCP,HLTCPI)=HLMSG
SET HLRETRY=HLRETRY+1
SET HLRETRM=HLRETRM+1
+62 ;update status to awaiting response, decrement link if cancelled
+63 IF '$$CHKMSG(1.7)
DO LLCNT^HLCSTCP(HLDP,3,1)
SET HLMSG=0
QUIT
+64 ;set transmission count, get ACKTIMEOUT override
+65 SET $PIECE(^HLMA(HLMSG,"P"),U,5)=HLRETRM
IF $PIECE(^("P"),U,7)
SET HLN("ACKTIME")=+$PIECE(^("P"),U,7)
+66 ;get header of message just sent
+67 KILL HLJ
MERGE HLJ=^HLMA(HLMSG,"MSH")
+68 ;first component of sending app.
+69 SET HLN("ECH")=$$P^HLTPCK2(.HLJ,2)
SET HLN("SAN")=$PIECE($$P^HLTPCK2(.HLJ,3),$EXTRACT(HLN("ECH")))
+70 ;msg type, msg. id, commit ack, and app. ack parameter
+71 SET HLN("TYPE")=$$P^HLTPCK2(.HLJ,1)
SET HLN("MID")=$$P^HLTPCK2(.HLJ,10)
SET HLN("ACAT")=$$P^HLTPCK2(.HLJ,15)
SET HLN("APAT")=$$P^HLTPCK2(.HLJ,16)
+72 ;MSA segment, message is a response, can't have an a. ack.
+73 SET Z=$$MSA^HLTP3(+^HLMA(HLMSG,0))
IF Z]""
if HLN("ACAT")=""
SET HLN("ACAT")="NE"
SET HLN("APAT")="NE"
+74 ;for batch/file with commit ack, reset c. ack and a. ack variables
+75 IF "BHS,FHS"[HLN("TYPE")
SET Z=$EXTRACT(HLJ(1,0),5)
SET X=$$P^HLTPCK2(.HLJ,9)
SET HLN("ACAT")=$PIECE(X,Z,5)
SET HLN("APAT")=$PIECE(X,Z,6)
SET HLN("MID")=$$P^HLTPCK2(.HLJ,11)
+76 ;get event protocol
+77 SET HLN("EID")=+$PIECE(^HLMA(HLMSG,0),U,8)
SET X=$GET(^ORD(101,HLN("EID"),770))
+78 ;set link counter to msg sent
+79 DO LLCNT^HLCSTCP(HLDP,4)
+80 ;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT
+81 IF HLN("ACAT")="NE"
IF HLN("APAT")="NE"
Begin DoDot:1
+82 DO DONE(3)
+83 ;
+84 ;
+85 HANG $GET(HLDWAIT)
End DoDot:1
QUIT
+86 ;
+87 ;do structure is to stack error
+88 Begin DoDot:1
+89 NEW $ETRAP,$ESTACK
SET $ETRAP="D RDERR^HLCSTCP2"
+90 ;HL*1.6*87: Read acknowledgement.
+91 ;Loop to re-read from buffer when receiving incorrect ack.
+92 FOR
Begin DoDot:2
+93 SET HLREREAD=1
+94 ;override ack timeout
+95 IF $GET(HLN("ACKTIME"))
NEW HLDBACK
SET HLDBACK=HLN("ACKTIME")
+96 ;check for response, quit if no-response, msg will be resent
+97 ;HLRESP=ien 773^ien 772 for response message
+98 SET HLRESP=$$READ^HLCSTCP1()
+99 ;if no response, decrement counter and quit
+100 IF 'HLRESP
Begin DoDot:3
+101 DO LLCNT^HLCSTCP(HLDP,4,1)
+102 SET HLREREAD="0^No Response"
+103 ;check if the port needs to be closed and re-opened before the next re-transmission attempt
+104 IF $GET(HLDRETR("CLOSE"))
DO CLOSE^%ZISTCP
KILL HLPORT
End DoDot:3
QUIT
+105 ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error
+106 SET X=$$RSP^HLTP31(HLRESP,.HLN)
+107 ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app)
+108 if 'X
QUIT
+109 ;commit ack - done
+110 ; patch HL*1.6*142
+111 ; time: this message has received commit ACK
+112 SET $PIECE(^HLMA(HLMSG,"S"),"^",4)=$$NOW^XLFDT
+113 IF X=1
Begin DoDot:3
+114 ;don't need app. ack, set status to complete
+115 IF "NE"[HLN("APAT")
Begin DoDot:4
+116 DO DONE(3)
+117 ;
End DoDot:4
QUIT
+118 ;response is deferred, set status to awaiting ack
+119 DO DONE(2)
+120 ;
End DoDot:3
SET HLREREAD="0^Commit Ack"
QUIT
+121 ;Error, HLRESLT=error number^error message from HLTP3
+122 IF X=4
Begin DoDot:3
+123 DO DONE(4,+$GET(HLRESLT),$PIECE($GET(HLRESLT),U,2))
+124 ;
+125 SET HLREREAD="0^Error"
End DoDot:3
QUIT
+126 ;app ack was successful
+127 DO DONE(3)
SET HLREREAD="0^App Ack"
+128 ;
End DoDot:2
if '+$GET(HLREREAD)
QUIT
End DoDot:1
+129 QUIT
+130 ;
DCSEND ;direct connect
+1 ; Set up error trap
+2 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLCSTCP2"
+3 ; patch HL*1.6*122
+4 NEW HLTMBUF
+5 ;override ack timeout
+6 IF $GET(HLP("ACKTIME"))
NEW HLDBACK
SET HLDBACK=HLP("ACKTIME")
+7 ; patch HL*1.6*142
+8 ; time: starts to send this message
+9 SET $PIECE(^HLMA(HLMSG,"S"),"^",2)=$$NOW^XLFDT
+10 ;HL*1.6*77
IF $$WRITE(HLMSG)<0
if $GET(HLERROR)]""
Begin DoDot:1
+11 ;HL*1.6*77
DO STATUS^HLTF0(HLMSG,4,$PIECE(HLERROR,"^"),$PIECE(HLERROR,"^",2),1)
+12 DO LLCNT^HLCSTCP(HLDP,3,1)
End DoDot:1
QUIT
+13 ; patch HL*1.6*142
+14 ; time: this message has been sent
+15 SET $PIECE(^HLMA(HLMSG,"S"),"^",3)=$$NOW^XLFDT
+16 DO LLCNT^HLCSTCP(HLDP,4)
+17 ;do structure is to stack error
+18 Begin DoDot:1
+19 NEW $ETRAP,$ESTACK
SET $ETRAP="D RDERR^HLCSTCP2"
+20 ;HLRESP=ien 773^ien 772 for response message
+21 SET HLRESP=$$READ^HLCSTCP1()
End DoDot:1
+22 ;
+23 ; patch HL*1.6*142
+24 ; time: this message has received app ACK
+25 SET $PIECE(^HLMA(HLMSG,"S"),"^",4)=$$NOW^XLFDT
+26 if $GET(HLRESP)
DO DONE(3)
if '$GET(HLRESP)
DO DONE(4,108,$SELECT($GET(HLERROR)]"":$PIECE(HLERROR,"^",2),1:"No response"))
+27 IF $GET(HLERROR)']""
Begin DoDot:1
+28 DO MON^HLCSTCP("Idle")
+29 IF '$GET(HLRESP)
SET HLERROR="108^No response"
End DoDot:1
+30 ;Close port
+31 IF $DATA(HLPORT)
DO CLOSE^%ZISTCP
KILL HLPORT
+32 QUIT
+33 ;
DONE(ST,ERR,ERRMSG) ;set status to complete
+1 ;ST=status, ERR=error ien, ERRMSG=error msg
+2 DO STATUS^HLTF0(HLMSG,ST,$GET(ERR),$GET(ERRMSG),1)
+3 ;
+4 DO DEQUE^HLCSREP(HLDP,"O",HLMSG)
+5 ;
+6 ;check for more msg.
+7 IF $GET(HLPRIO)'="I"
SET HLMSG=+$ORDER(^HLMA("AC","O",HLDP,0))
SET HLRETRY=0
+8 QUIT
+9 ;
CHKMSG(HLI) ;check status of message and update if not cancelled
+1 ;input: HLI=new status, HLMSG=ien of msg in 773
+2 ;returns 1=msg was updated, 0=msg has been canceled
+3 NEW X
+4 ;
+5 ; New HL*1.6*77 code starting here...
+6 IF '$DATA(^HLMA(HLMSG,"P"))
Begin DoDot:1
+7 SET HLERROR="2^Missing status field"
+8 DO STATUS^HLTF0(HLMSG,4,$PIECE(HLERROR,U),$PIECE(HLERROR,U,2),1)
+9 ;
+10 DO DEQUE^HLCSREP(HLDP,"O",HLMSG)
End DoDot:1
QUIT 0
+11 ;
+12 ; End of HL*1.6*77
+13 ;
+14 ;get status, quit if msg was cancelled
+15 ;
+16 ; patch HL*1.6*145
+17 ; S X=+^HLMA(HLMSG,"P") Q:X=3 0
+18 SET X=+^HLMA(HLMSG,"P")
+19 ;
+20 ;update status if it is different
+21 IF $GET(HLI)
IF HLI'=X
DO STATUS^HLTF0(HLMSG,HLI)
+22 ;
+23 QUIT 1
+24 ;
WRITE(HLDA) ; write message in HL7 format
+1 ; HLDA - ien of message in 773
+2 ; - start block $C(11)
+3 ; - end block $C(28)
+4 ; - record separator $C(13)
+5 ;Output(s): 1 - Successful
+6 ; -1 - Unsuccessful
+7 ;
+8 NEW HLDA2,HLAR,HLI,LINENO,X,CRCOUNT
+9 SET CRCOUNT=0
+10 ;set error trap, used when called from HLTP3
+11 ;
+12 ; New HL*1.6*77 code starts here...
+13 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLCSTCP2"
+14 IF $GET(^HLMA(HLDA,0))'>0
Begin DoDot:1
+15 SET HLERROR="2^Message Text pointer missing"
End DoDot:1
QUIT -1
+16 SET HLDA2=+$GET(^HLMA(HLDA,0))
+17 ; End of HL*1.6*77 modifications...
+18 ;
+19 ;HL*1.6*77
if '$GET(^HLMA(HLDA,0))
QUIT -1
+20 ; header is in ^HLMA(, message is in ^HL(772,
+21 SET LINENO=1
SET HLI=0
SET HLAR="^HLMA(HLDA,""MSH"")"
+22 USE IO
+23 Begin DoDot:1
+24 FOR
SET HLI=$ORDER(@HLAR@(HLI))
if 'HLI
QUIT
SET X=$GET(^(HLI,0))
Begin DoDot:2
+25 ;first line, need start block char.
+26 if LINENO=1
SET X=$CHAR(11)_X
+27 ; HL*1.6*122
+28 ; I X]"" W X,!
+29 NEW LENGTH
+30 SET LENGTH=$LENGTH(X)
+31 ; patch HL*1.6*142 start
+32 ; buffer should be limited to 510
+33 ; I LENGTH>512 D
+34 IF LENGTH>510
Begin DoDot:3
+35 NEW X1
+36 ; F Q:LENGTH<512 D
+37 FOR
if LENGTH<511
QUIT
Begin DoDot:4
+38 ; S X1=$E(X,1,512),X=$E(X,513,999999)
+39 SET X1=$EXTRACT(X,1,510)
SET X=$EXTRACT(X,511,999999)
+40 SET LENGTH=$LENGTH(X)
+41 ; patch HL*1.6*140
+42 ; W X1,@IOF
+43 WRITE X1,@HLTCPLNK("IOF")
End DoDot:4
End DoDot:3
+44 ; patch HL*1.6*142 end
+45 ;
+46 ; @HLTCPLNK("IOF") (! or #) for flush character
+47 IF X]""
WRITE X,@HLTCPLNK("IOF")
SET CRCOUNT=0
+48 ;send CR
+49 IF X=""
WRITE $CHAR(13)
SET CRCOUNT=CRCOUNT+1
+50 ; prevent from maxstring error
+51 IF CRCOUNT>200
WRITE @HLTCPLNK("IOF")
SET CRCOUNT=0
+52 SET LINENO=LINENO+1
End DoDot:2
End DoDot:1
WRITE $CHAR(13)
SET HLAR="^HL(772,HLDA2,""IN"")"
SET HLI=0
Begin DoDot:1
End DoDot:1
+53 ; Sends end block for this message
+54 SET X=$CHAR(28)_$CHAR(13)
+55 ; U IO W X,!
+56 USE IO
WRITE X,@HLTCPLNK("IOF")
+57 ;switch to null device
+58 IF $GET(IO(0))'=""
IF $GET(IO(0))'=IO
USE IO(0)
+59 QUIT 1
+60 ;
OPEN() ; -- Open TCP/IP device (Client)
+1 ;HLPORT=port, defined only if port is open
+2 ;HLPORTA=number of attempted opens
+3 IF $DATA(HLPORT)
SET IO=HLPORT
Begin DoDot:1
+4 USE IO
+5 ; patch HL*1.6*157: HLOS is from calling $$OS^%ZOSV
+6 ; use packet mode on Cache'
+7 ; I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache'
+8 IF (HLOS["VMS")!(HLOS["UNIX")
IF ^%ZOSF("OS")'["GT.M"
XECUTE "U IO:(::""-M"")"
End DoDot:1
QUIT 1
+9 NEW HLDOM,HLI,HLIP,HLPORTA
+10 GOTO OPENA^HLCSTCP3
+11 ;
RDERR DO RDERR^HLCSTCP4
QUIT
ERROR DO ERROR^HLCSTCP4
QUIT
+1 ;
CC(X) ;cleanup and close
+1 DO MON^HLCSTCP(X)
+2 IF $DATA(HLPORT)
DO CLOSE^%ZISTCP
KILL HLPORT
+3 ; patch HL*1.6*140
+4 ; H 2
+5 HANG 1
+6 QUIT
