Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLOTCP

HLOTCP.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Modified - IHS/MSC/PLS - 02/25/08 - Line RETRY+38
  1. ; IHS/CNI/VEN/TOAD - 10 July 2008 - explanation of mod by Rick Marshall,
  1. ; VISTA Expertise Network: The e-Prescribing project requires that a
  1. ; minor modification be made to the HLOTCP routine being delivered in
  1. ; IHS HL*1.6*1006. This modification is a fix to support synchronous
  1. ; acknowledgements, is needed for communication with the Cloverleaf
  1. ; Interface Engine, and has been extensively tested on the OIT CCHIT
  1. ; server. This modification has been in place for several months and
  1. ; was used to successfully obtain e-prescribing certification from
  1. ; Surescripts. Phil Salmon of Medsphere developed this mod.
  1. ;
  1. OPEN(HLCSTATE,LOGICAL) ;
  1. ;This may be called either in the context of a client or a server.
  1. ;For the server, there are 3 situations:
  1. ; 1) The server is not concurrent. In this case the TCP device should be opened.
  1. ; 2) The server is concurrent, but this process was spawned by the OS
  1. ; (via a VMS TCP Service) In this case, the device should be opened
  1. ; via the LOGICAL that was passed in.
  1. ; 3) The server is concurrent, but this process was spawned by the
  1. ; TaskMan multi-listener. In this case TaskMan already opened the
  1. ; device. This case can be determined by the absence of the LOGICAL
  1. ; input parameter.
  1. ;
  1. N IP,PORT,DNSFLAG
  1. ;
  1. S DNSFLAG=0 ;DNS has not been contacted for IP
  1. ;
  1. S:'$G(HLCSTATE("SERVER")) IP=HLCSTATE("LINK","IP")
  1. S PORT=HLCSTATE("LINK","PORT")
  1. S HLCSTATE("CONNECTED")=0
  1. S HLCSTATE("READ HEADER")="READHDR^HLOTCP"
  1. S HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP"
  1. S HLCSTATE("READ SEGMENT")="READSEG^HLOTCP"
  1. S HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP"
  1. S HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP"
  1. S HLCSTATE("CLOSE")="CLOSE^HLOTCP"
  1. ;
  1. ;spawned by TaskMan multi-listener? If so, the device has already been opened
  1. I $G(HLCSTATE("SERVER")),$G(HLCSTATE("LINK","SERVER"))="1^M",$G(LOGICAL)="" D Q
  1. .S HLCSTATE("DEVICE")=IO(0),HLCSTATE("FLUSH")="!",HLCSTATE("TCP BUFFER SIZE")=510
  1. .S HLCSTATE("CONNECTED")=1
  1. ;
  1. ;if no IP, not a server, give DNS a shot
  1. I '$G(HLCSTATE("SERVER")),IP="" S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")),HLCSTATE("LINK","IP")=IP Q:IP=""
  1. ;
  1. RETRY I HLCSTATE("SYSTEM","OS")="DSM" D
  1. .S HLCSTATE("TCP BUFFER SIZE")=512
  1. .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
  1. .E S HLCSTATE("DEVICE")=PORT
  1. .S HLCSTATE("FLUSH")="!"
  1. .I $G(HLCSTATE("SERVER")) D
  1. ..O:$G(LOGICAL)]"" HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
  1. ..O:$G(LOGICAL)="" HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
  1. ..I $T D
  1. ...S HLCSTATE("CONNECTED")=1
  1. ...U HLCSTATE("DEVICE"):NOECHO
  1. .E D ;client
  1. ..O HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
  1. ..I $T D
  1. ...S HLCSTATE("CONNECTED")=1
  1. ...U HLCSTATE("DEVICE"):NOECHO
  1. E I HLCSTATE("SYSTEM","OS")="CACHE" D
  1. .S HLCSTATE("FLUSH")="!"
  1. .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
  1. .E S HLCSTATE("DEVICE")="|TCP|"_PORT
  1. .S HLCSTATE("TCP BUFFER SIZE")=510
  1. .I $G(HLCSTATE("SERVER")) D
  1. ..I HLCSTATE("SERVER")="1^S" D Q
  1. ...;single server (no concurrent connections)
  1. ...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT")
  1. ...I $T D
  1. ....N A
  1. ....S HLCSTATE("CONNECTED")=1
  1. ....U HLCSTATE("DEVICE")
  1. ....F R *A:HLCSTATE("READ TIMEOUT") Q:$T I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 Q
  1. ..;
  1. ..;multi-server spawned by OS - VMS TCP Services
  1. ..O HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT") I '$T S HLCSTATE("CONNECTED")=0 Q
  1. ..S HLCSTATE("CONNECTED")=1
  1. ..U HLCSTATE("DEVICE"):(::"-S")
  1. ..;
  1. .E D ;client
  1. ..S HLCSTATE("TCP BUFFER SIZE")=510
  1. ..;
  1. ..; ** IHS mod ** IHS/MSC/PLS - 02/25/08 - Fix for sync ACKs
  1. ..;O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT")
  1. ..O HLCSTATE("DEVICE"):(IP:PORT:"+A":::):HLCSTATE("OPEN TIMEOUT")
  1. ..;
  1. ..I $T D
  1. ...S HLCSTATE("CONNECTED")=1
  1. E D ;any other system but Cache or DSM
  1. .S HLCSTATE("TCP BUFFER SIZE")=256
  1. .D CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT"))
  1. .S HLCSTATE("CONNECTED")='POP
  1. .I HLCSTATE("CONNECTED") S HLCSTATE("DEVICE")=IO
  1. ;
  1. ;if not connected, not the server, give DNS a shot if not tried already
  1. 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
  1. I HLCSTATE("CONNECTED"),DNSFLAG S $P(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP
  1. Q
  1. ;
  1. DNS(DOMAIN) ;
  1. Q $P($$ADDRESS^XLFNSLK(DOMAIN),",")
  1. ;
  1. WRITEHDR(HLCSTATE,HDR) ;
  1. ;
  1. ;insure that package buffer is empty
  1. K HLCSTATE("BUFFER")
  1. S HLCSTATE("BUFFER","BYTE COUNT")=0
  1. S HLCSTATE("BUFFER","SEGMENT COUNT")=0
  1. S HLCSTATE("FIRST WRITE")=1 ;so that FLUSH knows $X should be 0
  1. ;
  1. ;Start the message with <SB>, then write the header
  1. N SEG
  1. S SEG(1)=$C(11)_HDR(1)
  1. S SEG(2)=HDR(2)
  1. Q $$WRITESEG(.HLCSTATE,.SEG)
  1. ;
  1. WRITESEG(HLCSTATE,SEG) ;
  1. N I,LAST
  1. S HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1
  1. S I=0,LAST=$O(SEG(99999),-1)
  1. F S I=$O(SEG(I)) Q:'I D
  1. .I HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER") D FLUSH
  1. .I I=LAST S SEG(I)=SEG(I)_$C(13)
  1. .S HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I),HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$L(SEG(I))+20
  1. Q HLCSTATE("CONNECTED")
  1. ;
  1. FLUSH ;flushes the HL7 package buffer, and the system TCP buffer when full
  1. N SEGMENT,MAX
  1. S SEGMENT=0
  1. S MAX=HLCSTATE("TCP BUFFER SIZE")
  1. U HLCSTATE("DEVICE") I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
  1. F S SEGMENT=$O(HLCSTATE("BUFFER",SEGMENT)) Q:'SEGMENT D
  1. .N I S I=0
  1. .F S I=$O(HLCSTATE("BUFFER",SEGMENT,I)) Q:'I D
  1. ..N LINE,J
  1. ..S J=$S(HLCSTATE("FIRST WRITE"):0,1:$X)
  1. ..S HLCSTATE("FIRST WRITE")=0
  1. ..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
  1. ..F Q:'(J+$L(LINE)>MAX) D
  1. ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH")
  1. ...S LINE=$E(LINE,(MAX-J)+1,99999)
  1. ...S J=0
  1. ..W:(LINE]"") LINE
  1. K HLCSTATE("BUFFER")
  1. S HLCSTATE("BUFFER","SEGMENT COUNT")=1
  1. S HLCSTATE("BUFFER","BYTE COUNT")=0
  1. S HLCSTATE("FIRST WRITE")=0
  1. Q
  1. ;
  1. READSEG(HLCSTATE,SEG) ;
  1. ;
  1. ;Output:
  1. ; SEG - returns the segment (pass by reference)
  1. ; Function returns 1 on success, 0 on failure
  1. ;
  1. N SUCCESS,COUNT,BUF
  1. S (COUNT,SUCCESS)=0
  1. K SEG
  1. ;
  1. ;anything left from last read?
  1. S BUF=HLCSTATE("READ")
  1. S HLCSTATE("READ")=""
  1. I BUF]"" D ;something was left!
  1. .S COUNT=1
  1. .I BUF[$C(13) D Q
  1. ..S SEG(1)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999)
  1. ..S SUCCESS=1
  1. .S SEG(1)=BUF,BUF=""
  1. I 'SUCCESS U HLCSTATE("DEVICE") F R BUF:HLCSTATE("READ TIMEOUT") Q:'$T D Q:SUCCESS
  1. .I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) Q
  1. .S COUNT=COUNT+1,SEG(COUNT)=BUF
  1. ;
  1. I SUCCESS D
  1. .S HLCSTATE("READ")=BUF ;save the leftover
  1. .I COUNT>1,SEG(COUNT)="" K SEG(COUNT) S COUNT=COUNT-1
  1. ;Cache can return the connection status
  1. E I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
  1. ;
  1. ;if the <EB> character was encountered, then there are no more segments in the message, set the end of message flag
  1. I SUCCESS,SEG(COUNT)[$C(28) D
  1. .K SEG
  1. .S SUCCESS=0
  1. .S HLCSTATE("MESSAGE ENDED")=1
  1. Q SUCCESS
  1. ;
  1. READHDR(HLCSTATE,HDR) ;
  1. ;reads the next header segment in the message stream, discarding everything that comes before it
  1. ;
  1. N SEG,SUCCESS,J,I
  1. S SUCCESS=0
  1. K HDR
  1. F Q:'$$READSEG(.HLCSTATE,.SEG) D Q:SUCCESS
  1. .S I=0
  1. .;look for the <SB>
  1. .;perhaps the <SB> isn't in the first line
  1. .F S I=$O(SEG(I)) Q:'I D Q:SUCCESS
  1. ..I (SEG(I)'[$C(11)) K SEG(I) Q
  1. ..S SEG(I)=$P(SEG(I),$C(11),2)
  1. ..S SUCCESS=1
  1. ..K:SEG(I)="" SEG(I)
  1. I SUCCESS S (I,J)=0 F S J=$O(SEG(J)) Q:'J S I=I+1,HDR(I)=SEG(J)
  1. Q SUCCESS
  1. ;
  1. CLOSE(HLCSTATE) ;
  1. CLOSE HLCSTATE("DEVICE")
  1. Q
  1. ;
  1. ENDMSG(HLCSTATE) ;
  1. N SEG
  1. S SEG(1)=$C(28)
  1. I $$WRITESEG(.HLCSTATE,.SEG) D Q 1
  1. .D FLUSH
  1. .U HLCSTATE("DEVICE")
  1. .W:$X @HLCSTATE("FLUSH")
  1. Q 0