HLZTCP ;MILW/JMC - HL7 TCP/IP Hybrid Lower Level Protocol Receiver/Sender ;5/18/99 15:42 [ 04/02/2003 8:37 AM ]
;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
;;1.5;HEALTH LEVEL SEVEN;;JUL 09, 1993
;
INIT ;Initialize Variables
;REDIRECTED BY FROM HLLP IF IOT IS A CHANNEL DEVICE 08/19/02
;I.E. TERMINAL TYPE = CHAN
N HLZIO,HLZOS,HLZSTATE
;S HLZOS=^%ZPSF("OS")
;BEGIN IHS MODE **1004** IHS/ITSC/TPF
S HLZOS=$$VERSION^%ZOSV(1) ;e.g. Cache for Windows NT (Intel)
; MSM for RedHat Linux
;END IHS MOD **1004**
;
;I $D(ZTQUEUED) S ZTREQ="@"
;
I $$NEWERR^%ZTER N $ETRAP S $ETRAP=""
S X="ERR^HLZTCP",@^%ZOSF("TRAP")
;
I '$D(HLION) D Q:POP
. D HOME^%ZIS
. I POP Q
. S HLION=$S(ION']"":"UNKNOWN",1:ION)
;
S HLZIO(0)=IO
;
; Figure out type of connection: 1=Server, 2=Client.
I HLZOS["DSM" S HLZTCP=$S(IOPAR["ADDRESS":2,1:1)
I HLZOS["Cache" D
. N IP
. S IP=$P(IOPAR,"""",2) ; Extract IP address
. S HLZTCP=$S(IP?1.3N1P1.3N1P1.3N1P1.3N:2,1:1)
;
;BEGIN IHS MODE **1004** CHECK FOR MSM SYSTEM IHS/ITSC/TPF 08/19/02
I HLZOS["MSM" D
.S IOP=HLION
.S %ZIS="N" ;TROUBLE GETTING 'NO OPEN' TO WORK.
.D ^%ZIS
.D ^%ZISC ;DEVICE 56 STILL OPENED SO HAD TO CLOSE
.;USE 'USE PARAMETERS' IN DEVICE FILE TO PARSE IP AND PORT
.S IP=$TR($P($P(IOUPAR,"(",2),","),"""")
.S PORT=$P($P(IOUPAR,")"),",",2)
.D CALL^%ZISTCP(IP,PORT,30)
;END IHS MOD **1004**
;
S IOP="NULL DEVICE" D ^%ZIS
I POP G EXIT
S HLZIO=IO K IOP
;
S HLTIME=$$NOW^XLFDT
;
;U HLZIO(0)
; If TCP client, send a "space" to initiate connection.
;I HLZTCP=2 W " ",!
;BEGIN IHS MOD **1004** REPLACES THREE LINES ABOVE
;IHS/ITSC/TPF 08/19/02 I FOUND THE FOLLOWING THREE LINES
;NOT NEEDED FOR MSM CONNECTION
I HLZOS'["MSM" D
.U HLZIO(0)
.; If TCP client, send a "space" to initiate connection.
.I HLZTCP=2 W " ",!
;END IHS MOD **1004**
;
K %,%H,%I,X
S DTIME=$P($G(HLNDAP0),"^",9),HLTRIES=$P($G(HLNDAP0),"^",5)
S:DTIME'>0 DTIME=60 S:HLTRIES'>0 HLTRIES=3
S HLLPC=^%ZOSF("LPC")
;
;
LOOP ; Infinite loop to check for HL7 messages to send/receive
F D I $$S^%ZTLOAD S ZTSTOP=1 Q
. S HLLOG=$S($D(^HL(770,"ALOG",HLION)):1,1:0)
. D CHKREC,CHKSEND
EXIT Q
;
ERR ; Trap error
; Reset current device to "NULL DEVICE".
U:$G(HLZIO)'="" HLZIO
; Reschedule task.
I $$EC^%ZOSV["WRITE"!($$EC^%ZOSV["READ") D
. N ZTDTH,ZTSK
. S ZTSK=ZTQUEUED,ZTDTH="60S",ZTREQ=""
. D REQ^%ZTLOAD ; Requeue task in 60 seconds.
K HLL(1),^TMP("HLR",$J),^TMP("HLS",$J)
Q
;
CHKREC ; Check if there are HL7 messages to receive
; Set flag to receive state.
S HLZSTATE="recv"
D REC
; Received "NAK" message don't know what it goes to.
I $G(HLZNAK) K HLERR Q
I '$D(HLDTOUT),'HLERR D SENDNAK G CHKREC
I '$D(HLDTOUT) U HLZIO K HLERR D ^HLCHK
U HLZIO
Q
;
CHKSEND ; Check if there are HL7 messages to send
; Set flag to send state.
S HLZSTATE="send"
Q:'$D(HLNDAP)
I '$D(HLNDAP0) S HLNDAP0=$G(^HL(770,HLNDAP,0))
S HLDA=+$O(^HL(772,"AC","O",+$P(HLNDAP0,U,12),0)) G:'HLDA EX
S HLDA0=$G(^HL(772,HLDA,0)) G:HLDA0']"" EX
S HLXMZ=+$P(HLDA0,"^",5)
I 'HLXMZ D G EX
. D STATUS^HLTF0(HLDA,4,"","No pointer to Message file(#3.9)")
I '$D(^XMB(3.9,HLXMZ)) D G EX
. D STATUS^HLTF0(HLDA,4,"","No message found at #"_HLXMZ_" in Message file(#3.9)")
I '$O(^XMB(3.9,HLXMZ,2,0)) D G EX
. D STATUS^HLTF0(HLDA,4,"","No message contents at #"_HLXMZ_" in Message file(#3.9)")
S (HLI,HLTRIED)=0,HLSDT=+HLDA0
F HLJ=1:1 S HLI=$O(^XMB(3.9,HLXMZ,2,HLI)) Q:HLI'>0 S ^TMP("HLS",$J,HLSDT,HLJ)=$G(^XMB(3.9,HLXMZ,2,HLI,0))
CS1 ;
S HLTRIED=HLTRIED+1
K ^TMP("HLR",$J),HLSDATA
D SEND
; Set flag to awaiting acknowledgement state.
S HLZSTATE="awaiting ack"
D REC
I HLTRIED'=HLTRIES G CS1:$D(HLDTOUT) G CS1:HLZNAK
G EX:$D(HLDTOUT)
I HLZNAK D G EX
. S HLAC=4,HLMSG="Lower Level Protocol Error - "_$S($E(HLL(1))="X":"Checksum",1:"Character Count")_" Did Not Match"
. D STATUS^HLTF0(HLDA,HLAC,HLMSG)
I $S('$D(HLL(1)):1,"BHS,MSH"'[$E(HLL(1),1,3):1,1:0) D G EX
. S HLAC=4,HLMSG="Application Level error - Header Segment Missing"
. D STATUS^HLTF0(HLDA,HLAC,HLMSG)
K HLXMZ
U HLZIO
D CHK^HLCHK,IN^HLTF(HLMTN,HLMID,HLTIME)
;
EX K HLAC,HLDA,HLDA0,HLERR,HLMSG,HLI,HLJ,HLSDATA,HLSDT,HLTRIED
K ^TMP("HLS",$J),^TMP("HLR",$J)
Q
;
CSUM ;Calculate Checksum
S HLC1=HLC1+$L(X),X=X_HLC2 X HLLPC S HLC2=$C(Y)
Q
;
REC ;Receive a Message
S %=$$NOW^XLFDT
I HLTIME<% S HLTIME=%
E S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
I HLLOG F Q:'$D(^TMP("HL",HLION,HLTIME)) S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
K HLL,^TMP("HLR",$J)
S (HLC2,X0)="",(HLC1,HLI,HLK,HLZEB,HLZNAK)=0
U HLZIO(0)
F R X1#1:DTIME Q:X1=$C(11) I '$T S HLDTOUT=1 Q
; Did not find "Start of block" character.
I X1'=$C(11) Q
S X0=X1,HLZLEN=1
REC1 ;
U HLZIO(0) K HLDTOUT
R X1#1:DTIME I '$T S HLDTOUT=1
; Timed out and buffer empty.
I $G(HLDTOUT),'$L(X1) Q
;
S X0=X0_X1,HLZLEN=HLZLEN+1
; Set "NAK" block type flag.
I X1="N",HLZLEN=2 S HLZNAK=1
; Set "End Block" flag.
I X1=$C(28) S HLZEB=1
I X1'=$C(13) G REC1
I HLZEB,HLZNAK D RECNAK Q
;
; Process "End Block" if not a "NAK" record.
I HLZEB S HLC=+$E(X0,6,8),HLB=+$E(X0,1,5),X0=""
I $L(X0) D
. I HLLOG D ;Record Incoming Transmission in Log
. . S HLII=X0 S:$P(X0,$E(X0,5))="MSH" $P(X0,$E(X0,5),8)=""
. . S HLI=HLI+1,^TMP("HL",HLION,HLTIME,"REC",HLI)=$TR(X0,$C(11,13)),X0=HLII
. I HLK,HLK'>2 S HLL(HLK)=$TR(X0,$C(11,13))
. I HLK S ^TMP("HLR",$J,HLTIME,HLK)=$TR(X0,$C(11,13))
. S HLK=HLK+1,X=X0 D CSUM
. S X0=""
I 'HLZEB G REC1
S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
I HLLOG S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
Q
;
RECNAK ; Process Received "NAK" message.
S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
S HLC=+$E(X0,7,9),HLB=+$E(X0,2,6),X=$E(X0,1) D CSUM
S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
S HLL(1)=$TR(X0,$C(11,13,28)),^TMP("HLR",$J,HLTIME,1)=HLL(1)
I HLLOG D
. S ^TMP("HL",HLION,HLTIME,"REC",1)=HLL(1)
. S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
Q
;
SEND ;Send a Message
N X,Y
S %=$$NOW^XLFDT
I HLTIME<% S HLTIME=%
E S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
I HLLOG F Q:'$D(^TMP("HL",HLION,HLTIME)) S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
S (HLI,HLC1)=0,HLC2=""
D WRITE($C(11)_"D21"_$C(13))
I '$D(HLSDT) F S HLI=$O(HLSDATA(HLI)) Q:HLI="" D WRITE(HLSDATA(HLI)_$C(13))
I $D(HLSDT) F S HLI=$O(^TMP("HLS",$J,HLSDT,HLI)) Q:HLI="" S HLSDATA=^(HLI) D WRITE(HLSDATA_$C(13))
D FLUSH
Q
;
SENDNAK ; Send a "NAK" message.
S (HLC1,HLI)=0,HLC2="",HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
D WRITE($C(11)_"N21"_$C(13)_HLERR)
D FLUSH
K HLSDATA,HLERR
Q
;
WRITE(X) ; Write data in buffer.
U HLZIO(0)
W X,!
I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND",HLI)=$TR(X,$C(11,13))
D CSUM
Q
;
FLUSH ; Write checksum and flush buffer.
S X=HLC2 X HLLPC S X=$E("0000",1,(5-$L(HLC1)))_HLC1_$E("00",1,(3-$L(Y)))_Y_$C(28)_$C(13)
U HLZIO(0)
; Do final write for this block and flush buffer.
W X,!
I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND","CKS")=$TR(X,$C(11,13,28))
Q
HLZTCP ;MILW/JMC - HL7 TCP/IP Hybrid Lower Level Protocol Receiver/Sender ;5/18/99 15:42 [ 04/02/2003 8:37 AM ]
+1 ;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
+2 ;;1.5;HEALTH LEVEL SEVEN;;JUL 09, 1993
+3 ;
INIT ;Initialize Variables
+1 ;REDIRECTED BY FROM HLLP IF IOT IS A CHANNEL DEVICE 08/19/02
+2 ;I.E. TERMINAL TYPE = CHAN
+3 NEW HLZIO,HLZOS,HLZSTATE
+4 ;S HLZOS=^%ZPSF("OS")
+5 ;BEGIN IHS MODE **1004** IHS/ITSC/TPF
+6 ;e.g. Cache for Windows NT (Intel)
SET HLZOS=$$VERSION^%ZOSV(1)
+7 ; MSM for RedHat Linux
+8 ;END IHS MOD **1004**
+9 ;
+10 ;I $D(ZTQUEUED) S ZTREQ="@"
+11 ;
+12 IF $$NEWERR^%ZTER
NEW $ETRAP
SET $ETRAP=""
+13 SET X="ERR^HLZTCP"
SET @^%ZOSF("TRAP")
+14 ;
+15 IF '$DATA(HLION)
Begin DoDot:1
+16 DO HOME^%ZIS
+17 IF POP
QUIT
+18 SET HLION=$SELECT(ION']"":"UNKNOWN",1:ION)
End DoDot:1
IF POP
QUIT
+19 ;
+20 SET HLZIO(0)=IO
+21 ;
+22 ; Figure out type of connection: 1=Server, 2=Client.
+23 IF HLZOS["DSM"
SET HLZTCP=$SELECT(IOPAR["ADDRESS":2,1:1)
+24 IF HLZOS["Cache"
Begin DoDot:1
+25 NEW IP
+26 ; Extract IP address
SET IP=$PIECE(IOPAR,"""",2)
+27 SET HLZTCP=$SELECT(IP?1.3N1P1.3N1P1.3N1P1.3N:2,1:1)
End DoDot:1
+28 ;
+29 ;BEGIN IHS MODE **1004** CHECK FOR MSM SYSTEM IHS/ITSC/TPF 08/19/02
+30 IF HLZOS["MSM"
Begin DoDot:1
+31 SET IOP=HLION
+32 ;TROUBLE GETTING 'NO OPEN' TO WORK.
SET %ZIS="N"
+33 DO ^%ZIS
+34 ;DEVICE 56 STILL OPENED SO HAD TO CLOSE
DO ^%ZISC
+35 ;USE 'USE PARAMETERS' IN DEVICE FILE TO PARSE IP AND PORT
+36 SET IP=$TRANSLATE($PIECE($PIECE(IOUPAR,"(",2),","),"""")
+37 SET PORT=$PIECE($PIECE(IOUPAR,")"),",",2)
+38 DO CALL^%ZISTCP(IP,PORT,30)
End DoDot:1
+39 ;END IHS MOD **1004**
+40 ;
+41 SET IOP="NULL DEVICE"
DO ^%ZIS
+42 IF POP
GOTO EXIT
+43 SET HLZIO=IO
KILL IOP
+44 ;
+45 SET HLTIME=$$NOW^XLFDT
+46 ;
+47 ;U HLZIO(0)
+48 ; If TCP client, send a "space" to initiate connection.
+49 ;I HLZTCP=2 W " ",!
+50 ;BEGIN IHS MOD **1004** REPLACES THREE LINES ABOVE
+51 ;IHS/ITSC/TPF 08/19/02 I FOUND THE FOLLOWING THREE LINES
+52 ;NOT NEEDED FOR MSM CONNECTION
+53 IF HLZOS'["MSM"
Begin DoDot:1
+54 USE HLZIO(0)
+55 ; If TCP client, send a "space" to initiate connection.
+56 IF HLZTCP=2
WRITE " ",!
End DoDot:1
+57 ;END IHS MOD **1004**
+58 ;
+59 KILL %,%H,%I,X
+60 SET DTIME=$PIECE($GET(HLNDAP0),"^",9)
SET HLTRIES=$PIECE($GET(HLNDAP0),"^",5)
+61 IF DTIME'>0
SET DTIME=60
IF HLTRIES'>0
SET HLTRIES=3
+62 SET HLLPC=^%ZOSF("LPC")
+63 ;
+64 ;
LOOP ; Infinite loop to check for HL7 messages to send/receive
+1 FOR
Begin DoDot:1
+2 SET HLLOG=$SELECT($DATA(^HL(770,"ALOG",HLION)):1,1:0)
+3 DO CHKREC
DO CHKSEND
End DoDot:1
IF $$S^%ZTLOAD
SET ZTSTOP=1
QUIT
EXIT QUIT
+1 ;
ERR ; Trap error
+1 ; Reset current device to "NULL DEVICE".
+2 IF $GET(HLZIO)'=""
USE HLZIO
+3 ; Reschedule task.
+4 IF $$EC^%ZOSV["WRITE"!($$EC^%ZOSV["READ")
Begin DoDot:1
+5 NEW ZTDTH,ZTSK
+6 SET ZTSK=ZTQUEUED
SET ZTDTH="60S"
SET ZTREQ=""
+7 ; Requeue task in 60 seconds.
DO REQ^%ZTLOAD
End DoDot:1
+8 KILL HLL(1),^TMP("HLR",$JOB),^TMP("HLS",$JOB)
+9 QUIT
+10 ;
CHKREC ; Check if there are HL7 messages to receive
+1 ; Set flag to receive state.
+2 SET HLZSTATE="recv"
+3 DO REC
+4 ; Received "NAK" message don't know what it goes to.
+5 IF $GET(HLZNAK)
KILL HLERR
QUIT
+6 IF '$DATA(HLDTOUT)
IF 'HLERR
DO SENDNAK
GOTO CHKREC
+7 IF '$DATA(HLDTOUT)
USE HLZIO
KILL HLERR
DO ^HLCHK
+8 USE HLZIO
+9 QUIT
+10 ;
CHKSEND ; Check if there are HL7 messages to send
+1 ; Set flag to send state.
+2 SET HLZSTATE="send"
+3 IF '$DATA(HLNDAP)
QUIT
+4 IF '$DATA(HLNDAP0)
SET HLNDAP0=$GET(^HL(770,HLNDAP,0))
+5 SET HLDA=+$ORDER(^HL(772,"AC","O",+$PIECE(HLNDAP0,U,12),0))
IF 'HLDA
GOTO EX
+6 SET HLDA0=$GET(^HL(772,HLDA,0))
IF HLDA0']""
GOTO EX
+7 SET HLXMZ=+$PIECE(HLDA0,"^",5)
+8 IF 'HLXMZ
Begin DoDot:1
+9 DO STATUS^HLTF0(HLDA,4,"","No pointer to Message file(#3.9)")
End DoDot:1
GOTO EX
+10 IF '$DATA(^XMB(3.9,HLXMZ))
Begin DoDot:1
+11 DO STATUS^HLTF0(HLDA,4,"","No message found at #"_HLXMZ_" in Message file(#3.9)")
End DoDot:1
GOTO EX
+12 IF '$ORDER(^XMB(3.9,HLXMZ,2,0))
Begin DoDot:1
+13 DO STATUS^HLTF0(HLDA,4,"","No message contents at #"_HLXMZ_" in Message file(#3.9)")
End DoDot:1
GOTO EX
+14 SET (HLI,HLTRIED)=0
SET HLSDT=+HLDA0
+15 FOR HLJ=1:1
SET HLI=$ORDER(^XMB(3.9,HLXMZ,2,HLI))
IF HLI'>0
QUIT
SET ^TMP("HLS",$JOB,HLSDT,HLJ)=$GET(^XMB(3.9,HLXMZ,2,HLI,0))
CS1 ;
+1 SET HLTRIED=HLTRIED+1
+2 KILL ^TMP("HLR",$JOB),HLSDATA
+3 DO SEND
+4 ; Set flag to awaiting acknowledgement state.
+5 SET HLZSTATE="awaiting ack"
+6 DO REC
+7 IF HLTRIED'=HLTRIES
IF $DATA(HLDTOUT)
GOTO CS1
IF HLZNAK
GOTO CS1
+8 IF $DATA(HLDTOUT)
GOTO EX
+9 IF HLZNAK
Begin DoDot:1
+10 SET HLAC=4
SET HLMSG="Lower Level Protocol Error - "_$SELECT($EXTRACT(HLL(1))="X":"Checksum",1:"Character Count")_" Did Not Match"
+11 DO STATUS^HLTF0(HLDA,HLAC,HLMSG)
End DoDot:1
GOTO EX
+12 IF $SELECT('$DATA(HLL(1)):1,"BHS,MSH"'[$EXTRACT(HLL(1),1,3):1,1:0)
Begin DoDot:1
+13 SET HLAC=4
SET HLMSG="Application Level error - Header Segment Missing"
+14 DO STATUS^HLTF0(HLDA,HLAC,HLMSG)
End DoDot:1
GOTO EX
+15 KILL HLXMZ
+16 USE HLZIO
+17 DO CHK^HLCHK
DO IN^HLTF(HLMTN,HLMID,HLTIME)
+18 ;
EX KILL HLAC,HLDA,HLDA0,HLERR,HLMSG,HLI,HLJ,HLSDATA,HLSDT,HLTRIED
+1 KILL ^TMP("HLS",$JOB),^TMP("HLR",$JOB)
+2 QUIT
+3 ;
CSUM ;Calculate Checksum
+1 SET HLC1=HLC1+$LENGTH(X)
SET X=X_HLC2
XECUTE HLLPC
SET HLC2=$CHAR(Y)
+2 QUIT
+3 ;
REC ;Receive a Message
+1 SET %=$$NOW^XLFDT
+2 IF HLTIME<%
SET HLTIME=%
+3 IF '$TEST
SET HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+4 IF HLLOG
FOR
IF '$DATA(^TMP("HL",HLION,HLTIME))
QUIT
SET HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+5 KILL HLL,^TMP("HLR",$JOB)
+6 SET (HLC2,X0)=""
SET (HLC1,HLI,HLK,HLZEB,HLZNAK)=0
+7 USE HLZIO(0)
+8 FOR
READ X1#1:DTIME
IF X1=$CHAR(11)
QUIT
IF '$TEST
SET HLDTOUT=1
QUIT
+9 ; Did not find "Start of block" character.
+10 IF X1'=$CHAR(11)
QUIT
+11 SET X0=X1
SET HLZLEN=1
REC1 ;
+1 USE HLZIO(0)
KILL HLDTOUT
+2 READ X1#1:DTIME
IF '$TEST
SET HLDTOUT=1
+3 ; Timed out and buffer empty.
+4 IF $GET(HLDTOUT)
IF '$LENGTH(X1)
QUIT
+5 ;
+6 SET X0=X0_X1
SET HLZLEN=HLZLEN+1
+7 ; Set "NAK" block type flag.
+8 IF X1="N"
IF HLZLEN=2
SET HLZNAK=1
+9 ; Set "End Block" flag.
+10 IF X1=$CHAR(28)
SET HLZEB=1
+11 IF X1'=$CHAR(13)
GOTO REC1
+12 IF HLZEB
IF HLZNAK
DO RECNAK
QUIT
+13 ;
+14 ; Process "End Block" if not a "NAK" record.
+15 IF HLZEB
SET HLC=+$EXTRACT(X0,6,8)
SET HLB=+$EXTRACT(X0,1,5)
SET X0=""
+16 IF $LENGTH(X0)
Begin DoDot:1
+17 ;Record Incoming Transmission in Log
IF HLLOG
Begin DoDot:2
+18 SET HLII=X0
IF $PIECE(X0,$EXTRACT(X0,5))="MSH"
SET $PIECE(X0,$EXTRACT(X0,5),8)=""
+19 SET HLI=HLI+1
SET ^TMP("HL",HLION,HLTIME,"REC",HLI)=$TRANSLATE(X0,$CHAR(11,13))
SET X0=HLII
End DoDot:2
+20 IF HLK
IF HLK'>2
SET HLL(HLK)=$TRANSLATE(X0,$CHAR(11,13))
+21 IF HLK
SET ^TMP("HLR",$JOB,HLTIME,HLK)=$TRANSLATE(X0,$CHAR(11,13))
+22 SET HLK=HLK+1
SET X=X0
DO CSUM
+23 SET X0=""
End DoDot:1
+24 IF 'HLZEB
GOTO REC1
+25 SET X=HLC2
XECUTE HLLPC
SET HLCSUM=Y
SET HLERR=$SELECT(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
+26 IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
+27 QUIT
+28 ;
RECNAK ; Process Received "NAK" message.
+1 SET HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+2 SET HLC=+$EXTRACT(X0,7,9)
SET HLB=+$EXTRACT(X0,2,6)
SET X=$EXTRACT(X0,1)
DO CSUM
+3 SET X=HLC2
XECUTE HLLPC
SET HLCSUM=Y
SET HLERR=$SELECT(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
+4 SET HLL(1)=$TRANSLATE(X0,$CHAR(11,13,28))
SET ^TMP("HLR",$JOB,HLTIME,1)=HLL(1)
+5 IF HLLOG
Begin DoDot:1
+6 SET ^TMP("HL",HLION,HLTIME,"REC",1)=HLL(1)
+7 SET ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
End DoDot:1
+8 QUIT
+9 ;
SEND ;Send a Message
+1 NEW X,Y
+2 SET %=$$NOW^XLFDT
+3 IF HLTIME<%
SET HLTIME=%
+4 IF '$TEST
SET HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+5 IF HLLOG
FOR
IF '$DATA(^TMP("HL",HLION,HLTIME))
QUIT
SET HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+6 SET (HLI,HLC1)=0
SET HLC2=""
+7 DO WRITE($CHAR(11)_"D21"_$CHAR(13))
+8 IF '$DATA(HLSDT)
FOR
SET HLI=$ORDER(HLSDATA(HLI))
IF HLI=""
QUIT
DO WRITE(HLSDATA(HLI)_$CHAR(13))
+9 IF $DATA(HLSDT)
FOR
SET HLI=$ORDER(^TMP("HLS",$JOB,HLSDT,HLI))
IF HLI=""
QUIT
SET HLSDATA=^(HLI)
DO WRITE(HLSDATA_$CHAR(13))
+10 DO FLUSH
+11 QUIT
+12 ;
SENDNAK ; Send a "NAK" message.
+1 SET (HLC1,HLI)=0
SET HLC2=""
SET HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+2 DO WRITE($CHAR(11)_"N21"_$CHAR(13)_HLERR)
+3 DO FLUSH
+4 KILL HLSDATA,HLERR
+5 QUIT
+6 ;
WRITE(X) ; Write data in buffer.
+1 USE HLZIO(0)
+2 WRITE X,!
+3 IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"SEND",HLI)=$TRANSLATE(X,$CHAR(11,13))
+4 DO CSUM
+5 QUIT
+6 ;
FLUSH ; Write checksum and flush buffer.
+1 SET X=HLC2
XECUTE HLLPC
SET X=$EXTRACT("0000",1,(5-$LENGTH(HLC1)))_HLC1_$EXTRACT("00",1,(3-$LENGTH(Y)))_Y_$CHAR(28)_$CHAR(13)
+2 USE HLZIO(0)
+3 ; Do final write for this block and flush buffer.
+4 WRITE X,!
+5 IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"SEND","CKS")=$TRANSLATE(X,$CHAR(11,13,28))
+6 QUIT
