- 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