Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XWBRW

XWBRW.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. ;XWBRBUF is global
  1. ;SE is a flag to skip error for short read. From PRSB+41^XWBBRK
  1. BREAD(L,TO,SE) ;read tcp buffer, L is length, TO is timeout
  1. N R,S,DONE,C,MODE
  1. I L'>0 Q ""
  1. I $L(XWBRBUF)'<L S R=$E(XWBRBUF,1,L),XWBRBUF=$E(XWBRBUF,L+1,999999) Q R
  1. S R="",DONE=0,L=+L,C=0
  1. S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1,MODE=(XWBOS="GT.M")
  1. U XWBTDEV
  1. F D Q:DONE
  1. . S S=L-$L(R),R=R_$E(XWBRBUF,1,S),XWBRBUF=$E(XWBRBUF,S+1,999999)
  1. . I ($L(R)=L)!(R[$C(4))!(C>TO) S DONE=1 Q
  1. . I MODE R XWBRBUF#S:2 S:'$T C=C+1 ;p49
  1. . I 'MODE R XWBRBUF:2 S:'$T C=C+1 ;p49
  1. . S:$L(XWBRBUF) C=0 I $DEVICE S DONE=1 Q ;p49
  1. . I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG("rd: "_$E(XWBRBUF,1,252))
  1. . Q
  1. I $L(R)<L,'$G(SE) S $ECODE=",U411," ;Throw Error, Did not read full length
  1. Q R
  1. ;
  1. QSND(XWBR) ;Quick send
  1. S XWBPTYPE=1,XWBERROR="",XWBSEC="" D SND
  1. Q
  1. ;
  1. ESND(XWBR) ;Send from ETRAP
  1. S XWBPTYPE=1 D SND
  1. Q
  1. ;
  1. SND ; Send a response
  1. N XWBSBUF S XWBSBUF=""
  1. U XWBTDEV
  1. ;
  1. D SNDERR ;Send any error info
  1. D SNDDATA ;Send the data
  1. D WRITE($C(4)),WBF
  1. Q
  1. ;
  1. SNDDATA ;Send the data part
  1. N I,D
  1. ; -- single value
  1. I XWBPTYPE=1 D WRITE($G(XWBR)) Q
  1. ; -- table delimited by CR+LF
  1. I XWBPTYPE=2 D Q
  1. . S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)),WRITE($C(13,10))
  1. ; -- word processing
  1. I XWBPTYPE=3 D Q
  1. . S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)) D:XWBWRAP WRITE($C(13,10))
  1. ; -- global array
  1. I XWBPTYPE=4 D Q
  1. . I $E($G(XWBR))'="^" Q
  1. . S I=$G(XWBR) Q:I="" S T=$E(I,1,$L(I)-1)
  1. . ;Only send root node if non-null.
  1. . I $D(@I)>10 S D=@I I $L(D) D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
  1. . F S I=$Q(@I) Q:I=""!(I'[T) S D=@I D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
  1. . I $D(@XWBR),XWBR'["^XTMP(" K @XWBR ;p64
  1. ; -- global instance
  1. I XWBPTYPE=5 D Q
  1. . I $E($G(XWBR))'="^" Q
  1. . S XWBR=$G(@XWBR) D WRITE(XWBR) Q
  1. ; -- variable length records only good upto 255 char)
  1. I XWBPTYPE=6 D
  1. . S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE($C($L(XWBR(I)))),WRITE(XWBR(I))
  1. Q
  1. ;
  1. SNDERR ;send error information
  1. ;XWBSEC is the security packet, XWBERROR is application packet
  1. N X
  1. S $X=0 ;Start with zero
  1. S X=$E($G(XWBSEC),1,255)
  1. D WRITE($C($L(X))_X)
  1. S X=$E($G(XWBERROR),1,255)
  1. D WRITE($C($L(X))_X)
  1. S XWBERROR="",XWBSEC="" ;clears parameters
  1. Q
  1. ;
  1. WRITE(STR) ;Write a data string
  1. ; send data for DSM (requires buffer flush (!) every 511 chars)
  1. ;IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM) next line
  1. N MAX S MAX=255 ;p49
  1. F Q:'$L(STR) D
  1. . I $L(XWBSBUF)+$L(STR)>MAX D WBF
  1. . S XWBSBUF=XWBSBUF_$E(STR,1,MAX),STR=$E(STR,MAX+1,99999) ;p49
  1. Q
  1. WBF ;Write Buffer Flush
  1. Q:'$L(XWBSBUF)
  1. I $G(XWBDEBUG)>2,$L(XWBSBUF) D LOG^XWBDLOG("wrt ("_$L(XWBSBUF)_"): "_$E(XWBSBUF,1,247))
  1. W XWBSBUF,@XWBT("BF")
  1. S XWBSBUF=""
  1. Q