source: WorldVistAEHR/trunk/r/RPC_BROKER-XWB/XWBRPC.m@ 1076

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

initial load of WorldVistAEHR

File size: 9.4 KB
Line 
1XWBRPC ;OIFO-Oakland/REM - M2M Broker Server MRH ;08/20/2002 12:13
2 ;;1.1;RPC BROKER;**28,34**;Mar 28, 1997
3 ;
4 QUIT
5 ;
6 ; ---------------------------------------------------------------------
7 ; RPC Server: Message Request Handler (MRH)
8 ; ---------------------------------------------------------------------
9 ;
10 ;p34 -added $$CHARCHK^XWBUTL before writing to WRITE^XWBRL to escape CR - PROCESS.
11 ; -remove $C(13). CR were not being stripped out in result - PROCESS.
12 ;
13 ;
14EN(XWBDATA) ; -- handle parsed messages request
15 NEW RPC0,RPCURI,RPCIEN,TAG,ROU,METHSIG,XWBR
16 ;
17 IF $G(XWBDATA("URI"))="" DO GOTO ENQ
18 . DO ERROR(1,"NONE","No Remote Procedure Specified.")
19 ;
20 SET RPCURI=XWBDATA("URI")
21 ;
22 SET U="^"
23 ;May want to build/call common broker api for RPC lookup. See XWBBRK
24 SET RPCIEN=$O(^XWB(8994,"B",RPCURI,""))
25 IF RPCIEN'>0 DO GOTO ENQ
26 . DO ERROR(2,RPCURI,"Remote Procedure Unknown: "_RPCURI_" cannot be found.")
27 .D ERROR^XWBM2MC(7) ;Write error in TMP **M2M
28 ;
29 SET RPC0=$GET(^XWB(8994,RPCIEN,0))
30 IF RPC0="" DO GOTO ENQ
31 . DO ERROR(3,RPCURI,"Remote Procedure Blank: '"_RPCURI_"' contains no information.")
32 ;
33 SET RPCURI=$P(RPC0,U)
34 SET TAG=$P(RPC0,U,2)
35 SET ROU=$P(RPC0,U,3)
36 ;
37 ; -- check inactive flag
38 IF $P(RPC0,U,6)=1!($P(RPC0,U,6)=2) DO GOTO ENQ
39 . DO ERROR(4,RPCURI,"Remote Procedure InActive: '"_RPCURI_"' cannot be run at this time.")
40 ;
41 SET XWBPTYPE=$P(RPC0,U,4)
42 SET XWBWRAP=$P(RPC0,U,8)
43 ;
44 ; -- build method signature and call rpc
45 SET METHSIG=TAG_"^"_ROU_"(.XWBR"_$G(XWBDATA("PARAMS"))_")"
46 ;
47 I $G(XWBDEBUG) D LOG(METHSIG)
48 ;See that the NULL device is current
49 DO @METHSIG
50 ;
51 ; -- send results
52 D USE^%ZISUTL("XWBM2M SERVER") U IO ;**M2M use server IO
53 ;
54 I $G(XWBDEBUG) D LOG(.XWBR)
55 DO SEND(.XWBR)
56 ;
57ENQ ; -- end message handler
58 DO CLEAN
59 ;
60 QUIT
61 ;
62CLEAN ; -- clean up message handler environment
63 NEW POS
64 ; -- kill parameters
65 SET POS=0
66 FOR S POS=$O(XWBDATA("PARAMS",POS)) Q:'POS K @XWBDATA("PARAMS",POS)
67 Q
68 ;
69SEND(XWBR) ; -- stream rpc data to client
70 NEW XWBFMT,XWBFILL
71 SET XWBFMT=$$GETFMT()
72 ; -- prepare socket for writing
73 DO PRE^XWBRL
74 ; -- initialize
75 DO WRITE^XWBRL($$XMLHDR^XWBUTL())
76 ;DO DOCTYPE
77 DO WRITE^XWBRL("<vistalink type=""Gov.VA.Med.RPC.Response"" ><results type="""_XWBFMT_""" ><![CDATA[")
78 ; -- results
79 DO PROCESS
80 ; -- finalize
81 DO WRITE^XWBRL("]]></results></vistalink>")
82 ; -- send eot and flush buffer
83 DO POST^XWBRL
84 ;
85 QUIT
86 ;
87DOCTYPE ;
88 DO WRITE^XWBRL("<!DOCTYPE vistalink [<!ELEMENT vistalink (results) ><!ELEMENT results (#PCDATA)><!ATTLIST vistalink type CDATA ""Gov.VA.Med.RPC.Response"" ><!ATTLIST results type (array|string) >]>")
89 QUIT
90 ;
91GETFMT() ; -- determine response format type
92 IF XWBPTYPE=1!(XWBPTYPE=5)!(XWBPTYPE=6) QUIT "string"
93 IF XWBPTYPE=2 QUIT "array"
94 ;
95 QUIT $S(XWBWRAP:"array",1:"string")
96 ;
97PROCESS ; -- send the real results
98 NEW I,T,DEL,V
99 ;
100 ;*p34-Remove $C(13). CR were not being stripped out in results to escape CR.
101 ;S DEL=$S(XWBMODE="RPCBroker":$C(13,10),1:$C(10))
102 S DEL=$S(XWBMODE="RPCBroker":$C(10),1:$C(10))
103 ;
104 ;*p34-When write XWBR, go thru $$CHARCHK^XWBUTL first.
105 ; -- single value
106 IF XWBPTYPE=1 SET XWBR=$G(XWBR) DO WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR))) QUIT
107 ; -- table delimited by CR+LF - ARRAY
108 IF XWBPTYPE=2 DO QUIT
109 . SET I="" FOR SET I=$O(XWBR(I)) QUIT:I="" DO WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR(I)))),WRITE^XWBRL(DEL)
110 ; -- word processing
111 IF XWBPTYPE=3 DO QUIT
112 . SET I="" FOR SET I=$O(XWBR(I)) QUIT:I="" DO WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR(I)))) DO:XWBWRAP WRITE^XWBRL(DEL)
113 ; -- global array
114 IF XWBPTYPE=4 DO QUIT
115 . SET I=$G(XWBR) QUIT:I="" SET T=$E(I,1,$L(I)-1)
116 . I $D(@I)>10 S V=@I D WRITE^XWBRL($$CHARCHK^XWBUTL($G(V)))
117 . FOR SET I=$Q(@I) QUIT:I=""!(I'[T) S V=@I D WRITE^XWBRL($$CHARCHK^XWBUTL($G(V))) D:XWBWRAP&(V'=DEL) WRITE^XWBRL(DEL)
118 . IF $D(@XWBR) KILL @XWBR
119 ; -- global instance
120 IF XWBPTYPE=5 S XWBR=$G(@XWBR) D WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR))) QUIT
121 ; -- variable length records only good up to 255 char)
122 IF XWBPTYPE=6 SET I="" FOR SET I=$O(XWBR(I)) QUIT:I="" DO WRITE^XWBRL($C($L(XWBR(I)))),WRITE^XWBRL(XWBR(I))
123 QUIT
124 ;
125ERROR(CODE,RPCURI,MSG) ; -- send rpc application error
126 DO PRE^XWBRL
127 DO WRITE^XWBRL($$XMLHDR^XWBUTL())
128 DO WRITE^XWBRL("<vistalink type=""VA.RPC.Error"" >")
129 DO WRITE^XWBRL("<errors>")
130 DO WRITE^XWBRL("<error code="""_CODE_""" uri="""_$G(RPCURI)_""" >")
131 DO WRITE^XWBRL("<msg>"_$G(MSG)_"</msg>")
132 DO WRITE^XWBRL("</error>")
133 DO WRITE^XWBRL("</errors>")
134 DO WRITE^XWBRL("</vistalink>")
135 ; -- send eot and flush buffer
136 DO POST^XWBRL
137 QUIT
138 ;
139 ; ---------------------------------------------------------------------
140 ; RPC Server: Request Message XML SAX Parser Callbacks
141 ; ---------------------------------------------------------------------
142ELEST(ELE,ATR) ; -- element start event handler
143 IF ELE="vistalink" KILL XWBSESS,XWBPARAM,XWBPN,XWBPTYPE QUIT
144 ;
145 IF ELE="rpc" SET XWBDATA("URI")=$$ESC^XWBRMX($G(ATR("uri"),"##Unkown RPC##")) QUIT
146 ;
147 IF ELE="param" DO QUIT
148 . SET XWBPARAM=1
149 . SET XWBPN="XWBP"_ATR("position")
150 . SET XWBDATA("PARAMS",ATR("position"))=XWBPN
151 . SET XWBPTYPE=ATR("type")
152 . S XWBCHRST="" ;To accumulate char
153 ;
154 IF ELE="index" DO QUIT
155 . ;SET @XWBPN@($$ESC^XWBRMX(ATR("name")))=$$ESC^XWBRMX(ATR("value"))
156 . S XWBPN("name")=$$ESC^XWBRMX(ATR("name")) ;rwf
157 . S XWBCHRST=""
158 ;
159 QUIT
160 ;
161ELEND(ELE) ; -- element end event handler
162 IF ELE="vistalink" KILL XWBPOS,XWBSESS,XWBPARAM,XWBPN,XWBPTYPE,XWBCHRST QUIT
163 ;
164 IF ELE="params" DO QUIT
165 . NEW POS,PARAMS
166 . SET PARAMS="",POS=0
167 . FOR SET POS=$O(XWBDATA("PARAMS",POS)) Q:'POS SET PARAMS=PARAMS_",."_XWBDATA("PARAMS",POS)
168 . SET XWBDATA("PARAMS")=PARAMS
169 ;
170 IF ELE="param" D Q
171 . I $G(XWBDEBUG),$D(XWBPN),$D(@XWBPN) D LOG(.@XWBPN)
172 . KILL XWBPARAM,XWBCHRST
173 ;
174 QUIT
175 ;
176 ;This can be called more than once for one TEXT string.
177CHR(TEXT) ; -- character value event handler <tag>TEXT</tag)
178 ;
179 IF $G(XWBPARAM) DO
180 . ;What to do if string gets too long?
181 . ;IF XWBPTYPE="string" SET XWBCHRST=XWBCHRST_$$ESC^XWBRMX(TEXT),@XWBPN=XWBCHRST QUIT
182 . IF XWBPTYPE="string" SET XWBCHRST=XWBCHRST_TEXT,@XWBPN=XWBCHRST QUIT
183 . ;IF XWBPTYPE="ref" SET @XWBPN=$G(@$$ESC^XWBRMX(TEXT)) QUIT
184 . IF XWBPTYPE="ref" SET XWBCHRST=XWBCHRST_TEXT,@XWBPN=@XWBCHRST QUIT
185 . I XWBPTYPE="array" S XWBCHRST=XWBCHRST_TEXT,@XWBPN@(XWBPN("name"))=XWBCHRST Q ;rwf
186 QUIT
187 ;
188 ; ---------------------------------------------------------------------
189 ; Parse Results of Successful Legacy RPC Request
190 ; ---------------------------------------------------------------------
191 ;
192 ; [Public/Supported Method]
193PARSE(XWBPARMS,XWBY) ; -- parse legacy rpc results ; uses SAX parser
194 NEW XWBCHK,XWBOPT,XWBTYPE,XWBCNT
195 ;
196 ;**M2M Result will go here.
197 I XWBY="" D
198 .IF $G(XWBY)="" SET XWBY=$NA(^TMP("XWBM2MRPC",$J,"RESULTS"))
199 .SET XWBYX=XWBY
200 .KILL @XWBYX
201 ;
202 DO SET
203 SET XWBOPT=""
204 DO EN^MXMLPRSE(XWBPARMS("RESULTS"),.XWBCBK,.XWBOPT)
205 Q
206 ;
207SET ; -- set the event interface entry points ;
208 SET XWBCBK("STARTELEMENT")="RESELEST^XWBRPC"
209 SET XWBCBK("ENDELEMENT")="RESELEND^XWBRPC"
210 SET XWBCBK("CHARACTERS")="RESCHR^XWBRPC"
211 QUIT
212 ;
213RESELEST(ELE,ATR) ; -- element start event handler
214 IF ELE="results" SET XWBTYPE=$G(ATR("type")),XWBCNT=0
215 QUIT
216 ;
217RESELEND(ELE) ; -- element end event handler
218 KILL XWBCNT,XWBTYPE
219 QUIT
220 ;
221RESCHR(TEXT) ; -- character value event handler
222 QUIT:$G(XWBTYPE)=""
223 QUIT:'$L(TEXT) ; -- Sometimes sends in empty string
224 ;
225 IF XWBCNT=0,TEXT=$C(10) QUIT ; -- bug in parser? always starts with $C(10)
226 ;
227 IF XWBTYPE="string" DO QUIT
228 . SET XWBCNT=XWBCNT+1
229 . SET @XWBY@(XWBCNT)=TEXT
230 ;
231 IF XWBTYPE="array" DO
232 . SET XWBCNT=XWBCNT+1
233 . SET @XWBY@(XWBCNT)=$P(TEXT,$C(10))
234 QUIT
235 ;
236PARSEX(XWBPARMS,XWBY) ; -- parse legacy rpc results ; uses DOM parser
237 NEW XWBDOM
238 SET XWBDOM=$$EN^MXMLDOM(XWBPARMS("RESULTS"),"")
239 DO TEXT^MXMLDOM(XWBDOM,2,XWBY)
240 DO DELETE^MXMLDOM(XWBDOM)
241 QUIT
242 ;
243LOG(MSG) ;Debug log
244 N CNT
245 S CNT=$G(^TMP("XWBM2ML",$J))+1,^($J)=CNT
246 M ^TMP("XWBM2ML",$J,CNT)=MSG
247 Q
248 ;
249 ; -------------------------------------------------------------------
250 ; Response Format Documentation
251 ; -------------------------------------------------------------------
252 ;
253 ;
254 ; [ Sample XML produced by a successful call of EN^XWBRPC(.XWBPARMS).
255 ; SEND^XWBRPC does the actual work to produce response. ]
256 ;
257 ; <?xml version="1.0" encoding="utf-8" ?>
258 ; <vistalink type="Gov.VA.Med.RPC.Response" >
259 ; <results type="array" >
260 ; <![CDATA[4261;;2961001.08^2^274^166^105^^2961001.1123^1^^9^2^8^10^^^^^^^10G1-ALN
261 ; 4270;;2961002.08^2^274^166^112^^^1^^9^2^8^10^^^^^^^10G8-ALN
262 ; 4274;;2961003.08^2^274^166^116^^^1^^9^2^8^10^^^^^^^10GD-ALN
263 ; 4340;;2961117.08^2^274^166^182^^2961118.1425^1^^9^2^8^10^^^^^^^10K0-ALN
264 ; 4342;;2961108.13^2^108^207^183^^2961118.1546^1^^9^2^8^10^^^^^^^10K2-ALN
265 ; 6394;;3000607.084^2^165^68^6479^^3000622.13^1^^9^1^8^10^^^^^^^197M-ALN]]>
266 ; </results>
267 ; </vistalink>
268 ;
269 ; -------------------------------------------------------------------
270 ;
271 ; [ Sample XML produced by a unsuccessful call of EN^XWBRPC(.XWBPARMS).
272 ; ERROR^XWBRPC does the actual work to produce response. ]
273 ;
274 ; <?xml version="1.0" encoding="utf-8" ?>
275 ; <vistalink type="Gov.VA..Med.RPC.Error" >
276 ; <errors>
277 ; <error code="2" uri="XWB BAD NAME" >
278 ; <msg>
279 ; Remote Procedure Unknown: 'XWB BAD NAME' cannot be found.
280 ; </msg>
281 ; </error>
282 ; </errors>
283 ; </vistalink>
284 ;
285 ; -------------------------------------------------------------------
286 ;
Note: See TracBrowser for help on using the repository browser.