| 1 | XWBRPC ;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 | ;
|
|---|
| 14 | EN(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 | ;
|
|---|
| 57 | ENQ ; -- end message handler
|
|---|
| 58 | DO CLEAN
|
|---|
| 59 | ;
|
|---|
| 60 | QUIT
|
|---|
| 61 | ;
|
|---|
| 62 | CLEAN ; -- 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 | ;
|
|---|
| 69 | SEND(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 | ;
|
|---|
| 87 | DOCTYPE ;
|
|---|
| 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 | ;
|
|---|
| 91 | GETFMT() ; -- 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 | ;
|
|---|
| 97 | PROCESS ; -- 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 | ;
|
|---|
| 125 | ERROR(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 | ; ---------------------------------------------------------------------
|
|---|
| 142 | ELEST(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 | ;
|
|---|
| 161 | ELEND(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.
|
|---|
| 177 | CHR(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]
|
|---|
| 193 | PARSE(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 | ;
|
|---|
| 207 | SET ; -- 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 | ;
|
|---|
| 213 | RESELEST(ELE,ATR) ; -- element start event handler
|
|---|
| 214 | IF ELE="results" SET XWBTYPE=$G(ATR("type")),XWBCNT=0
|
|---|
| 215 | QUIT
|
|---|
| 216 | ;
|
|---|
| 217 | RESELEND(ELE) ; -- element end event handler
|
|---|
| 218 | KILL XWBCNT,XWBTYPE
|
|---|
| 219 | QUIT
|
|---|
| 220 | ;
|
|---|
| 221 | RESCHR(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 | ;
|
|---|
| 236 | PARSEX(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 | ;
|
|---|
| 243 | LOG(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 | ;
|
|---|
