HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;03/01/2011
;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137,138,139,146,153**;Oct 13, 1995;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;
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"
S HLCSTATE("TCP BUFFER")=""
S HLCSTATE("TCP BUFFER $X")=0
;
;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")=512
.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")=512
.I $G(HLCSTATE("SERVER")) D
..I HLCSTATE("SERVER")="1^S" D Q
...;single server (no concurrent connections)
ZB25 ...;
...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT")
...I $T D
....N A
ZB26 ....S HLCSTATE("CONNECTED")=1
....U HLCSTATE("DEVICE")
....F R *A:HLCSTATE("READ TIMEOUT") Q:$T I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 D CLOSE(.HLCSTATE) Q
ZB27 ....;
...E D
ZB28 ....;
..;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")=512
..O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):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 Q: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
;
;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")-2
;
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
..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
..;put the line in the TCP buffer, or as much as will fit - flush the buffer when it gets full
..F Q:LINE="" D
...N INC
...;INC is how much space is left in the buffer
...S INC=MAX-HLCSTATE("TCP BUFFER $X")
...I '($L(LINE)>INC) D
....S HLCSTATE("TCP BUFFER")=HLCSTATE("TCP BUFFER")_LINE
....S HLCSTATE("TCP BUFFER $X")=HLCSTATE("TCP BUFFER $X")+$L(LINE)
....S LINE=""
...E D
....S HLCSTATE("TCP BUFFER")=HLCSTATE("TCP BUFFER")_$E(LINE,1,INC)
....S HLCSTATE("TCP BUFFER $X")=MAX
....S LINE=$E(LINE,INC+1,99999)
...I HLCSTATE("TCP BUFFER $X")=MAX D
....W HLCSTATE("TCP BUFFER"),@HLCSTATE("FLUSH")
....S HLCSTATE("TCP BUFFER")="",HLCSTATE("TCP BUFFER $X")=0
K HLCSTATE("BUFFER")
S HLCSTATE("BUFFER","SEGMENT COUNT")=1
S HLCSTATE("BUFFER","BYTE COUNT")=0
Q
;
READSEG(HLCSTATE,SEG) ;
;
;Output:
; SEG - returns the segment (pass by reference)
; Function returns 1 on success, 0 on failure
;
K SEG
;**START P139 CJM - if the header segment has been read, and <EB> is encountered before the <CR>, then accept whatever came before <EB> as a segment
Q:HLCSTATE("MESSAGE ENDED") 0
;**END P139
;
N SUCCESS,COUNT,BUF
S (COUNT,SUCCESS)=0
;
;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,999999)
..S SUCCESS=1
.;**START P139 CJM
.I HLCSTATE("MESSAGE STARTED"),BUF[$C(28) D Q
..S SEG(1)=$P(BUF,$C(28)),BUF=$P(BUF,$C(28),2,999999)
..S SUCCESS=1
..S HLCSTATE("MESSAGE ENDED")=1
.;**END P139 CJM
.S SEG(1)=BUF,BUF=""
;
; *** Begin HL*1.6*146 - RBN ***
;I 'SUCCESS U HLCSTATE("DEVICE") F R BUF:HLCSTATE("READ TIMEOUT") Q:'$T D Q:SUCCESS
I 'SUCCESS U HLCSTATE("DEVICE") F Q:'$$READ(.BUF) D Q:SUCCESS
.;** End HL*1.6*146 - RBN ***
.;
.I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,999999) Q
.;
.;**START P139 CJM
.I HLCSTATE("MESSAGE STARTED"),BUF[$C(28) S SUCCESS=1,HLCSTATE("MESSAGE ENDED")=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(28)),BUF=$P(BUF,$C(28),2,999999) Q
.;**END P139 CJM
.;
.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")
;**P146 START CJM
I $G(HLCSTATE("READ TIMEOUT","CHANGED")) D PUTTIME(.HLCSTATE)
;**P146 END CJM
Q
;
ENDMSG(HLCSTATE) ;
N SEG
S SEG(1)=$C(28)
I $$WRITESEG(.HLCSTATE,.SEG) D Q 1
.D FLUSH
.I HLCSTATE("TCP BUFFER $X") D
..U HLCSTATE("DEVICE")
..W HLCSTATE("TCP BUFFER"),@HLCSTATE("FLUSH")
..S HLCSTATE("TCP BUFFER")=""
..S HLCSTATE("TCP BUFFER $X")=0
Q 0
;
;**P146 START CJM
READ(BUF) ;
;Performs a READ to BUF and returns the $T result as the function value.
;For client reads the timeout value is dynamically adjusted based
;on a random sample. For server reads the timeout is static.
;
;
ZB31 ;
N RETURN
S RETURN=0
;for the server the timeout is static
I $G(HLCSTATE("SERVER")) D
.R BUF:HLCSTATE("READ TIMEOUT")
.S RETURN=$T
;
E D ;client
.I ($R(100)<10) D
..;measure how long the READ really takes
.. N T1,T2
.. S T1=$$NOW^XLFDT
.. R BUF:100
..I $T D
...S RETURN=1
...S T2=$$NOW^XLFDT
...D SETTIME($$FMDIFF^XLFDT(T2,T1,2))
..E D
...S RETURN=0
.E D
..R BUF:HLCSTATE("READ TIMEOUT")
..S RETURN=$T
ZB32 ;
;
Q RETURN
;
SETTIME(TIME) ;
;Re-sets the Read Timeout based on an algorithm that uses the
;new read time + the prior 4 historical values.
;
N MAX,I,TEMP
S HLCSTATE("READ TIMEOUT","HISTORICAL")=TIME_"^"_$P(HLCSTATE("READ TIMEOUT","HISTORICAL"),"^",1,4)
S MAX=0
F I=1:1:5 S TEMP=$P(HLCSTATE("READ TIMEOUT","HISTORICAL"),"^",I) I TEMP>MAX S MAX=TEMP
S TEMP=MAX+5
I TEMP<20 S TEMP=20
I TEMP>60 S TEMP=60
S HLCSTATE("READ TIMEOUT")=TEMP
S HLCSTATE("READ TIMEOUT","CHANGED")=1
Q
;
GETTIME(HLCSTATE) ;
;Gets from ^HLTMP the current read timeout for the client link and the
;historical data that the timeout value is based on.
N DATA
S DATA=$G(^HLTMP("READ TIMEOUT",HLCSTATE("LINK","NAME")))
I $P(DATA,"^")<20 D
.S HLCSTATE("READ TIMEOUT")=20
E D
.S HLCSTATE("READ TIMEOUT")=$P(DATA,"^")
S HLCSTATE("READ TIMEOUT","HISTORICAL")=$P(DATA,"^",2,6)
S HLCSTATE("READ TIMEOUT","CHANGED")=0
Q
;
PUTTIME(HLCSTATE) ;
;Stores to ^HLTMP the current read timeout for the client link and
;the historical data that the timeout value is based on.
S ^HLTMP("READ TIMEOUT",HLCSTATE("LINK","NAME"))=HLCSTATE("READ TIMEOUT")_"^"_HLCSTATE("READ TIMEOUT","HISTORICAL")
Q
;**P146 END CJM