HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133**;JUL 17,1995;Build 13
;Per VHA Directive 2004-038, this routine should not be modified.
;Receiver
;connection is initiated by sender and listener accepts connection
;and calls this routine
;
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
N HLMIEN,HLASTMSG
D MON^HLCSTCP("Open")
K ^TMP("HLCSTCP",$J,0)
S HLMIEN=0,HLASTMSG=""
F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3
. S HLMIEN=$$READ
. Q:'HLMIEN
. D PROCESS
Q
;
PROCESS ;check message and reply
;HLDP=LL in 870, update monitor, received msg.
N HLTCP,HLTCPI,HLTCPO
S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
;update monitor, msg. received
D LLCNT^HLCSTCP(HLDP,1)
D NEW^HLTP3(HLMIEN)
;update monitor, msg. processed
D LLCNT^HLCSTCP(HLDP,2)
Q
;
READ() ;read 1 message, returns ien in 773^ien in 772 for message
D MON^HLCSTCP("Reading")
N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack
S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
K ^TMP("HLCSTCP",$J,0)
F D RDBLK Q:HLRDOUT
;save any excess for next time
S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX
I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
Q HLIND1
;
RDBLK S HLDB=HLDBSIZE-$L(HLX)
U IO R X#HLDB:HLDREAD
;switch to null device if opened to prevent 'leakage'
I $G(IO(0))'="",$G(IO(0))'=IO U IO(0)
; timedout, check ack timeout, clean up
I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
;data stream: <sb>dddd<cr><eb><cr>
;add incoming line to what wasn't processed in last read
S HLX=$G(HLX)_X
; look for segment= <CR>
F Q:HLX'[HLRS D Q:HLRDOUT
. ; Get the first piece, save the rest of the line
. S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
. ; check for start block, Quit if no ien
. I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q
.. D:HLMSG(HLINE,0)[HLDSTRT
... S X=$L(HLMSG(HLINE,0),HLDSTRT)
... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
... D RESET:(HLINE>1)
.. ;ping message
.. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
.. ; get next ien to store
.. D MIEN
.. K HLMSG
.. S (HLINE,HLHDR)=0
. ; check for end block; HLMSG(HLINE) = <eb><cr>
. I HLMSG(HLINE,0)[HLDEND D
.. ;no msg. ien
.. Q:'HLIND1
.. ; Kill just the last line
.. K HLMSG(HLINE,0) S HLINE=HLINE-1
.. ; move into 772
.. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
.. ;mark that end block has been received
.. ;HLIND1=ien in 773^ien in 772^1 if end block was received
.. S $P(HLIND1,U,3)=1
.. ;reset variables for next message
.. D CLEAN
. ;add blank line for carriage return
. I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
Q:HLRDOUT
;If the line is long and no <CR> move it into the array.
I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q
. S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
;have start block but no record seperator
I HLX[HLDSTRT D Q
. ;check for more than 1 start block
. S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
. S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
. D RESET:(HLHDR&(HLINE>1))
;if no ien, then we don't have start block, reset
I 'HLIND1 D CLEAN Q
; big message-merge from local to global every 100 lines
I (HLINE-$O(HLMSG(0)))>100 D
. M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
. ; reset working array
. K HLMSG
Q
;
SAVE(SRC,DEST) ;save into global & set top node
;SRC=source array (passed by ref.), DEST=destination global
M @DEST=SRC
S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
Q
;
DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
N DIK,DA
S DA=+HLMAMT,DIK="^HLMA("
D ^DIK
S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
D ^DIK
Q
MIEN ; sets HLIND1=ien in 773^ien in 772 for message
N HLMID,X
I HLIND1 D
. S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
. S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
;msg. id is 10th of MSH & 11th for BSH or FSH
S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
;if HLIND1 is set, kill old message, use HLIND1 for new
;message, it means we never got end block for 1st msg.
I HLIND1 D Q
. ;get pointer to 772, kill header
. K ^HLMA(+HLIND1,"MSH")
. I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
. S X=$$MAID^HLTF(+HLIND1,HLMID)
. D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
. S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
D TCP^HLTF(.HLMID,.X,.HLDT)
I 'X D Q
. ;error - record and reset array
. ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
. D CLEAN K HLLSTN
. ;error 100=LLP Could not Enqueue the Message, reset array
. D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
;HLIND1=ien in 773^ien in 772
S HLIND1=X_U_+$G(^HLMA(X,0))
;save MSH into 773
D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
Q
;
PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
N FS,I,L,L1,L2,X,Y
S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0))
. S:L1=1 L=L+1
. S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
. S L2=Y,Y=L
Q X
;
PING ;process PING message
S X=HLMSG(1,0)
I X[HLDEND U IO W X,! I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) ;switch to null device if opened to prevent 'leakage'
;
CLEAN ;reset var. for next message
K HLMSG
S HLINE=0,HLRDOUT=1
Q
;
ERROR ; Error trap for disconnect error and return back to the read loop.
S $ETRAP="D UNWIND^%ZTER"
I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
S HLCSOUT=1 D ^%ZTER,CC("Error")
D UNWIND^%ZTER
Q
;
CC(X) ;cleanup and close
D MON^HLCSTCP(X)
H 2
Q
RESET ;reset info as a result of no end block
N %
S HLMSG(1,0)=HLMSG(HLINE,0)
F %=2:1:HLINE K HLMSG(%,0)
S HLINE=1
Q
HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133**;JUL 17,1995;Build 13
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Receiver
+4 ;connection is initiated by sender and listener accepts connection
+5 ;and calls this routine
+6 ;
+7 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLCSTCP1"
+8 NEW HLMIEN,HLASTMSG
+9 DO MON^HLCSTCP("Open")
+10 KILL ^TMP("HLCSTCP",$JOB,0)
+11 SET HLMIEN=0
SET HLASTMSG=""
+12 FOR
Begin DoDot:1
+13 SET HLMIEN=$$READ
+14 IF 'HLMIEN
QUIT
+15 DO PROCESS
End DoDot:1
IF $$STOP^HLCSTCP
QUIT
IF 'HLMIEN
DO MON^HLCSTCP("Idle")
HANG 3
+16 QUIT
+17 ;
PROCESS ;check message and reply
+1 ;HLDP=LL in 870, update monitor, received msg.
+2 NEW HLTCP,HLTCPI,HLTCPO
+3 SET HLTCP=""
SET HLTCPO=HLDP
SET HLTCPI=+HLMIEN
+4 ;update monitor, msg. received
+5 DO LLCNT^HLCSTCP(HLDP,1)
+6 DO NEW^HLTP3(HLMIEN)
+7 ;update monitor, msg. processed
+8 DO LLCNT^HLCSTCP(HLDP,2)
+9 QUIT
+10 ;
READ() ;read 1 message, returns ien in 773^ien in 772 for message
+1 DO MON^HLCSTCP("Reading")
+2 NEW HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
+3 ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
+4 SET HLDSTRT=$CHAR(11)
SET HLDEND=$CHAR(28)
SET HLRS=$CHAR(13)
+5 ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
+6 ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack
+7 SET (HLRDOUT,HLINE,HLIND1,HLHDR)=0
SET HLX=$GET(^TMP("HLCSTCP",$JOB,0))
SET HLACKWT=HLDBACK
+8 KILL ^TMP("HLCSTCP",$JOB,0)
+9 FOR
DO RDBLK
IF HLRDOUT
QUIT
+10 ;save any excess for next time
+11 IF $LENGTH(HLX)
SET ^TMP("HLCSTCP",$JOB,0)=HLX
+12 IF +HLIND1
IF '$PIECE(HLIND1,U,3)
DO DELMSG(HLIND1)
SET HLIND1=0
+13 QUIT HLIND1
+14 ;
RDBLK SET HLDB=HLDBSIZE-$LENGTH(HLX)
+1 USE IO
READ X#HLDB:HLDREAD
+2 ;switch to null device if opened to prevent 'leakage'
+3 IF $GET(IO(0))'=""
IF $GET(IO(0))'=IO
USE IO(0)
+4 ; timedout, check ack timeout, clean up
+5 IF '$TEST
IF X=""
IF HLX=""
SET HLACKWT=HLACKWT-HLDREAD
IF HLACKWT<0&'HLHDR
DO CLEAN
QUIT
+6 ;data stream: <sb>dddd<cr><eb><cr>
+7 ;add incoming line to what wasn't processed in last read
+8 SET HLX=$GET(HLX)_X
+9 ; look for segment= <CR>
+10 FOR
IF HLX'[HLRS
QUIT
Begin DoDot:1
+11 ; Get the first piece, save the rest of the line
+12 SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=$PIECE(HLX,HLRS)
SET HLX=$PIECE(HLX,HLRS,2,999)
+13 ; check for start block, Quit if no ien
+14 IF HLMSG(HLINE,0)[HLDSTRT!HLHDR
Begin DoDot:2
+15 IF HLMSG(HLINE,0)[HLDSTRT
Begin DoDot:3
+16 SET X=$LENGTH(HLMSG(HLINE,0),HLDSTRT)
+17 IF X>2
SET HLMSG(HLINE,0)=HLDSTRT_$PIECE(HLMSG(HLINE,0),HLDSTRT,X)
+18 SET HLMSG(HLINE,0)=$PIECE(HLMSG(HLINE,0),HLDSTRT,2)
+19 IF (HLINE>1)
DO RESET
End DoDot:3
+20 ;ping message
+21 IF $EXTRACT(HLMSG(1,0),1,9)="MSH^PING^"
DO PING
QUIT
+22 ; get next ien to store
+23 DO MIEN
+24 KILL HLMSG
+25 SET (HLINE,HLHDR)=0
End DoDot:2
QUIT
+26 ; check for end block; HLMSG(HLINE) = <eb><cr>
+27 IF HLMSG(HLINE,0)[HLDEND
Begin DoDot:2
+28 ;no msg. ien
+29 IF 'HLIND1
QUIT
+30 ; Kill just the last line
+31 KILL HLMSG(HLINE,0)
SET HLINE=HLINE-1
+32 ; move into 772
+33 DO SAVE(.HLMSG,"^HL(772,"_+$PIECE(HLIND1,U,2)_",""IN"")")
+34 ;mark that end block has been received
+35 ;HLIND1=ien in 773^ien in 772^1 if end block was received
+36 SET $PIECE(HLIND1,U,3)=1
+37 ;reset variables for next message
+38 DO CLEAN
End DoDot:2
+39 ;add blank line for carriage return
+40 IF HLINE'=0
IF HLMSG(HLINE,0)]""
SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=""
End DoDot:1
IF HLRDOUT
QUIT
+41 IF HLRDOUT
QUIT
+42 ;If the line is long and no <CR> move it into the array.
+43 IF ($LENGTH(HLX)=HLDBSIZE)
IF (HLX'[HLRS)
IF (HLX'[HLDEND)
IF (HLX'[HLDSTRT)
Begin DoDot:1
+44 SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=HLX
SET HLX=""
End DoDot:1
QUIT
+45 ;have start block but no record seperator
+46 IF HLX[HLDSTRT
Begin DoDot:1
+47 ;check for more than 1 start block
+48 SET X=$LENGTH(HLX,HLDSTRT)
IF X>2
SET HLX=HLDSTRT_$PIECE(HLX,HLDSTRT,X)
+49 IF $LENGTH($PIECE(HLX,HLDSTRT,2))>8
SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=$PIECE(HLX,HLDSTRT,2)
SET HLX=""
SET HLHDR=1
+50 IF (HLHDR&(HLINE>1))
DO RESET
End DoDot:1
QUIT
+51 ;if no ien, then we don't have start block, reset
+52 IF 'HLIND1
DO CLEAN
QUIT
+53 ; big message-merge from local to global every 100 lines
+54 IF (HLINE-$ORDER(HLMSG(0)))>100
Begin DoDot:1
+55 MERGE ^HL(772,+$PIECE(HLIND1,U,2),"IN")=HLMSG
+56 ; reset working array
+57 KILL HLMSG
End DoDot:1
+58 QUIT
+59 ;
SAVE(SRC,DEST) ;save into global & set top node
+1 ;SRC=source array (passed by ref.), DEST=destination global
+2 MERGE @DEST=SRC
+3 SET @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
+4 QUIT
+5 ;
DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
+1 NEW DIK,DA
+2 SET DA=+HLMAMT
SET DIK="^HLMA("
+3 DO ^DIK
+4 SET DA=$PIECE(HLMAMT,U,2)
SET DIK="^HL(772,"
+5 DO ^DIK
+6 QUIT
MIEN ; sets HLIND1=ien in 773^ien in 772 for message
+1 NEW HLMID,X
+2 IF HLIND1
Begin DoDot:1
+3 IF '$GET(^HLMA(+HLIND1,0))
SET HLIND1=0
+4 IF '$GET(^HL(772,+$PIECE(HLIND1,U,2),0))
SET HLIND1=0
End DoDot:1
+5 ;msg. id is 10th of MSH & 11th for BSH or FSH
+6 SET X=10+($EXTRACT(HLMSG(1,0),1,3)'="MSH")
SET HLMID=$$PMSH(.HLMSG,X)
+7 ;if HLIND1 is set, kill old message, use HLIND1 for new
+8 ;message, it means we never got end block for 1st msg.
+9 IF HLIND1
Begin DoDot:1
+10 ;get pointer to 772, kill header
+11 KILL ^HLMA(+HLIND1,"MSH")
+12 IF $DATA(^HL(772,+$PIECE(HLIND1,U,2),"IN"))
KILL ^("IN")
+13 SET X=$$MAID^HLTF(+HLIND1,HLMID)
+14 DO SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+15 IF $PIECE(HLIND1,U,3)
SET $PIECE(HLIND1,U,3)=""
End DoDot:1
QUIT
+16 DO TCP^HLTF(.HLMID,.X,.HLDT)
+17 IF 'X
Begin DoDot:1
+18 ;error - record and reset array
+19 ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
+20 DO CLEAN
KILL HLLSTN
+21 ;error 100=LLP Could not Enqueue the Message, reset array
+22 DO MONITOR^HLCSDR2(100,19,HLDP)
DO MON^HLCSTCP("ERROR")
HANG 30
End DoDot:1
QUIT
+23 ;HLIND1=ien in 773^ien in 772
+24 SET HLIND1=X_U_+$GET(^HLMA(X,0))
+25 ;save MSH into 773
+26 DO SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+27 QUIT
+28 ;
PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
+1 NEW FS,I,L,L1,L2,X,Y
+2 SET FS=$EXTRACT(MSH(1,0),4)
SET (L2,Y)=0
SET X=""
+3 FOR I=1:1
SET L1=$LENGTH($GET(MSH(I,0)),FS)
SET L=L1+Y-1
Begin DoDot:1
+4 IF L1=1
SET L=L+1
+5 IF P'>L
SET X=$PIECE($GET(MSH(I-1,0)),FS,P-L2)_$PIECE($GET(MSH(I,0)),FS,(P-Y))
+6 SET L2=Y
SET Y=L
End DoDot:1
IF $LENGTH(X)!'$DATA(MSH(I,0))
QUIT
+7 QUIT X
+8 ;
PING ;process PING message
+1 SET X=HLMSG(1,0)
+2 ;switch to null device if opened to prevent 'leakage'
IF X[HLDEND
USE IO
WRITE X,!
IF $GET(IO(0))'=""
IF $GET(IO(0))'=IO
USE IO(0)
+3 ;
CLEAN ;reset var. for next message
+1 KILL HLMSG
+2 SET HLINE=0
SET HLRDOUT=1
+3 QUIT
+4 ;
ERROR ; Error trap for disconnect error and return back to the read loop.
+1 SET $ETRAP="D UNWIND^%ZTER"
+2 IF $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN")
DO UNWIND^%ZTER
QUIT
+3 IF $$EC^%ZOSV["WRITE"
DO CC("Wr-err")
DO UNWIND^%ZTER
QUIT
+4 SET HLCSOUT=1
DO ^%ZTER
DO CC("Error")
+5 DO UNWIND^%ZTER
+6 QUIT
+7 ;
CC(X) ;cleanup and close
+1 DO MON^HLCSTCP(X)
+2 HANG 2
+3 QUIT
RESET ;reset info as a result of no end block
+1 NEW %
+2 SET HLMSG(1,0)=HLMSG(HLINE,0)
+3 FOR %=2:1:HLINE
KILL HLMSG(%,0)
+4 SET HLINE=1
+5 QUIT
