source: WorldVistAEHR/trunk/r/RPC_BROKER-XWB/XWBRW.m@ 1732

Last change on this file since 1732 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.5 KB
RevLine 
[613]1XWBRW ;ISF/RWF - Read/Write for Broker TCP ;8/16/07 09:33
2 ;;1.1;RPC BROKER;**35,49**;Mar 28, 1997;Build 4;WorldVistA 30-Jan-08
3 ;Modified from FOIA VISTA,
4 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
5 ;General Public License See attached copy of the License.
6 ;
7 ;This program is free software; you can redistribute it and/or modify
8 ;it under the terms of the GNU General Public License as published by
9 ;the Free Software Foundation; either version 2 of the License, or
10 ;(at your option) any later version.
11 ;
12 ;This program is distributed in the hope that it will be useful,
13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;GNU General Public License for more details.
16 ;
17 ;You should have received a copy of the GNU General Public License along
18 ;with this program; if not, write to the Free Software Foundation, Inc.,
19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 Q
21 ;
22 ;XWBRBUF is global
23 ;SE is a flag to skip error for short read. From PRSB+41^XWBBRK
24BREAD(L,TO,SE) ;read tcp buffer, L is length, TO is timeout
25 N R,S,DONE,C
26 I L'>0 Q ""
27 I $L(XWBRBUF)'<L S R=$E(XWBRBUF,1,L),XWBRBUF=$E(XWBRBUF,L+1,999999) Q R
28 S R="",DONE=0,L=+L,C=0
29 S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
30 U XWBTDEV
31 F D Q:DONE
32 . S S=L-$L(R),R=R_$E(XWBRBUF,1,S),XWBRBUF=$E(XWBRBUF,S+1,999999)
33 . I ($L(R)=L)!(R[$C(4))!(C>TO) S DONE=1 Q
34 . R XWBRBUF#S:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0 I +$DEVICE S DONE=1
35 . I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG("rd: "_$E(XWBRBUF,1,252))
36 . Q
37 I $L(R)<L,'$G(SE) S $ECODE=",U411," ;Throw Error, Did not read full length
38 Q R
39 ;
40QSND(XWBR) ;Quick send
41 S XWBPTYPE=1,XWBERROR="",XWBSEC="" D SND
42 Q
43 ;
44ESND(XWBR) ;Send from ETRAP
45 S XWBPTYPE=1 D SND
46 Q
47 ;
48SND ; Send a responce
49 N XWBSBUF S XWBSBUF=""
50 U XWBTDEV
51 ;
52 D SNDERR ;Send any error info
53 D SNDDATA ;Send the data
54 ;D WRITE($C(4)) ;EOT
55 D WRITE($C(4)),WBF
56 Q
57 ;
58SNDDATA ;Send the data part
59 N I,D
60 ; -- single value
61 I XWBPTYPE=1 D WRITE($G(XWBR)) Q
62 ; -- table delimited by CR+LF
63 I XWBPTYPE=2 D Q
64 . S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)),WRITE($C(13,10))
65 ; -- word processing
66 I XWBPTYPE=3 D Q
67 . S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)) D:XWBWRAP WRITE($C(13,10))
68 ; -- global array
69 I XWBPTYPE=4 D Q
70 . I $E($G(XWBR))'="^" Q
71 . S I=$G(XWBR) Q:I="" S T=$E(I,1,$L(I)-1)
72 . ;Only send root node if non-null.
73 . I $D(@I)>10 S D=@I I $L(D) D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
74 . F S I=$Q(@I) Q:I=""!(I'[T) S D=@I D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
75 . I $D(@XWBR) K @XWBR
76 ; -- global instance
77 I XWBPTYPE=5 D Q
78 . I $E($G(XWBR))'="^" Q
79 . S XWBR=$G(@XWBR) D WRITE(XWBR) Q
80 ; -- variable length records only good upto 255 char)
81 I XWBPTYPE=6 D
82 . S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE($C($L(XWBR(I)))),WRITE(XWBR(I))
83 Q
84 ;
85SNDERR ;send error information
86 ;XWBSEC is the security packet, XWBERROR is application packet
87 N X
88 S $X=0 ;Start with zero
89 S X=$E($G(XWBSEC),1,255)
90 D WRITE($C($L(X))_X)
91 S X=$E($G(XWBERROR),1,255)
92 D WRITE($C($L(X))_X)
93 S XWBERROR="",XWBSEC="" ;clears parameters
94 Q
95 ;
96WRITE(STR) ;Write a data string
97 ; send data for DSM (requires buffer flush (!) every 511 chars)
98 ;IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM) next line
99 F Q:'$L(STR) D
100 . I $L(XWBSBUF)+$L(STR)>240 D WBF
101 . S XWBSBUF=XWBSBUF_$E(STR,1,255),STR=$E(STR,256,99999)
102 Q
103WBF ;Write Buffer Flush
104 Q:'$L(XWBSBUF)
105 I $G(XWBDEBUG)>2,$L(XWBSBUF) D LOG^XWBDLOG("wrt ("_$L(XWBSBUF)_"): "_$E(XWBSBUF,1,247))
106 W XWBSBUF,@XWBT("BF")
107 S XWBSBUF=""
108 Q
Note: See TracBrowser for help on using the repository browser.