XWBRW ;ISF/RWF - Read/Write for Broker TCP ;09/15/15 06:26
;;1.1;RPC BROKER;**35,49,64**;Mar 28, 1997;Build 12
;Per VA Directive 6402, this routine should not be modified.
Q
;
;XWBRBUF is global
;SE is a flag to skip error for short read. From PRSB+41^XWBBRK
BREAD(L,TO,SE) ;read tcp buffer, L is length, TO is timeout
N R,S,DONE,C,MODE
I L'>0 Q ""
I $L(XWBRBUF)'<L S R=$E(XWBRBUF,1,L),XWBRBUF=$E(XWBRBUF,L+1,999999) Q R
S R="",DONE=0,L=+L,C=0
S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1,MODE=(XWBOS="GT.M")
U XWBTDEV
F D Q:DONE
. S S=L-$L(R),R=R_$E(XWBRBUF,1,S),XWBRBUF=$E(XWBRBUF,S+1,999999)
. I ($L(R)=L)!(R[$C(4))!(C>TO) S DONE=1 Q
. I MODE R XWBRBUF#S:2 S:'$T C=C+1 ;p49
. I 'MODE R XWBRBUF:2 S:'$T C=C+1 ;p49
. S:$L(XWBRBUF) C=0 I $DEVICE S DONE=1 Q ;p49
. I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG("rd: "_$E(XWBRBUF,1,252))
. Q
I $L(R)<L,'$G(SE) S $ECODE=",U411," ;Throw Error, Did not read full length
Q R
;
QSND(XWBR) ;Quick send
S XWBPTYPE=1,XWBERROR="",XWBSEC="" D SND
Q
;
ESND(XWBR) ;Send from ETRAP
S XWBPTYPE=1 D SND
Q
;
SND ; Send a response
N XWBSBUF S XWBSBUF=""
U XWBTDEV
;
D SNDERR ;Send any error info
D SNDDATA ;Send the data
D WRITE($C(4)),WBF
Q
;
SNDDATA ;Send the data part
N I,D
; -- single value
I XWBPTYPE=1 D WRITE($G(XWBR)) Q
; -- table delimited by CR+LF
I XWBPTYPE=2 D Q
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)),WRITE($C(13,10))
; -- word processing
I XWBPTYPE=3 D Q
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)) D:XWBWRAP WRITE($C(13,10))
; -- global array
I XWBPTYPE=4 D Q
. I $E($G(XWBR))'="^" Q
. S I=$G(XWBR) Q:I="" S T=$E(I,1,$L(I)-1)
. ;Only send root node if non-null.
. I $D(@I)>10 S D=@I I $L(D) D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
. F S I=$Q(@I) Q:I=""!(I'[T) S D=@I D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
. I $D(@XWBR),XWBR'["^XTMP(" K @XWBR ;p64
; -- global instance
I XWBPTYPE=5 D Q
. I $E($G(XWBR))'="^" Q
. S XWBR=$G(@XWBR) D WRITE(XWBR) Q
; -- variable length records only good upto 255 char)
I XWBPTYPE=6 D
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE($C($L(XWBR(I)))),WRITE(XWBR(I))
Q
;
SNDERR ;send error information
;XWBSEC is the security packet, XWBERROR is application packet
N X
S $X=0 ;Start with zero
S X=$E($G(XWBSEC),1,255)
D WRITE($C($L(X))_X)
S X=$E($G(XWBERROR),1,255)
D WRITE($C($L(X))_X)
S XWBERROR="",XWBSEC="" ;clears parameters
Q
;
WRITE(STR) ;Write a data string
; send data for DSM (requires buffer flush (!) every 511 chars)
;IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM) next line
N MAX S MAX=255 ;p49
F Q:'$L(STR) D
. I $L(XWBSBUF)+$L(STR)>MAX D WBF
. S XWBSBUF=XWBSBUF_$E(STR,1,MAX),STR=$E(STR,MAX+1,99999) ;p49
Q
WBF ;Write Buffer Flush
Q:'$L(XWBSBUF)
I $G(XWBDEBUG)>2,$L(XWBSBUF) D LOG^XWBDLOG("wrt ("_$L(XWBSBUF)_"): "_$E(XWBSBUF,1,247))
W XWBSBUF,@XWBT("BF")
S XWBSBUF=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBRW 3004 printed Dec 13, 2024@02:37:25 Page 2
XWBRW ;ISF/RWF - Read/Write for Broker TCP ;09/15/15 06:26
+1 ;;1.1;RPC BROKER;**35,49,64**;Mar 28, 1997;Build 12
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;XWBRBUF is global
+6 ;SE is a flag to skip error for short read. From PRSB+41^XWBBRK
BREAD(L,TO,SE) ;read tcp buffer, L is length, TO is timeout
+1 NEW R,S,DONE,C,MODE
+2 IF L'>0
QUIT ""
+3 IF $LENGTH(XWBRBUF)'<L
SET R=$EXTRACT(XWBRBUF,1,L)
SET XWBRBUF=$EXTRACT(XWBRBUF,L+1,999999)
QUIT R
+4 SET R=""
SET DONE=0
SET L=+L
SET C=0
+5 SET TO=$SELECT($GET(TO)>0:TO,$GET(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
SET MODE=(XWBOS="GT.M")
+6 USE XWBTDEV
+7 FOR
Begin DoDot:1
+8 SET S=L-$LENGTH(R)
SET R=R_$EXTRACT(XWBRBUF,1,S)
SET XWBRBUF=$EXTRACT(XWBRBUF,S+1,999999)
+9 IF ($LENGTH(R)=L)!(R[$CHAR(4))!(C>TO)
SET DONE=1
QUIT
+10 ;p49
IF MODE
READ XWBRBUF#S:2
if '$TEST
SET C=C+1
+11 ;p49
IF 'MODE
READ XWBRBUF:2
if '$TEST
SET C=C+1
+12 ;p49
if $LENGTH(XWBRBUF)
SET C=0
IF $DEVICE
SET DONE=1
QUIT
+13 IF $GET(XWBDEBUG)>2
IF $LENGTH(XWBRBUF)
DO LOG^XWBDLOG("rd: "_$EXTRACT(XWBRBUF,1,252))
+14 QUIT
End DoDot:1
if DONE
QUIT
+15 ;Throw Error, Did not read full length
IF $LENGTH(R)<L
IF '$GET(SE)
SET $ECODE=",U411,"
+16 QUIT R
+17 ;
QSND(XWBR) ;Quick send
+1 SET XWBPTYPE=1
SET XWBERROR=""
SET XWBSEC=""
DO SND
+2 QUIT
+3 ;
ESND(XWBR) ;Send from ETRAP
+1 SET XWBPTYPE=1
DO SND
+2 QUIT
+3 ;
SND ; Send a response
+1 NEW XWBSBUF
SET XWBSBUF=""
+2 USE XWBTDEV
+3 ;
+4 ;Send any error info
DO SNDERR
+5 ;Send the data
DO SNDDATA
+6 DO WRITE($CHAR(4))
DO WBF
+7 QUIT
+8 ;
SNDDATA ;Send the data part
+1 NEW I,D
+2 ; -- single value
+3 IF XWBPTYPE=1
DO WRITE($GET(XWBR))
QUIT
+4 ; -- table delimited by CR+LF
+5 IF XWBPTYPE=2
Begin DoDot:1
+6 SET I=""
FOR
SET I=$ORDER(XWBR(I))
if I=""
QUIT
DO WRITE(XWBR(I))
DO WRITE($CHAR(13,10))
End DoDot:1
QUIT
+7 ; -- word processing
+8 IF XWBPTYPE=3
Begin DoDot:1
+9 SET I=""
FOR
SET I=$ORDER(XWBR(I))
if I=""
QUIT
DO WRITE(XWBR(I))
if XWBWRAP
DO WRITE($CHAR(13,10))
End DoDot:1
QUIT
+10 ; -- global array
+11 IF XWBPTYPE=4
Begin DoDot:1
+12 IF $EXTRACT($GET(XWBR))'="^"
QUIT
+13 SET I=$GET(XWBR)
if I=""
QUIT
SET T=$EXTRACT(I,1,$LENGTH(I)-1)
+14 ;Only send root node if non-null.
+15 IF $DATA(@I)>10
SET D=@I
IF $LENGTH(D)
DO WRITE(D)
if XWBWRAP&(D'=$CHAR(13,10))
DO WRITE($CHAR(13,10))
+16 FOR
SET I=$QUERY(@I)
if I=""!(I'[T)
QUIT
SET D=@I
DO WRITE(D)
if XWBWRAP&(D'=$CHAR(13,10))
DO WRITE($CHAR(13,10))
+17 ;p64
IF $DATA(@XWBR)
IF XWBR'["^XTMP("
KILL @XWBR
End DoDot:1
QUIT
+18 ; -- global instance
+19 IF XWBPTYPE=5
Begin DoDot:1
+20 IF $EXTRACT($GET(XWBR))'="^"
QUIT
+21 SET XWBR=$GET(@XWBR)
DO WRITE(XWBR)
QUIT
End DoDot:1
QUIT
+22 ; -- variable length records only good upto 255 char)
+23 IF XWBPTYPE=6
Begin DoDot:1
+24 SET I=""
FOR
SET I=$ORDER(XWBR(I))
if I=""
QUIT
DO WRITE($CHAR($LENGTH(XWBR(I))))
DO WRITE(XWBR(I))
End DoDot:1
+25 QUIT
+26 ;
SNDERR ;send error information
+1 ;XWBSEC is the security packet, XWBERROR is application packet
+2 NEW X
+3 ;Start with zero
SET $X=0
+4 SET X=$EXTRACT($GET(XWBSEC),1,255)
+5 DO WRITE($CHAR($LENGTH(X))_X)
+6 SET X=$EXTRACT($GET(XWBERROR),1,255)
+7 DO WRITE($CHAR($LENGTH(X))_X)
+8 ;clears parameters
SET XWBERROR=""
SET XWBSEC=""
+9 QUIT
+10 ;
WRITE(STR) ;Write a data string
+1 ; send data for DSM (requires buffer flush (!) every 511 chars)
+2 ;IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM) next line
+3 ;p49
NEW MAX
SET MAX=255
+4 FOR
if '$LENGTH(STR)
QUIT
Begin DoDot:1
+5 IF $LENGTH(XWBSBUF)+$LENGTH(STR)>MAX
DO WBF
+6 ;p49
SET XWBSBUF=XWBSBUF_$EXTRACT(STR,1,MAX)
SET STR=$EXTRACT(STR,MAX+1,99999)
End DoDot:1
+7 QUIT
WBF ;Write Buffer Flush
+1 if '$LENGTH(XWBSBUF)
QUIT
+2 IF $GET(XWBDEBUG)>2
IF $LENGTH(XWBSBUF)
DO LOG^XWBDLOG("wrt ("_$LENGTH(XWBSBUF)_"): "_$EXTRACT(XWBSBUF,1,247))
+3 WRITE XWBSBUF,@XWBT("BF")
+4 SET XWBSBUF=""
+5 QUIT
