- 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 Jan 18, 2025@03:38:32 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