HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;07/08/2009 15:27
;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122,140,142,145,165**;OCT 13,1995;Build 2
;;Per VA Directive 6402, 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
;
; patch HL*1.6*140, save IO
S HLTCPORT("IO")=IO ;RWF
; patch HL*1.6*122 start
; variable to replace ^TMP
N HLTMBUF
;
; for HL7 application proxy user
;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed
N HLDUZ
S HLDUZ=+$G(DUZ)
;
D MON^HLCSTCP("Open")
; K ^TMP("HLCSTCP",$J,0)
S HLMIEN=0,HLASTMSG=""
;
; patch HL*1.6*122 TEST v2: DUZ code removed
; set DUZ for application proxy user
;; D PROXY^HLCSTCP4
;
F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3
. ; clean variables
. D CLEANVAR^HLCSTCP4
. ; patch HL*1.6*140, restore the saved IO
. S IO=HLTCPORT("IO") ;RWF
. S HLMIEN=$$READ
. Q:'HLMIEN
. ;
. ; patch HL*1.6*122 TEST v2: DUZ code removed
. ; DUZ comparison/reset for application proxy user
. ;; D HLDUZ^HLCSTCP4
. D HLDUZ2^HLCSTCP4
. ; protect HLDUZ
. N HLDUZ
. D PROCESS
; patch HL*1.6*122 end
Q
;
PROCESS ;check message and reply
;HLDP=LL in 870
N HLTCP,HLTCPI,HLTCPO
S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
; patch HL*1.6*145 start
; variable HLDP("HLLINK") will be used as the client link ien,
; in which the incoming original messages received by listener
; will be stored and the messages in the client link queue will
; be processed by incoming filer.
; variable HLDP("SETINQUE")=1 to indicate the x-ref
; ^HLMA("AC","I",<ien of link>,<ien of message>) is set.
; initilizes to 0.
S HLDP("HLLINK")=0
S HLDP("SETINQUE")=0
; patch HL*1.6*145 end
;
;update monitor, msg. received
D LLCNT^HLCSTCP(HLDP,1)
D NEW^HLTP3(HLMIEN)
;
; patch HL*1.6*145 start
; quit if x-ref ^HLMA("AC","I",<ien of link>,<ien of message>)
; was set, and counter will be incrmented later after message
; being processed.
Q:HLDP("SETINQUE")
;update monitor, msg. processed
I HLDP("HLLINK") D LLCNT^HLCSTCP(HLDP("HLLINK"),2) Q
D LLCNT^HLCSTCP(HLDP,2)
; patch HL*1.6*145 end
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 separator
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, HLTMBUF()=excess from last read, HLACKWT=wait for ack
; HL*1.6*122 start
; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK
N HLBUFF,HLXX,MAXWAIT
; based on patch 132 for readtime
S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD)
S HLRS("START-FLAG")=0
S HLTMBUF(0)=""
; variable used to store data in HLBUFF
S HLX(1)=$G(HLTMBUF(1))
S HLTMBUF(1)=""
S HLBUFF("START")=0
S HLBUFF("END")=0
I (HLX]"")!(HLX(1)]"") D
. I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D
.. S HLBUFF("START")=1
. I (HLX[HLDEND)!(HLX(1)[HLDEND) D
.. S HLBUFF("END")=1
F D RDBLK Q:HLRDOUT
;**132**
;switch to null device if opened to prevent 'leakage'
I $G(IO(0))]"",IO(0)'=IO U IO(0)
;
;save any excess for next time
S:HLX]"" HLTMBUF(0)=HLX
S:HLX(1)]"" HLTMBUF(1)=HLX(1)
I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
Q HLIND1
;
RDBLK ;
; initialize
S HLBUFF=""
;
;S HLDB=HLDBSIZE-$L(HLX)
; store the total length of HLX and HLX(1) in HLDB(1)
S HLDB(1)=$L(HLX)+$L(HLX(1))
;
;**132 **
;U IO R X#HLDB:HLDREAD
; U IO R X#HLDB:MAXWAIT
;
; remove the readcount to speedup GT.M
U IO
R:(HLDB(1)<HLDBSIZE) HLBUFF:MAXWAIT
;
I HLBUFF]"" D
. I HLBUFF[HLDSTRT,(HLBUFF("START")=0) D
.. ; remove the extraneous text prefixing the "START" char
.. I $P(HLBUFF,HLDSTRT)]"" S HLBUFF=HLDSTRT_$P(HLBUFF,HLDSTRT,2,99)
.. S HLBUFF("START")=1
. ;
. I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1
; detect disconnect for GT.M
I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=",UREAD,"
; timedout, <clean up>, quit
;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
;I '$T,X="",HLX="" D:'HLHDR CLEAN Q
; patch HL*1.6*140
; I '$T,HLBUFF="",HLX="",HLX(1)="" D Q
I HLBUFF="",HLX="",HLX(1)="" D Q
. D:('HLHDR)&('HLIND1) CLEAN
;add incoming line to what wasn't processed in last read
;S HLX=$G(HLX)_X
; get block of characters from read buffer HLBUFF
; every 'for-loop' deal with one read at most, and one message at most
; if HLX is not empty, loop continues even no data is read
; quit, if both HLDBUFF and HLX(1) are empty, means one read is done
; quit, when HLRDOUT is set to 1, means one message is encountered
; an "end"
; F D Q:HLXX=""!(HLRDOUT)
F D Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)=""))
. ;
. ; if HLX(1) is not empty
. I HLX(1)]"" D
.. ; hldb(2) is the number of characters extracted from hlx(1)
.. ; to be concatenated with hlx
.. S HLDB(2)=HLDBSIZE-$L(HLX)
.. ; hlx(2) stores the first hldb(2) characters extracted
.. ; from hlx(1)
.. S HLX(2)=$E(HLX(1),1,HLDB(2))
.. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1)))
.. S HLX=$G(HLX)_HLX(2)
. ;
. ; if HLX(1) is empty, and HLBUFF contains data
. ; all the data in hlx(1) need to be extracted first
. I HLX(1)="",HLBUFF]"" D
.. S HLDB=HLDBSIZE-$L(HLX)
.. S HLXX=$E(HLBUFF,1,HLDB)
.. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF))
.. S HLX=$G(HLX)_HLXX
. ; quit when HLX is empty
. Q:(HLX="")
. ; ** 132 **
. ; if no segment end, HLX not full, go back for more
. I $L(HLX)<HLDBSIZE,HLX'[HLRS,HLX'[HLDEND Q
. ;add incoming line to what wasn't processed
. D RDBLK2
;
; it is possible one message is encountered an "end" and other
; messages left in buffer,HLBUFF, save it in HLX for next run
I HLBUFF]"" D
. ; variable HLBUFF may remain data with size more than HLDBSIZE
. ; variable HLBUFF is not empty, only if the total length of
. ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be
. ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed
. ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error
. S HLX(1)=$G(HLX(1))_HLBUFF
. S HLBUFF=""
Q
;
RDBLK2 ;data stream: <sb>dddd<cr><eb><cr>
; HL*1.6*122 end
; 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
.. S HLRS("START-FLAG")=1 ; HL*1.6*122
.. 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)
.. ;
.. ; patch HL*1.6*122
.. ; if the first line less than 10 characters
.. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D
... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10)
... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999)
.. ;
.. ;ping message
.. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
.. ; get next ien to store
.. D MIEN^HLCSTCP4
.. K HLMSG
.. S (HLINE,HLHDR)=0
. ; check for end block; <eb><cr>
. I HLMSG(HLINE,0)[HLDEND D
.. ; patch HL*1.6*122 start
.. ;no msg. ien
.. ; Q:'HLIND1
.. I 'HLIND1 D CLEAN Q
.. ; Kill just the last line if no data before HLDEND
.. I $P(HLMSG(HLINE,0),HLDEND)']"" D
... K HLMSG(HLINE,0) S HLINE=HLINE-1
.. E S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND)
.. ; patch HL*1.6*122 end
.. ;
.. ; 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
.. S HLBUFF("HLIND1")=HLIND1
.. ;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 separator
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)
. ;
. ; patch HL*1.6*122
. ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
. S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
. ;
. D RESET:(HLHDR&(HLINE>1))
;if no ien, reset
; patch HL*1.6*122
; I 'HLIND1 D CLEAN Q
I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q
;HL*1.6*165
;if ENDBLOCK without ien reset
I HLX[HLDEND,'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
;
; patch HL*1.6*122: MPI-client/server
I DEST["HLMA" D
. F L +^HLMA(+HLIND1):10 Q:$T H 1
E D
. F L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T H 1
;
M @DEST=SRC
S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
;
I DEST["HLMA" L -^HLMA(+HLIND1)
E L -^HL(772,+$P(HLIND1,U,2))
;
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
PING ;process PING message
S X=HLMSG(1,0)
; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
; I X[HLDEND U IO W X,! D
; I X[HLDEND U IO W X,HLTCPLNK("IOF") D
; patch HL*1.6*142
I X[HLDEND U IO W X,@HLTCPLNK("IOF") D
. ; switch to null device if opened to prevent 'leakage'
. I $G(IO(0))]"",$G(IO(0))'=IO U IO(0)
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.
; patch HL*1.6*122
; move to routine HLCSTCP4 (splitted-size over 10000)
D ERROR1^HLCSTCP4
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSTCP1 10531 printed Dec 13, 2024@01:57:06 Page 2
HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;07/08/2009 15:27
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122,140,142,145,165**;OCT 13,1995;Build 2
+2 ;;Per VA Directive 6402, 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 ;
+10 ; patch HL*1.6*140, save IO
+11 ;RWF
SET HLTCPORT("IO")=IO
+12 ; patch HL*1.6*122 start
+13 ; variable to replace ^TMP
+14 NEW HLTMBUF
+15 ;
+16 ; for HL7 application proxy user
+17 ;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed
+18 NEW HLDUZ
+19 SET HLDUZ=+$GET(DUZ)
+20 ;
+21 DO MON^HLCSTCP("Open")
+22 ; K ^TMP("HLCSTCP",$J,0)
+23 SET HLMIEN=0
SET HLASTMSG=""
+24 ;
+25 ; patch HL*1.6*122 TEST v2: DUZ code removed
+26 ; set DUZ for application proxy user
+27 ;; D PROXY^HLCSTCP4
+28 ;
+29 FOR
Begin DoDot:1
+30 ; clean variables
+31 DO CLEANVAR^HLCSTCP4
+32 ; patch HL*1.6*140, restore the saved IO
+33 ;RWF
SET IO=HLTCPORT("IO")
+34 SET HLMIEN=$$READ
+35 if 'HLMIEN
QUIT
+36 ;
+37 ; patch HL*1.6*122 TEST v2: DUZ code removed
+38 ; DUZ comparison/reset for application proxy user
+39 ;; D HLDUZ^HLCSTCP4
+40 DO HLDUZ2^HLCSTCP4
+41 ; protect HLDUZ
+42 NEW HLDUZ
+43 DO PROCESS
End DoDot:1
if $$STOP^HLCSTCP
QUIT
IF 'HLMIEN
DO MON^HLCSTCP("Idle")
HANG 3
+44 ; patch HL*1.6*122 end
+45 QUIT
+46 ;
PROCESS ;check message and reply
+1 ;HLDP=LL in 870
+2 NEW HLTCP,HLTCPI,HLTCPO
+3 SET HLTCP=""
SET HLTCPO=HLDP
SET HLTCPI=+HLMIEN
+4 ; patch HL*1.6*145 start
+5 ; variable HLDP("HLLINK") will be used as the client link ien,
+6 ; in which the incoming original messages received by listener
+7 ; will be stored and the messages in the client link queue will
+8 ; be processed by incoming filer.
+9 ; variable HLDP("SETINQUE")=1 to indicate the x-ref
+10 ; ^HLMA("AC","I",<ien of link>,<ien of message>) is set.
+11 ; initilizes to 0.
+12 SET HLDP("HLLINK")=0
+13 SET HLDP("SETINQUE")=0
+14 ; patch HL*1.6*145 end
+15 ;
+16 ;update monitor, msg. received
+17 DO LLCNT^HLCSTCP(HLDP,1)
+18 DO NEW^HLTP3(HLMIEN)
+19 ;
+20 ; patch HL*1.6*145 start
+21 ; quit if x-ref ^HLMA("AC","I",<ien of link>,<ien of message>)
+22 ; was set, and counter will be incrmented later after message
+23 ; being processed.
+24 if HLDP("SETINQUE")
QUIT
+25 ;update monitor, msg. processed
+26 IF HLDP("HLLINK")
DO LLCNT^HLCSTCP(HLDP("HLLINK"),2)
QUIT
+27 DO LLCNT^HLCSTCP(HLDP,2)
+28 ; patch HL*1.6*145 end
+29 QUIT
+30 ;
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 separator
+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, HLTMBUF()=excess from last read, HLACKWT=wait for ack
+7 ; HL*1.6*122 start
+8 ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
+9 SET (HLRDOUT,HLINE,HLIND1,HLHDR)=0
SET HLX=$GET(HLTMBUF(0))
SET HLACKWT=HLDBACK
+10 NEW HLBUFF,HLXX,MAXWAIT
+11 ; based on patch 132 for readtime
+12 SET MAXWAIT=$SELECT((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD)
+13 SET HLRS("START-FLAG")=0
+14 SET HLTMBUF(0)=""
+15 ; variable used to store data in HLBUFF
+16 SET HLX(1)=$GET(HLTMBUF(1))
+17 SET HLTMBUF(1)=""
+18 SET HLBUFF("START")=0
+19 SET HLBUFF("END")=0
+20 IF (HLX]"")!(HLX(1)]"")
Begin DoDot:1
+21 IF (HLX[HLDSTRT)!(HLX(1)[HLDSTRT)
Begin DoDot:2
+22 SET HLBUFF("START")=1
End DoDot:2
+23 IF (HLX[HLDEND)!(HLX(1)[HLDEND)
Begin DoDot:2
+24 SET HLBUFF("END")=1
End DoDot:2
End DoDot:1
+25 FOR
DO RDBLK
if HLRDOUT
QUIT
+26 ;**132**
+27 ;switch to null device if opened to prevent 'leakage'
+28 IF $GET(IO(0))]""
IF IO(0)'=IO
USE IO(0)
+29 ;
+30 ;save any excess for next time
+31 if HLX]""
SET HLTMBUF(0)=HLX
+32 if HLX(1)]""
SET HLTMBUF(1)=HLX(1)
+33 IF +HLIND1
IF '$PIECE(HLIND1,U,3)
DO DELMSG(HLIND1)
SET HLIND1=0
+34 QUIT HLIND1
+35 ;
RDBLK ;
+1 ; initialize
+2 SET HLBUFF=""
+3 ;
+4 ;S HLDB=HLDBSIZE-$L(HLX)
+5 ; store the total length of HLX and HLX(1) in HLDB(1)
+6 SET HLDB(1)=$LENGTH(HLX)+$LENGTH(HLX(1))
+7 ;
+8 ;**132 **
+9 ;U IO R X#HLDB:HLDREAD
+10 ; U IO R X#HLDB:MAXWAIT
+11 ;
+12 ; remove the readcount to speedup GT.M
+13 USE IO
+14 if (HLDB(1)<HLDBSIZE)
READ HLBUFF:MAXWAIT
+15 ;
+16 IF HLBUFF]""
Begin DoDot:1
+17 IF HLBUFF[HLDSTRT
IF (HLBUFF("START")=0)
Begin DoDot:2
+18 ; remove the extraneous text prefixing the "START" char
+19 IF $PIECE(HLBUFF,HLDSTRT)]""
SET HLBUFF=HLDSTRT_$PIECE(HLBUFF,HLDSTRT,2,99)
+20 SET HLBUFF("START")=1
End DoDot:2
+21 ;
+22 IF HLBUFF[HLDEND
IF (HLBUFF("END")=0)
SET HLBUFF("END")=1
End DoDot:1
+23 ; detect disconnect for GT.M
+24 IF $GET(^%ZOSF("OS"))["GT.M"
IF $DEVICE
SET $ECODE=",UREAD,"
+25 ; timedout, <clean up>, quit
+26 ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
+27 ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q
+28 ; patch HL*1.6*140
+29 ; I '$T,HLBUFF="",HLX="",HLX(1)="" D Q
+30 IF HLBUFF=""
IF HLX=""
IF HLX(1)=""
Begin DoDot:1
+31 if ('HLHDR)&('HLIND1)
DO CLEAN
End DoDot:1
QUIT
+32 ;add incoming line to what wasn't processed in last read
+33 ;S HLX=$G(HLX)_X
+34 ; get block of characters from read buffer HLBUFF
+35 ; every 'for-loop' deal with one read at most, and one message at most
+36 ; if HLX is not empty, loop continues even no data is read
+37 ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done
+38 ; quit, when HLRDOUT is set to 1, means one message is encountered
+39 ; an "end"
+40 ; F D Q:HLXX=""!(HLRDOUT)
+41 FOR
Begin DoDot:1
+42 ;
+43 ; if HLX(1) is not empty
+44 IF HLX(1)]""
Begin DoDot:2
+45 ; hldb(2) is the number of characters extracted from hlx(1)
+46 ; to be concatenated with hlx
+47 SET HLDB(2)=HLDBSIZE-$LENGTH(HLX)
+48 ; hlx(2) stores the first hldb(2) characters extracted
+49 ; from hlx(1)
+50 SET HLX(2)=$EXTRACT(HLX(1),1,HLDB(2))
+51 SET HLX(1)=$EXTRACT(HLX(1),HLDB(2)+1,$LENGTH(HLX(1)))
+52 SET HLX=$GET(HLX)_HLX(2)
End DoDot:2
+53 ;
+54 ; if HLX(1) is empty, and HLBUFF contains data
+55 ; all the data in hlx(1) need to be extracted first
+56 IF HLX(1)=""
IF HLBUFF]""
Begin DoDot:2
+57 SET HLDB=HLDBSIZE-$LENGTH(HLX)
+58 SET HLXX=$EXTRACT(HLBUFF,1,HLDB)
+59 SET HLBUFF=$EXTRACT(HLBUFF,HLDB+1,$LENGTH(HLBUFF))
+60 SET HLX=$GET(HLX)_HLXX
End DoDot:2
+61 ; quit when HLX is empty
+62 if (HLX="")
QUIT
+63 ; ** 132 **
+64 ; if no segment end, HLX not full, go back for more
+65 IF $LENGTH(HLX)<HLDBSIZE
IF HLX'[HLRS
IF HLX'[HLDEND
QUIT
+66 ;add incoming line to what wasn't processed
+67 DO RDBLK2
End DoDot:1
if (HLRDOUT)!(HLBUFF=""&(HLX(1)=""))
QUIT
+68 ;
+69 ; it is possible one message is encountered an "end" and other
+70 ; messages left in buffer,HLBUFF, save it in HLX for next run
+71 IF HLBUFF]""
Begin DoDot:1
+72 ; variable HLBUFF may remain data with size more than HLDBSIZE
+73 ; variable HLBUFF is not empty, only if the total length of
+74 ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be
+75 ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed
+76 ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error
+77 SET HLX(1)=$GET(HLX(1))_HLBUFF
+78 SET HLBUFF=""
End DoDot:1
+79 QUIT
+80 ;
RDBLK2 ;data stream: <sb>dddd<cr><eb><cr>
+1 ; HL*1.6*122 end
+2 ; look for segment= <CR>
+3 FOR
if HLX'[HLRS
QUIT
Begin DoDot:1
+4 ; Get the first piece, save the rest of the line
+5 SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=$PIECE(HLX,HLRS)
SET HLX=$PIECE(HLX,HLRS,2,999)
+6 ; check for start block, Quit if no ien
+7 IF HLMSG(HLINE,0)[HLDSTRT!HLHDR
Begin DoDot:2
+8 ; HL*1.6*122
SET HLRS("START-FLAG")=1
+9 if HLMSG(HLINE,0)[HLDSTRT
Begin DoDot:3
+10 SET X=$LENGTH(HLMSG(HLINE,0),HLDSTRT)
+11 if X>2
SET HLMSG(HLINE,0)=HLDSTRT_$PIECE(HLMSG(HLINE,0),HLDSTRT,X)
+12 SET HLMSG(HLINE,0)=$PIECE(HLMSG(HLINE,0),HLDSTRT,2)
+13 if (HLINE>1)
DO RESET
End DoDot:3
+14 ;
+15 ; patch HL*1.6*122
+16 ; if the first line less than 10 characters
+17 IF HLHDR
IF $LENGTH(HLMSG(1,0))<10
IF $DATA(HLMSG(2,0))
Begin DoDot:3
+18 SET HLMSG(1,0)=HLMSG(1,0)_$EXTRACT(HLMSG(2,0),1,10)
+19 SET HLMSG(2,0)=$EXTRACT(HLMSG(2,0),11,9999999)
End DoDot:3
+20 ;
+21 ;ping message
+22 IF $EXTRACT(HLMSG(1,0),1,9)="MSH^PING^"
DO PING
QUIT
+23 ; get next ien to store
+24 DO MIEN^HLCSTCP4
+25 KILL HLMSG
+26 SET (HLINE,HLHDR)=0
End DoDot:2
QUIT
+27 ; check for end block; <eb><cr>
+28 IF HLMSG(HLINE,0)[HLDEND
Begin DoDot:2
+29 ; patch HL*1.6*122 start
+30 ;no msg. ien
+31 ; Q:'HLIND1
+32 IF 'HLIND1
DO CLEAN
QUIT
+33 ; Kill just the last line if no data before HLDEND
+34 IF $PIECE(HLMSG(HLINE,0),HLDEND)']""
Begin DoDot:3
+35 KILL HLMSG(HLINE,0)
SET HLINE=HLINE-1
End DoDot:3
+36 IF '$TEST
SET HLMSG(HLINE,0)=$PIECE(HLMSG(HLINE,0),HLDEND)
+37 ; patch HL*1.6*122 end
+38 ;
+39 ; move into 772
+40 DO SAVE(.HLMSG,"^HL(772,"_+$PIECE(HLIND1,U,2)_",""IN"")")
+41 ;mark that end block has been received
+42 ;HLIND1=ien in 773^ien in 772^1 if end block was received
+43 SET $PIECE(HLIND1,U,3)=1
+44 SET HLBUFF("HLIND1")=HLIND1
+45 ;reset variables for next message
+46 DO CLEAN
End DoDot:2
+47 ;add blank line for carriage return
+48 IF HLINE'=0
IF HLMSG(HLINE,0)]""
SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=""
End DoDot:1
if HLRDOUT
QUIT
+49 if HLRDOUT
QUIT
+50 ;If the line is long and no <CR> move it into the array.
+51 IF ($LENGTH(HLX)=HLDBSIZE)
IF (HLX'[HLRS)
IF (HLX'[HLDEND)
IF (HLX'[HLDSTRT)
Begin DoDot:1
+52 SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=HLX
SET HLX=""
End DoDot:1
QUIT
+53 ;have start block but no record separator
+54 IF HLX[HLDSTRT
Begin DoDot:1
+55 ;check for more than 1 start block
+56 SET X=$LENGTH(HLX,HLDSTRT)
if X>2
SET HLX=HLDSTRT_$PIECE(HLX,HLDSTRT,X)
+57 ;
+58 ; patch HL*1.6*122
+59 ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+60 SET HLINE=HLINE+1
SET HLMSG(HLINE,0)=$PIECE(HLX,HLDSTRT,2)
SET HLX=""
SET HLHDR=1
+61 ;
+62 if (HLHDR&(HLINE>1))
DO RESET
End DoDot:1
QUIT
+63 ;if no ien, reset
+64 ; patch HL*1.6*122
+65 ; I 'HLIND1 D CLEAN Q
+66 IF (HLRS("START-FLAG")=1)
IF 'HLIND1
DO CLEAN
QUIT
+67 ;HL*1.6*165
+68 ;if ENDBLOCK without ien reset
+69 IF HLX[HLDEND
IF 'HLIND1
DO CLEAN
QUIT
+70 ; big message-merge from local to global every 100 lines
+71 IF (HLINE-$ORDER(HLMSG(0)))>100
Begin DoDot:1
+72 MERGE ^HL(772,+$PIECE(HLIND1,U,2),"IN")=HLMSG
+73 ; reset working array
+74 KILL HLMSG
End DoDot:1
+75 QUIT
+76 ;
SAVE(SRC,DEST) ;save into global & set top node
+1 ;SRC=source array (passed by ref.), DEST=destination global
+2 ;
+3 ; patch HL*1.6*122: MPI-client/server
+4 IF DEST["HLMA"
Begin DoDot:1
+5 FOR
LOCK +^HLMA(+HLIND1):10
if $TEST
QUIT
HANG 1
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 FOR
LOCK +^HL(772,+$PIECE(HLIND1,U,2)):10
if $TEST
QUIT
HANG 1
End DoDot:1
+8 ;
+9 MERGE @DEST=SRC
+10 SET @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
+11 ;
+12 IF DEST["HLMA"
LOCK -^HLMA(+HLIND1)
+13 IF '$TEST
LOCK -^HL(772,+$PIECE(HLIND1,U,2))
+14 ;
+15 QUIT
+16 ;
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
PING ;process PING message
+1 SET X=HLMSG(1,0)
+2 ; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
+3 ; I X[HLDEND U IO W X,! D
+4 ; I X[HLDEND U IO W X,HLTCPLNK("IOF") D
+5 ; patch HL*1.6*142
+6 IF X[HLDEND
USE IO
WRITE X,@HLTCPLNK("IOF")
Begin DoDot:1
+7 ; switch to null device if opened to prevent 'leakage'
+8 IF $GET(IO(0))]""
IF $GET(IO(0))'=IO
USE IO(0)
End DoDot:1
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 ; patch HL*1.6*122
+2 ; move to routine HLCSTCP4 (splitted-size over 10000)
+3 DO ERROR1^HLCSTCP4
+4 QUIT
+5 ;
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
