source: WorldVistAEHR/trunk/r/RPC_BROKER-XWB/XWBPRS.m@ 701

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1XWBPRS ;ISF/STAFF - VISTA BROKER MSG PARSER ; 3/28/2006
2 ;;1.1;RPC BROKER;**35,43,46**;Mar 28, 1997
3 ;XWB holds info from the message used by the RPC
4CALLP(XWBP,XWBDEBUG) ;make API call using Protocol string
5 N ERR,S,XWBARY K XWB
6 S ERR=0
7 S ERR=$$PRSP("[XWB]") ;Read the rest of the protocol header
8 I '+ERR S ERR=$$PRSM ;Read and parse message
9 I $G(XWB(2,"RPC"))="XUS SET SHARED" S XWBSHARE=1 Q
10 I '+ERR S ERR=$$RPC ;Check the RPC
11 I +ERR S XWBSEC=$P(ERR,U,2) ;P10 -- dpc
12 I '+ERR D CHKPRMIT^XWBSEC($G(XWB(2,"RPC"))) ;checks if RPC allowed to run
13 S:$L($G(XWBSEC)) ERR="-1^"_XWBSEC
14 I '+ERR D
15 . D CAPI(.XWBP,XWB("PARAM"))
16 E I ($G(XWBTCMD)'="#BYE#") D LOG^XWBTCPM("Bad Msg"_ERR),CLRBUF
17 I 'XWBDEBUG K XWB
18 I $D(XWBARY) K @XWBARY,XWBARY
19 Q
20 ;
21PRSP(P) ;ef, Parse Protocol
22 ;M Extrinsic Function
23 ;Outputs
24 ;ERR 0 for success, "-1^Text" if error
25 ;
26 N ERR,C,M,R,X
27 S R=0,C=";",ERR=0
28 S P=$$BREAD^XWBRW(4)
29 IF $L(P)'=4 S ERR="-1^Short Header info"
30 IF +ERR=0 D
31 . S XWB(R,"VER")=+$E(P,1)
32 . S XWB(R,"TYPE")=+$E(P,2)
33 . S (XWBENVL,XWB(R,"LENV"))=+$E(P,3)
34 . S (XWBPRT,XWB(R,"RT"))=+$E(P,4)
35 I XWBENVL<1 S (XWBENVL,XWB(R,"LENV"))=3
36 Q ERR
37 ;
38PRSM() ;ef, Parse message
39 ;M Extrinsic Function
40 ;See document on msg format
41 ;Outputs
42 ;ERR 0 for success, "-1^Text" if error
43 N C,EX1,ERR,R,X,CNK
44 S R=1,C=";",CNK=0,EX1=0 ;Max buffer
45 S ERR="-1^Invalid Chunk"
46 F S CNK=$$BREAD^XWBRW(1) Q:("12345"'[CNK) D Q:EX1
47 . S EX1=(CNK=5),@("ERR=$$PRS"_CNK)
48 Q ERR
49 ;
50PRS1() ;Parse the HEADER chunk
51 N %,L,R
52 S R=1
53 S XWB(R,"VER")=$$SREAD
54 S XWB(R,"RETURN")=$$SREAD
55 Q 0
56 ;
57PRS2() ;Parse the RPC chunk
58 N L,R
59 S R=2
60 S (XWBAPVER,XWB(R,"VER"))=$$SREAD ;RPC version
61 S XWB(R,"RPC")=$$SREAD
62 I $G(XWBDEBUG)>1 D LOG^XWBTCPM("RPC: "_XWB(R,"RPC"))
63 Q 0
64PRS3() ;Parse the Security chunk
65 N L,R
66 S R=3
67 Q 0
68PRS4() ;Parse the Command chunk
69 N R
70 S R=4,XWBTCMD=$$SREAD,XWB(R,"CMD")=XWBTCMD
71 I $G(XWBDEBUG)>1 D LOG^XWBTCPM("CMD: "_XWBTCMD)
72 Q ("TCPConnect^#BYE#"[XWBTCMD)
73 ;
74PRS5() ;Parse Data Parameter chunk
75 ;M Extrinsic Function
76 ;Outputs
77 ;ERR 0 for success, "-1^Text" if error
78 ;
79 N CONT,DONE,ERR,F,FL,IX,K,L,P1,P2,P3,P4,P5,MAXP,R,TY,VA
80 S R=5,ERR=0,F=3,IX=0,DONE=0,CONT="f",XWB("PARAM")=""
81 F S:CONT="f" TY=$$BREAD^XWBRW(1) D Q:DONE S CONT=$$BREAD^XWBRW(1) S:CONT'="t" IX=IX+1
82 . K VA,P1
83 . IF TY=$C(4) S DONE=1 Q ;EOT
84 . IF TY=0 D Q ;literal
85 . . D LREAD("VA")
86 . . S XWB(R,"P",IX)=VA(1) D PARAM($NA(XWB(R,"P",IX)))
87 . . Q
88 . IF TY=1 D Q ;reference
89 . . D LREAD("VA")
90 . . S XWB(R,"P",IX)=$$GETV(VA(1)) D PARAM($NA(XWB(R,"P",IX)))
91 . . Q
92 . IF TY=2 D Q ;list
93 . . I CONT'="t" D
94 . . . S XWBARY=$$OARY,XWB(R,"P",IX)="."_XWBARY
95 . . . D PARAM(XWB(R,"P",IX))
96 . . D LREAD("P1") Q:P1(1)="" D LREAD("VA")
97 . . D LINST(XWBARY,P1(1),VA(1))
98 . . Q
99 . IF TY=3 D Q ;global
100 . . I CONT'="t" D
101 . . . S XWBARY=$NA(^TMP("XWBA",$J,IX)),XWB(R,"P",IX)=XWBARY
102 . . . K @XWBARY S @XWBARY=""
103 . . . D PARAM(XWBARY)
104 . . D LREAD("P1") Q:P1(1)="" D LREAD("VA")
105 . . D GINST(XWBARY,P1(1),VA(1))
106 . . Q
107 . IF TY=4 D Q ;empty - ,,
108 . . S XWB(R,"XWB",IX)=""
109 . . Q
110 . IF TY=5 D Q
111 . . ;stream still to be done
112 . Q ;End of loop
113 Q ERR
114PARAM(NA) ;Add a new parameter to the list
115 N A
116 S A=$G(XWB("PARAM")) S:'$L(NA) NA="""""" ;Empty
117 S A=A_$S($L(A):",",1:"")_$S(TY=3:"$NA(",1:"")_NA_$S(TY=3:")",1:"")
118 S XWB("PARAM")=A
119 Q
120 ;
121RPC() ;Check the rpc information.
122 ;M Extrinsic Function
123 ;Outputs
124 ;ERR 0 for success, "-1^Text" if error
125 ;
126 N C,DR,ERR,M,R,RPC,T,X
127 S R=2,C=";",ERR=0,M=512 ;Max buffer
128 S RPC=$G(XWB(R,"RPC")) I '$L(RPC) Q "-1^No RPC sent"
129 S T=$O(^XWB(8994,"B",RPC,0))
130 I '+T Q "-1^Remote Procedure '"_RPC_"' doesn't exist on the server."
131 S T(0)=$G(^XWB(8994,T,0))
132 I $P(T(0),U,6)=1!($P(T(0),U,6)=2) Q "-1^Remote Procedure '"_RPC_"' cannot be run at this time." ;P10. Check INACTIVE field. - dpc.
133 S XWB(R,"RTAG")=$P(T(0),"^",2)
134 S XWB(R,"RNAM")=$P(T(0),"^",3)
135 S XWBPTYPE=$P(T(0),"^",4)
136 S XWBWRAP=+$P(T(0),"^",8)
137 Q ERR
138 ;
139SREAD() ;Read a S_PACK
140 N L,V7
141 S L=$$BREAD^XWBRW(1),L=$A(L)
142 S V7=$$BREAD^XWBRW(L)
143 Q V7
144 ;
145LREAD(ROOT) ;Read a L_PACK
146 N L,V7,I ;p45 Remove limit on length of string.
147 S I=1,@ROOT@(I)=""
148 S L=$$BREAD^XWBRW(XWBENVL),L=+L
149 I L>0 S V7=$$BREAD^XWBRW(L),@ROOT@(I)=V7,I=I+1
150 Q
151 ;
152 ;X can be something like '"TEXT",1,0'.
153LINST(A,X,XWBY) ;instantiate local array
154 IF XWBY=$C(1) S XWBY=""
155 S X=A_"("_X_")"
156 S @X=XWBY
157 Q
158 ;
159 ;S can be something like '"TEXT",1,0'.
160GINST(R,S,V) ;instantiate global
161 N N
162 I V=$C(1) S V=""
163 S N=$P(R,")")_","_S_")"
164 S @N=V
165 Q
166 ;
167GETV(V) ;get value of V - reference parameter
168 N X
169 S X=V
170 IF $E(X,1,2)="$$" Q ""
171 IF $C(34,36)[$E(V) X "S V="_$$VCHK(V)
172 E S V=@V
173 Q V
174 ;
175VCHK(S) ;Parse string for first argument
176 N C,I,P
177 F I=1:1 S C=$E(S,I) D VCHKP:C="(",VCHKQ:C=$C(34) Q:" ,"[C
178 Q $E(S,1,I-1)
179VCHKP S P=1 ;Find closing paren
180 F I=I+1:1 S C=$E(S,I) Q:P=0!(C="") I "()"""[C D VCHKQ:C=$C(34) S P=P+$S("("[C:1,")"[C:-1,1:0)
181 Q
182VCHKQ ;Find closing quote
183 F I=I+1:1 S C=$E(S,I) Q:C=""!(C=$C(34))
184 Q
185CLRBUF ;Empties Input buffer
186 N %
187 F R *%:2 Q:'$T!(%=4) ;!(%=-1)
188 Q
189ZZZ(X) ;Convert
190 N I
191 F S I=$F(X,"$C(") Q:'I S J=$F(X,")",I),X=$E(X,1,I-4)_$C($E(X,I,J-2))_$E(X,J,999)
192 Q X
193 ;
194CAPI(XWBY,PAR) ;make API call
195 N XWBCALL,T,DX,DY
196 S XWBCALL=XWB(2,"RTAG")_"^"_XWB(2,"RNAM")_"(.XWBY"_$S($L(PAR):","_PAR,1:"")_")",XWBCALL2=""
197 K PAR
198 O XWBNULL U XWBNULL ;p43 Make sure its open
199 ;
200 I $G(XWBDEBUG)>2 D LOG^XWBDLOG("Call: "_$E(XWBCALL,1,247))
201 ;start RUM for RPC
202 I $G(XWB(2,"CAPI"))]"" D LOGRSRC^%ZOSV(XWB(2,"CAPI"),2,1)
203 ;
204 D @XWBCALL S XWBCALL2=XWBCALL ;Save call for debug
205 ;
206 ;restart RUM for handler
207 D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
208 ;
209 U XWBTDEV
210 Q
211 ;
212OARY() ;create storage array
213 N A,DONE,I
214 S I=1+$G(XWB("ARRAY")),XWB("ARRAY")=I
215 S A="XWBS"_I
216 K @A ;temp fix for single array
217 S @A="" ;set naked
218 Q A
219 ;
220CREF(R,P) ;Convert array contained in P to reference A
221 N I,X,DONE,F1,S
222 S DONE=0
223 S S=""
224 F I=1:1 D Q:DONE
225 . IF $P(P,",",I)="" S DONE=1 Q
226 . S X(I)=$P(P,",",I)
227 . IF X(I)?1"."1A.E D
228 . . S F1=$F(X(I),".")
229 . . S X(I)="."_R
230 . S S=S_X(I)_","
231 Q $E(S,1,$L(S)-1)
232 ;
Note: See TracBrowser for help on using the repository browser.