HLOTCP ;ALB/CJM- TCP/IP I/O ;7/10/2008 16:58
;;1.6;HEALTH LEVEL SEVEN;**126,131,1006**;Oct 13, 1995;Build 10
;
; Modified - IHS/MSC/PLS - 02/25/08 - Line RETRY+38
; IHS/CNI/VEN/TOAD - 10 July 2008 - explanation of mod by Rick Marshall,
; VISTA Expertise Network: The e-Prescribing project requires that a
; minor modification be made to the HLOTCP routine being delivered in
; IHS HL*1.6*1006. This modification is a fix to support synchronous
; acknowledgements, is needed for communication with the Cloverleaf
; Interface Engine, and has been extensively tested on the OIT CCHIT
; server. This modification has been in place for several months and
; was used to successfully obtain e-prescribing certification from
; Surescripts. Phil Salmon of Medsphere developed this mod.
;
OPEN(HLCSTATE,LOGICAL) ;
;This may be called either in the context of a client or a server.
;For the server, there are 3 situations:
; 1) The server is not concurrent. In this case the TCP device should be opened.
; 2) The server is concurrent, but this process was spawned by the OS
; (via a VMS TCP Service) In this case, the device should be opened
; via the LOGICAL that was passed in.
; 3) The server is concurrent, but this process was spawned by the
; TaskMan multi-listener. In this case TaskMan already opened the
; device. This case can be determined by the absence of the LOGICAL
; input parameter.
;
N IP,PORT,DNSFLAG
;
S DNSFLAG=0 ;DNS has not been contacted for IP
;
S:'$G(HLCSTATE("SERVER")) IP=HLCSTATE("LINK","IP")
S PORT=HLCSTATE("LINK","PORT")
S HLCSTATE("CONNECTED")=0
S HLCSTATE("READ HEADER")="READHDR^HLOTCP"
S HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP"
S HLCSTATE("READ SEGMENT")="READSEG^HLOTCP"
S HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP"
S HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP"
S HLCSTATE("CLOSE")="CLOSE^HLOTCP"
;
;spawned by TaskMan multi-listener? If so, the device has already been opened
I $G(HLCSTATE("SERVER")),$G(HLCSTATE("LINK","SERVER"))="1^M",$G(LOGICAL)="" D Q
.S HLCSTATE("DEVICE")=IO(0),HLCSTATE("FLUSH")="!",HLCSTATE("TCP BUFFER SIZE")=510
.S HLCSTATE("CONNECTED")=1
;
;if no IP, not a server, give DNS a shot
I '$G(HLCSTATE("SERVER")),IP="" S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")),HLCSTATE("LINK","IP")=IP Q:IP=""
;
RETRY I HLCSTATE("SYSTEM","OS")="DSM" D
.S HLCSTATE("TCP BUFFER SIZE")=512
.I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
.E S HLCSTATE("DEVICE")=PORT
.S HLCSTATE("FLUSH")="!"
.I $G(HLCSTATE("SERVER")) D
..O:$G(LOGICAL)]"" HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
..O:$G(LOGICAL)="" HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
..I $T D
...S HLCSTATE("CONNECTED")=1
...U HLCSTATE("DEVICE"):NOECHO
.E D ;client
..O HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
..I $T D
...S HLCSTATE("CONNECTED")=1
...U HLCSTATE("DEVICE"):NOECHO
E I HLCSTATE("SYSTEM","OS")="CACHE" D
.S HLCSTATE("FLUSH")="!"
.I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
.E S HLCSTATE("DEVICE")="|TCP|"_PORT
.S HLCSTATE("TCP BUFFER SIZE")=510
.I $G(HLCSTATE("SERVER")) D
..I HLCSTATE("SERVER")="1^S" D Q
...;single server (no concurrent connections)
...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT")
...I $T D
....N A
....S HLCSTATE("CONNECTED")=1
....U HLCSTATE("DEVICE")
....F R *A:HLCSTATE("READ TIMEOUT") Q:$T I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 Q
..;
..;multi-server spawned by OS - VMS TCP Services
..O HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT") I '$T S HLCSTATE("CONNECTED")=0 Q
..S HLCSTATE("CONNECTED")=1
..U HLCSTATE("DEVICE"):(::"-S")
..;
.E D ;client
..S HLCSTATE("TCP BUFFER SIZE")=510
..;
..; ** IHS mod ** IHS/MSC/PLS - 02/25/08 - Fix for sync ACKs
..;O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT")
..O HLCSTATE("DEVICE"):(IP:PORT:"+A":::):HLCSTATE("OPEN TIMEOUT")
..;
..I $T D
...S HLCSTATE("CONNECTED")=1
E D ;any other system but Cache or DSM
.S HLCSTATE("TCP BUFFER SIZE")=256
.D CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT"))
.S HLCSTATE("CONNECTED")='POP
.I HLCSTATE("CONNECTED") S HLCSTATE("DEVICE")=IO
;
;if not connected, not the server, give DNS a shot if not tried already
I '$G(HLCSTATE("SERVER")),'HLCSTATE("CONNECTED"),'DNSFLAG S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")) I IP]"",IP'=HLCSTATE("LINK","IP") S HLCSTATE("LINK","IP")=IP G RETRY
I HLCSTATE("CONNECTED"),DNSFLAG S $P(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP
Q
;
DNS(DOMAIN) ;
Q $P($$ADDRESS^XLFNSLK(DOMAIN),",")
;
WRITEHDR(HLCSTATE,HDR) ;
;
;insure that package buffer is empty
K HLCSTATE("BUFFER")
S HLCSTATE("BUFFER","BYTE COUNT")=0
S HLCSTATE("BUFFER","SEGMENT COUNT")=0
S HLCSTATE("FIRST WRITE")=1 ;so that FLUSH knows $X should be 0
;
;Start the message with <SB>, then write the header
N SEG
S SEG(1)=$C(11)_HDR(1)
S SEG(2)=HDR(2)
Q $$WRITESEG(.HLCSTATE,.SEG)
;
WRITESEG(HLCSTATE,SEG) ;
N I,LAST
S HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1
S I=0,LAST=$O(SEG(99999),-1)
F S I=$O(SEG(I)) Q:'I D
.I HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER") D FLUSH
.I I=LAST S SEG(I)=SEG(I)_$C(13)
.S HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I),HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$L(SEG(I))+20
Q HLCSTATE("CONNECTED")
;
FLUSH ;flushes the HL7 package buffer, and the system TCP buffer when full
N SEGMENT,MAX
S SEGMENT=0
S MAX=HLCSTATE("TCP BUFFER SIZE")
U HLCSTATE("DEVICE") I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
F S SEGMENT=$O(HLCSTATE("BUFFER",SEGMENT)) Q:'SEGMENT D
.N I S I=0
.F S I=$O(HLCSTATE("BUFFER",SEGMENT,I)) Q:'I D
..N LINE,J
..S J=$S(HLCSTATE("FIRST WRITE"):0,1:$X)
..S HLCSTATE("FIRST WRITE")=0
..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
..F Q:'(J+$L(LINE)>MAX) D
...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH")
...S LINE=$E(LINE,(MAX-J)+1,99999)
...S J=0
..W:(LINE]"") LINE
K HLCSTATE("BUFFER")
S HLCSTATE("BUFFER","SEGMENT COUNT")=1
S HLCSTATE("BUFFER","BYTE COUNT")=0
S HLCSTATE("FIRST WRITE")=0
Q
;
READSEG(HLCSTATE,SEG) ;
;
;Output:
; SEG - returns the segment (pass by reference)
; Function returns 1 on success, 0 on failure
;
N SUCCESS,COUNT,BUF
S (COUNT,SUCCESS)=0
K SEG
;
;anything left from last read?
S BUF=HLCSTATE("READ")
S HLCSTATE("READ")=""
I BUF]"" D ;something was left!
.S COUNT=1
.I BUF[$C(13) D Q
..S SEG(1)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999)
..S SUCCESS=1
.S SEG(1)=BUF,BUF=""
I 'SUCCESS U HLCSTATE("DEVICE") F R BUF:HLCSTATE("READ TIMEOUT") Q:'$T D Q:SUCCESS
.I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) Q
.S COUNT=COUNT+1,SEG(COUNT)=BUF
;
I SUCCESS D
.S HLCSTATE("READ")=BUF ;save the leftover
.I COUNT>1,SEG(COUNT)="" K SEG(COUNT) S COUNT=COUNT-1
;Cache can return the connection status
E I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
;
;if the <EB> character was encountered, then there are no more segments in the message, set the end of message flag
I SUCCESS,SEG(COUNT)[$C(28) D
.K SEG
.S SUCCESS=0
.S HLCSTATE("MESSAGE ENDED")=1
Q SUCCESS
;
READHDR(HLCSTATE,HDR) ;
;reads the next header segment in the message stream, discarding everything that comes before it
;
N SEG,SUCCESS,J,I
S SUCCESS=0
K HDR
F Q:'$$READSEG(.HLCSTATE,.SEG) D Q:SUCCESS
.S I=0
.;look for the <SB>
.;perhaps the <SB> isn't in the first line
.F S I=$O(SEG(I)) Q:'I D Q:SUCCESS
..I (SEG(I)'[$C(11)) K SEG(I) Q
..S SEG(I)=$P(SEG(I),$C(11),2)
..S SUCCESS=1
..K:SEG(I)="" SEG(I)
I SUCCESS S (I,J)=0 F S J=$O(SEG(J)) Q:'J S I=I+1,HDR(I)=SEG(J)
Q SUCCESS
;
CLOSE(HLCSTATE) ;
CLOSE HLCSTATE("DEVICE")
Q
;
ENDMSG(HLCSTATE) ;
N SEG
S SEG(1)=$C(28)
I $$WRITESEG(.HLCSTATE,.SEG) D Q 1
.D FLUSH
.U HLCSTATE("DEVICE")
.W:$X @HLCSTATE("FLUSH")
Q 0
HLOTCP ;ALB/CJM- TCP/IP I/O ;7/10/2008 16:58
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,131,1006**;Oct 13, 1995;Build 10
+2 ;
+3 ; Modified - IHS/MSC/PLS - 02/25/08 - Line RETRY+38
+4 ; IHS/CNI/VEN/TOAD - 10 July 2008 - explanation of mod by Rick Marshall,
+5 ; VISTA Expertise Network: The e-Prescribing project requires that a
+6 ; minor modification be made to the HLOTCP routine being delivered in
+7 ; IHS HL*1.6*1006. This modification is a fix to support synchronous
+8 ; acknowledgements, is needed for communication with the Cloverleaf
+9 ; Interface Engine, and has been extensively tested on the OIT CCHIT
+10 ; server. This modification has been in place for several months and
+11 ; was used to successfully obtain e-prescribing certification from
+12 ; Surescripts. Phil Salmon of Medsphere developed this mod.
+13 ;
OPEN(HLCSTATE,LOGICAL) ;
+1 ;This may be called either in the context of a client or a server.
+2 ;For the server, there are 3 situations:
+3 ; 1) The server is not concurrent. In this case the TCP device should be opened.
+4 ; 2) The server is concurrent, but this process was spawned by the OS
+5 ; (via a VMS TCP Service) In this case, the device should be opened
+6 ; via the LOGICAL that was passed in.
+7 ; 3) The server is concurrent, but this process was spawned by the
+8 ; TaskMan multi-listener. In this case TaskMan already opened the
+9 ; device. This case can be determined by the absence of the LOGICAL
+10 ; input parameter.
+11 ;
+12 NEW IP,PORT,DNSFLAG
+13 ;
+14 ;DNS has not been contacted for IP
SET DNSFLAG=0
+15 ;
+16 IF '$GET(HLCSTATE("SERVER"))
SET IP=HLCSTATE("LINK","IP")
+17 SET PORT=HLCSTATE("LINK","PORT")
+18 SET HLCSTATE("CONNECTED")=0
+19 SET HLCSTATE("READ HEADER")="READHDR^HLOTCP"
+20 SET HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP"
+21 SET HLCSTATE("READ SEGMENT")="READSEG^HLOTCP"
+22 SET HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP"
+23 SET HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP"
+24 SET HLCSTATE("CLOSE")="CLOSE^HLOTCP"
+25 ;
+26 ;spawned by TaskMan multi-listener? If so, the device has already been opened
+27 IF $GET(HLCSTATE("SERVER"))
IF $GET(HLCSTATE("LINK","SERVER"))="1^M"
IF $GET(LOGICAL)=""
Begin DoDot:1
+28 SET HLCSTATE("DEVICE")=IO(0)
SET HLCSTATE("FLUSH")="!"
SET HLCSTATE("TCP BUFFER SIZE")=510
+29 SET HLCSTATE("CONNECTED")=1
End DoDot:1
QUIT
+30 ;
+31 ;if no IP, not a server, give DNS a shot
+32 IF '$GET(HLCSTATE("SERVER"))
IF IP=""
SET DNSFLAG=1
SET IP=$$DNS(HLCSTATE("LINK","DOMAIN"))
SET HLCSTATE("LINK","IP")=IP
IF IP=""
QUIT
+33 ;
RETRY IF HLCSTATE("SYSTEM","OS")="DSM"
Begin DoDot:1
+1 SET HLCSTATE("TCP BUFFER SIZE")=512
+2 IF $GET(LOGICAL)]""
SET HLCSTATE("DEVICE")=LOGICAL
+3 IF '$TEST
SET HLCSTATE("DEVICE")=PORT
+4 SET HLCSTATE("FLUSH")="!"
+5 IF $GET(HLCSTATE("SERVER"))
Begin DoDot:2
+6 IF $GET(LOGICAL)]""
OPEN HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
+7 IF $GET(LOGICAL)=""
OPEN HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
+8 IF $TEST
Begin DoDot:3
+9 SET HLCSTATE("CONNECTED")=1
+10 USE HLCSTATE("DEVICE"):NOECHO
End DoDot:3
End DoDot:2
+11 ;client
IF '$TEST
Begin DoDot:2
+12 OPEN HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
+13 IF $TEST
Begin DoDot:3
+14 SET HLCSTATE("CONNECTED")=1
+15 USE HLCSTATE("DEVICE"):NOECHO
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF '$TEST
IF HLCSTATE("SYSTEM","OS")="CACHE"
Begin DoDot:1
+17 SET HLCSTATE("FLUSH")="!"
+18 IF $GET(LOGICAL)]""
SET HLCSTATE("DEVICE")=LOGICAL
+19 IF '$TEST
SET HLCSTATE("DEVICE")="|TCP|"_PORT
+20 SET HLCSTATE("TCP BUFFER SIZE")=510
+21 IF $GET(HLCSTATE("SERVER"))
Begin DoDot:2
+22 IF HLCSTATE("SERVER")="1^S"
Begin DoDot:3
+23 ;single server (no concurrent connections)
+24 OPEN HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT")
+25 IF $TEST
Begin DoDot:4
+26 NEW A
+27 SET HLCSTATE("CONNECTED")=1
+28 USE HLCSTATE("DEVICE")
+29 FOR
READ *A:HLCSTATE("READ TIMEOUT")
IF $TEST
QUIT
IF $$CHKSTOP^HLOPROC
SET HLCSTATE("CONNECTED")=0
QUIT
End DoDot:4
End DoDot:3
QUIT
+30 ;
+31 ;multi-server spawned by OS - VMS TCP Services
+32 OPEN HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT")
IF '$TEST
SET HLCSTATE("CONNECTED")=0
QUIT
+33 SET HLCSTATE("CONNECTED")=1
+34 USE HLCSTATE("DEVICE"):(::"-S")
+35 ;
End DoDot:2
+36 ;client
IF '$TEST
Begin DoDot:2
+37 SET HLCSTATE("TCP BUFFER SIZE")=510
+38 ;
+39 ; ** IHS mod ** IHS/MSC/PLS - 02/25/08 - Fix for sync ACKs
+40 ;O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT")
+41 OPEN HLCSTATE("DEVICE"):(IP:PORT:"+A":::):HLCSTATE("OPEN TIMEOUT")
+42 ;
+43 IF $TEST
Begin DoDot:3
+44 SET HLCSTATE("CONNECTED")=1
End DoDot:3
End DoDot:2
End DoDot:1
+45 ;any other system but Cache or DSM
IF '$TEST
Begin DoDot:1
+46 SET HLCSTATE("TCP BUFFER SIZE")=256
+47 DO CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT"))
+48 SET HLCSTATE("CONNECTED")='POP
+49 IF HLCSTATE("CONNECTED")
SET HLCSTATE("DEVICE")=IO
End DoDot:1
+50 ;
+51 ;if not connected, not the server, give DNS a shot if not tried already
+52 IF '$GET(HLCSTATE("SERVER"))
IF 'HLCSTATE("CONNECTED")
IF 'DNSFLAG
SET DNSFLAG=1
SET IP=$$DNS(HLCSTATE("LINK","DOMAIN"))
IF IP]""
IF IP'=HLCSTATE("LINK","IP")
SET HLCSTATE("LINK","IP")=IP
GOTO RETRY
+53 IF HLCSTATE("CONNECTED")
IF DNSFLAG
SET $PIECE(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP
+54 QUIT
+55 ;
DNS(DOMAIN) ;
+1 QUIT $PIECE($$ADDRESS^XLFNSLK(DOMAIN),",")
+2 ;
WRITEHDR(HLCSTATE,HDR) ;
+1 ;
+2 ;insure that package buffer is empty
+3 KILL HLCSTATE("BUFFER")
+4 SET HLCSTATE("BUFFER","BYTE COUNT")=0
+5 SET HLCSTATE("BUFFER","SEGMENT COUNT")=0
+6 ;so that FLUSH knows $X should be 0
SET HLCSTATE("FIRST WRITE")=1
+7 ;
+8 ;Start the message with <SB>, then write the header
+9 NEW SEG
+10 SET SEG(1)=$CHAR(11)_HDR(1)
+11 SET SEG(2)=HDR(2)
+12 QUIT $$WRITESEG(.HLCSTATE,.SEG)
+13 ;
WRITESEG(HLCSTATE,SEG) ;
+1 NEW I,LAST
+2 SET HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1
+3 SET I=0
SET LAST=$ORDER(SEG(99999),-1)
+4 FOR
SET I=$ORDER(SEG(I))
IF 'I
QUIT
Begin DoDot:1
+5 IF HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER")
DO FLUSH
+6 IF I=LAST
SET SEG(I)=SEG(I)_$CHAR(13)
+7 SET HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I)
SET HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$LENGTH(SEG(I))+20
End DoDot:1
+8 QUIT HLCSTATE("CONNECTED")
+9 ;
FLUSH ;flushes the HL7 package buffer, and the system TCP buffer when full
+1 NEW SEGMENT,MAX
+2 SET SEGMENT=0
+3 SET MAX=HLCSTATE("TCP BUFFER SIZE")
+4 USE HLCSTATE("DEVICE")
IF (HLCSTATE("SYSTEM","OS")="CACHE")
SET HLCSTATE("CONNECTED")=($ZA\8192#2)
IF 'HLCSTATE("CONNECTED")
DO CLOSE(.HLCSTATE)
+5 FOR
SET SEGMENT=$ORDER(HLCSTATE("BUFFER",SEGMENT))
IF 'SEGMENT
QUIT
Begin DoDot:1
+6 NEW I
SET I=0
+7 FOR
SET I=$ORDER(HLCSTATE("BUFFER",SEGMENT,I))
IF 'I
QUIT
Begin DoDot:2
+8 NEW LINE,J
+9 SET J=$SELECT(HLCSTATE("FIRST WRITE"):0,1:$X)
+10 SET HLCSTATE("FIRST WRITE")=0
+11 SET LINE=HLCSTATE("BUFFER",SEGMENT,I)
+12 FOR
IF '(J+$LENGTH(LINE)>MAX)
QUIT
Begin DoDot:3
+13 WRITE $EXTRACT(LINE,1,MAX-J),@HLCSTATE("FLUSH")
+14 SET LINE=$EXTRACT(LINE,(MAX-J)+1,99999)
+15 SET J=0
End DoDot:3
+16 IF (LINE]"")
WRITE LINE
End DoDot:2
End DoDot:1
+17 KILL HLCSTATE("BUFFER")
+18 SET HLCSTATE("BUFFER","SEGMENT COUNT")=1
+19 SET HLCSTATE("BUFFER","BYTE COUNT")=0
+20 SET HLCSTATE("FIRST WRITE")=0
+21 QUIT
+22 ;
READSEG(HLCSTATE,SEG) ;
+1 ;
+2 ;Output:
+3 ; SEG - returns the segment (pass by reference)
+4 ; Function returns 1 on success, 0 on failure
+5 ;
+6 NEW SUCCESS,COUNT,BUF
+7 SET (COUNT,SUCCESS)=0
+8 KILL SEG
+9 ;
+10 ;anything left from last read?
+11 SET BUF=HLCSTATE("READ")
+12 SET HLCSTATE("READ")=""
+13 ;something was left!
IF BUF]""
Begin DoDot:1
+14 SET COUNT=1
+15 IF BUF[$CHAR(13)
Begin DoDot:2
+16 SET SEG(1)=$PIECE(BUF,$CHAR(13))
SET BUF=$PIECE(BUF,$CHAR(13),2,9999)
+17 SET SUCCESS=1
End DoDot:2
QUIT
+18 SET SEG(1)=BUF
SET BUF=""
End DoDot:1
+19 IF 'SUCCESS
USE HLCSTATE("DEVICE")
FOR
READ BUF:HLCSTATE("READ TIMEOUT")
IF '$TEST
QUIT
Begin DoDot:1
+20 IF BUF[$CHAR(13)
SET SUCCESS=1
SET COUNT=COUNT+1
SET SEG(COUNT)=$PIECE(BUF,$CHAR(13))
SET BUF=$PIECE(BUF,$CHAR(13),2,9999)
QUIT
+21 SET COUNT=COUNT+1
SET SEG(COUNT)=BUF
End DoDot:1
IF SUCCESS
QUIT
+22 ;
+23 IF SUCCESS
Begin DoDot:1
+24 ;save the leftover
SET HLCSTATE("READ")=BUF
+25 IF COUNT>1
IF SEG(COUNT)=""
KILL SEG(COUNT)
SET COUNT=COUNT-1
End DoDot:1
+26 ;Cache can return the connection status
+27 IF '$TEST
IF (HLCSTATE("SYSTEM","OS")="CACHE")
SET HLCSTATE("CONNECTED")=($ZA\8192#2)
IF 'HLCSTATE("CONNECTED")
DO CLOSE(.HLCSTATE)
+28 ;
+29 ;if the <EB> character was encountered, then there are no more segments in the message, set the end of message flag
+30 IF SUCCESS
IF SEG(COUNT)[$CHAR(28)
Begin DoDot:1
+31 KILL SEG
+32 SET SUCCESS=0
+33 SET HLCSTATE("MESSAGE ENDED")=1
End DoDot:1
+34 QUIT SUCCESS
+35 ;
READHDR(HLCSTATE,HDR) ;
+1 ;reads the next header segment in the message stream, discarding everything that comes before it
+2 ;
+3 NEW SEG,SUCCESS,J,I
+4 SET SUCCESS=0
+5 KILL HDR
+6 FOR
IF '$$READSEG(.HLCSTATE,.SEG)
QUIT
Begin DoDot:1
+7 SET I=0
+8 ;look for the <SB>
+9 ;perhaps the <SB> isn't in the first line
+10 FOR
SET I=$ORDER(SEG(I))
IF 'I
QUIT
Begin DoDot:2
+11 IF (SEG(I)'[$CHAR(11))
KILL SEG(I)
QUIT
+12 SET SEG(I)=$PIECE(SEG(I),$CHAR(11),2)
+13 SET SUCCESS=1
+14 IF SEG(I)=""
KILL SEG(I)
End DoDot:2
IF SUCCESS
QUIT
End DoDot:1
IF SUCCESS
QUIT
+15 IF SUCCESS
SET (I,J)=0
FOR
SET J=$ORDER(SEG(J))
IF 'J
QUIT
SET I=I+1
SET HDR(I)=SEG(J)
+16 QUIT SUCCESS
+17 ;
CLOSE(HLCSTATE) ;
+1 CLOSE HLCSTATE("DEVICE")
+2 QUIT
+3 ;
ENDMSG(HLCSTATE) ;
+1 NEW SEG
+2 SET SEG(1)=$CHAR(28)
+3 IF $$WRITESEG(.HLCSTATE,.SEG)
Begin DoDot:1
+4 DO FLUSH
+5 USE HLCSTATE("DEVICE")
+6 IF $X
WRITE @HLCSTATE("FLUSH")
End DoDot:1
QUIT 1
+7 QUIT 0
