XWBRPC ;OIFO-Oakland/REM - M2M Broker Server MRH ;08/20/2002 12:13
;;1.1;RPC BROKER;**28,34**;Mar 28, 1997
;
QUIT
;
; ---------------------------------------------------------------------
; RPC Server: Message Request Handler (MRH)
; ---------------------------------------------------------------------
;
;p34 -added $$CHARCHK^XWBUTL before writing to WRITE^XWBRL to escape CR - PROCESS.
; -remove $C(13). CR were not being stripped out in result - PROCESS.
;
;
EN(XWBDATA) ; -- handle parsed messages request
NEW RPC0,RPCURI,RPCIEN,TAG,ROU,METHSIG,XWBR
;
IF $G(XWBDATA("URI"))="" DO GOTO ENQ
. DO ERROR(1,"NONE","No Remote Procedure Specified.")
;
SET RPCURI=XWBDATA("URI")
;
SET U="^"
;May want to build/call common broker api for RPC lookup. See XWBBRK
SET RPCIEN=$O(^XWB(8994,"B",RPCURI,""))
IF RPCIEN'>0 DO GOTO ENQ
. DO ERROR(2,RPCURI,"Remote Procedure Unknown: "_RPCURI_" cannot be found.")
.D ERROR^XWBM2MC(7) ;Write error in TMP **M2M
;
SET RPC0=$GET(^XWB(8994,RPCIEN,0))
IF RPC0="" DO GOTO ENQ
. DO ERROR(3,RPCURI,"Remote Procedure Blank: '"_RPCURI_"' contains no information.")
;
SET RPCURI=$P(RPC0,U)
SET TAG=$P(RPC0,U,2)
SET ROU=$P(RPC0,U,3)
;
; -- check inactive flag
IF $P(RPC0,U,6)=1!($P(RPC0,U,6)=2) DO GOTO ENQ
. DO ERROR(4,RPCURI,"Remote Procedure InActive: '"_RPCURI_"' cannot be run at this time.")
;
SET XWBPTYPE=$P(RPC0,U,4)
SET XWBWRAP=$P(RPC0,U,8)
;
; -- build method signature and call rpc
SET METHSIG=TAG_"^"_ROU_"(.XWBR"_$G(XWBDATA("PARAMS"))_")"
;
I $G(XWBDEBUG) D LOG(METHSIG)
;See that the NULL device is current
DO @METHSIG
;
; -- send results
D USE^%ZISUTL("XWBM2M SERVER") U IO ;**M2M use server IO
;
I $G(XWBDEBUG) D LOG(.XWBR)
DO SEND(.XWBR)
;
ENQ ; -- end message handler
DO CLEAN
;
QUIT
;
CLEAN ; -- clean up message handler environment
NEW POS
; -- kill parameters
SET POS=0
FOR S POS=$O(XWBDATA("PARAMS",POS)) Q:'POS K @XWBDATA("PARAMS",POS)
Q
;
SEND(XWBR) ; -- stream rpc data to client
NEW XWBFMT,XWBFILL
SET XWBFMT=$$GETFMT()
; -- prepare socket for writing
DO PRE^XWBRL
; -- initialize
DO WRITE^XWBRL($$XMLHDR^XWBUTL())
;DO DOCTYPE
DO WRITE^XWBRL("<vistalink type=""Gov.VA.Med.RPC.Response"" ><results type="""_XWBFMT_""" ><![CDATA[")
; -- results
DO PROCESS
; -- finalize
DO WRITE^XWBRL("]]></results></vistalink>")
; -- send eot and flush buffer
DO POST^XWBRL
;
QUIT
;
DOCTYPE ;
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) >]>")
QUIT
;
GETFMT() ; -- determine response format type
IF XWBPTYPE=1!(XWBPTYPE=5)!(XWBPTYPE=6) QUIT "string"
IF XWBPTYPE=2 QUIT "array"
;
QUIT $S(XWBWRAP:"array",1:"string")
;
PROCESS ; -- send the real results
NEW I,T,DEL,V
;
;*p34-Remove $C(13). CR were not being stripped out in results to escape CR.
;S DEL=$S(XWBMODE="RPCBroker":$C(13,10),1:$C(10))
S DEL=$S(XWBMODE="RPCBroker":$C(10),1:$C(10))
;
;*p34-When write XWBR, go thru $$CHARCHK^XWBUTL first.
; -- single value
IF XWBPTYPE=1 SET XWBR=$G(XWBR) DO WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR))) QUIT
; -- table delimited by CR+LF - ARRAY
IF XWBPTYPE=2 DO QUIT
. SET I="" FOR SET I=$O(XWBR(I)) QUIT:I="" DO WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR(I)))),WRITE^XWBRL(DEL)
; -- word processing
IF XWBPTYPE=3 DO QUIT
. SET I="" FOR SET I=$O(XWBR(I)) QUIT:I="" DO WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR(I)))) DO:XWBWRAP WRITE^XWBRL(DEL)
; -- global array
IF XWBPTYPE=4 DO QUIT
. SET I=$G(XWBR) QUIT:I="" SET T=$E(I,1,$L(I)-1)
. I $D(@I)>10 S V=@I D WRITE^XWBRL($$CHARCHK^XWBUTL($G(V)))
. 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)
. IF $D(@XWBR) KILL @XWBR
; -- global instance
IF XWBPTYPE=5 S XWBR=$G(@XWBR) D WRITE^XWBRL($$CHARCHK^XWBUTL($G(XWBR))) QUIT
; -- variable length records only good up to 255 char)
IF XWBPTYPE=6 SET I="" FOR SET I=$O(XWBR(I)) QUIT:I="" DO WRITE^XWBRL($C($L(XWBR(I)))),WRITE^XWBRL(XWBR(I))
QUIT
;
ERROR(CODE,RPCURI,MSG) ; -- send rpc application error
DO PRE^XWBRL
DO WRITE^XWBRL($$XMLHDR^XWBUTL())
DO WRITE^XWBRL("<vistalink type=""VA.RPC.Error"" >")
DO WRITE^XWBRL("<errors>")
DO WRITE^XWBRL("<error code="""_CODE_""" uri="""_$G(RPCURI)_""" >")
DO WRITE^XWBRL("<msg>"_$G(MSG)_"</msg>")
DO WRITE^XWBRL("</error>")
DO WRITE^XWBRL("</errors>")
DO WRITE^XWBRL("</vistalink>")
; -- send eot and flush buffer
DO POST^XWBRL
QUIT
;
; ---------------------------------------------------------------------
; RPC Server: Request Message XML SAX Parser Callbacks
; ---------------------------------------------------------------------
ELEST(ELE,ATR) ; -- element start event handler
IF ELE="vistalink" KILL XWBSESS,XWBPARAM,XWBPN,XWBPTYPE QUIT
;
IF ELE="rpc" SET XWBDATA("URI")=$$ESC^XWBRMX($G(ATR("uri"),"##Unkown RPC##")) QUIT
;
IF ELE="param" DO QUIT
. SET XWBPARAM=1
. SET XWBPN="XWBP"_ATR("position")
. SET XWBDATA("PARAMS",ATR("position"))=XWBPN
. SET XWBPTYPE=ATR("type")
. S XWBCHRST="" ;To accumulate char
;
IF ELE="index" DO QUIT
. ;SET @XWBPN@($$ESC^XWBRMX(ATR("name")))=$$ESC^XWBRMX(ATR("value"))
. S XWBPN("name")=$$ESC^XWBRMX(ATR("name")) ;rwf
. S XWBCHRST=""
;
QUIT
;
ELEND(ELE) ; -- element end event handler
IF ELE="vistalink" KILL XWBPOS,XWBSESS,XWBPARAM,XWBPN,XWBPTYPE,XWBCHRST QUIT
;
IF ELE="params" DO QUIT
. NEW POS,PARAMS
. SET PARAMS="",POS=0
. FOR SET POS=$O(XWBDATA("PARAMS",POS)) Q:'POS SET PARAMS=PARAMS_",."_XWBDATA("PARAMS",POS)
. SET XWBDATA("PARAMS")=PARAMS
;
IF ELE="param" D Q
. I $G(XWBDEBUG),$D(XWBPN),$D(@XWBPN) D LOG(.@XWBPN)
. KILL XWBPARAM,XWBCHRST
;
QUIT
;
;This can be called more than once for one TEXT string.
CHR(TEXT) ; -- character value event handler <tag>TEXT</tag)
;
IF $G(XWBPARAM) DO
. ;What to do if string gets too long?
. ;IF XWBPTYPE="string" SET XWBCHRST=XWBCHRST_$$ESC^XWBRMX(TEXT),@XWBPN=XWBCHRST QUIT
. IF XWBPTYPE="string" SET XWBCHRST=XWBCHRST_TEXT,@XWBPN=XWBCHRST QUIT
. ;IF XWBPTYPE="ref" SET @XWBPN=$G(@$$ESC^XWBRMX(TEXT)) QUIT
. IF XWBPTYPE="ref" SET XWBCHRST=XWBCHRST_TEXT,@XWBPN=@XWBCHRST QUIT
. I XWBPTYPE="array" S XWBCHRST=XWBCHRST_TEXT,@XWBPN@(XWBPN("name"))=XWBCHRST Q ;rwf
QUIT
;
; ---------------------------------------------------------------------
; Parse Results of Successful Legacy RPC Request
; ---------------------------------------------------------------------
;
; [Public/Supported Method]
PARSE(XWBPARMS,XWBY) ; -- parse legacy rpc results ; uses SAX parser
NEW XWBCHK,XWBOPT,XWBTYPE,XWBCNT
;
;**M2M Result will go here.
I XWBY="" D
.IF $G(XWBY)="" SET XWBY=$NA(^TMP("XWBM2MRPC",$J,"RESULTS"))
.SET XWBYX=XWBY
.KILL @XWBYX
;
DO SET
SET XWBOPT=""
DO EN^MXMLPRSE(XWBPARMS("RESULTS"),.XWBCBK,.XWBOPT)
Q
;
SET ; -- set the event interface entry points ;
SET XWBCBK("STARTELEMENT")="RESELEST^XWBRPC"
SET XWBCBK("ENDELEMENT")="RESELEND^XWBRPC"
SET XWBCBK("CHARACTERS")="RESCHR^XWBRPC"
QUIT
;
RESELEST(ELE,ATR) ; -- element start event handler
IF ELE="results" SET XWBTYPE=$G(ATR("type")),XWBCNT=0
QUIT
;
RESELEND(ELE) ; -- element end event handler
KILL XWBCNT,XWBTYPE
QUIT
;
RESCHR(TEXT) ; -- character value event handler
QUIT:$G(XWBTYPE)=""
QUIT:'$L(TEXT) ; -- Sometimes sends in empty string
;
IF XWBCNT=0,TEXT=$C(10) QUIT ; -- bug in parser? always starts with $C(10)
;
IF XWBTYPE="string" DO QUIT
. SET XWBCNT=XWBCNT+1
. SET @XWBY@(XWBCNT)=TEXT
;
IF XWBTYPE="array" DO
. SET XWBCNT=XWBCNT+1
. SET @XWBY@(XWBCNT)=$P(TEXT,$C(10))
QUIT
;
PARSEX(XWBPARMS,XWBY) ; -- parse legacy rpc results ; uses DOM parser
NEW XWBDOM
SET XWBDOM=$$EN^MXMLDOM(XWBPARMS("RESULTS"),"")
DO TEXT^MXMLDOM(XWBDOM,2,XWBY)
DO DELETE^MXMLDOM(XWBDOM)
QUIT
;
LOG(MSG) ;Debug log
N CNT
S CNT=$G(^TMP("XWBM2ML",$J))+1,^($J)=CNT
M ^TMP("XWBM2ML",$J,CNT)=MSG
Q
;
; -------------------------------------------------------------------
; Response Format Documentation
; -------------------------------------------------------------------
;
;
; [ Sample XML produced by a successful call of EN^XWBRPC(.XWBPARMS).
; SEND^XWBRPC does the actual work to produce response. ]
;
; <?xml version="1.0" encoding="utf-8" ?>
; <vistalink type="Gov.VA.Med.RPC.Response" >
; <results type="array" >
; <![CDATA[4261;;2961001.08^2^274^166^105^^2961001.1123^1^^9^2^8^10^^^^^^^10G1-ALN
; 4270;;2961002.08^2^274^166^112^^^1^^9^2^8^10^^^^^^^10G8-ALN
; 4274;;2961003.08^2^274^166^116^^^1^^9^2^8^10^^^^^^^10GD-ALN
; 4340;;2961117.08^2^274^166^182^^2961118.1425^1^^9^2^8^10^^^^^^^10K0-ALN
; 4342;;2961108.13^2^108^207^183^^2961118.1546^1^^9^2^8^10^^^^^^^10K2-ALN
; 6394;;3000607.084^2^165^68^6479^^3000622.13^1^^9^1^8^10^^^^^^^197M-ALN]]>
; </results>
; </vistalink>
;
; -------------------------------------------------------------------
;
; [ Sample XML produced by a unsuccessful call of EN^XWBRPC(.XWBPARMS).
; ERROR^XWBRPC does the actual work to produce response. ]
;
; <?xml version="1.0" encoding="utf-8" ?>
; <vistalink type="Gov.VA..Med.RPC.Error" >
; <errors>
; <error code="2" uri="XWB BAD NAME" >
; <msg>
; Remote Procedure Unknown: 'XWB BAD NAME' cannot be found.
; </msg>
; </error>
; </errors>
; </vistalink>
;
; -------------------------------------------------------------------
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBRPC 9931 printed Oct 16, 2024@18:38 Page 2
XWBRPC ;OIFO-Oakland/REM - M2M Broker Server MRH ;08/20/2002 12:13
+1 ;;1.1;RPC BROKER;**28,34**;Mar 28, 1997
+2 ;
+3 QUIT
+4 ;
+5 ; ---------------------------------------------------------------------
+6 ; RPC Server: Message Request Handler (MRH)
+7 ; ---------------------------------------------------------------------
+8 ;
+9 ;p34 -added $$CHARCHK^XWBUTL before writing to WRITE^XWBRL to escape CR - PROCESS.
+10 ; -remove $C(13). CR were not being stripped out in result - PROCESS.
+11 ;
+12 ;
EN(XWBDATA) ; -- handle parsed messages request
+1 NEW RPC0,RPCURI,RPCIEN,TAG,ROU,METHSIG,XWBR
+2 ;
+3 IF $GET(XWBDATA("URI"))=""
Begin DoDot:1
+4 DO ERROR(1,"NONE","No Remote Procedure Specified.")
End DoDot:1
GOTO ENQ
+5 ;
+6 SET RPCURI=XWBDATA("URI")
+7 ;
+8 SET U="^"
+9 ;May want to build/call common broker api for RPC lookup. See XWBBRK
+10 SET RPCIEN=$ORDER(^XWB(8994,"B",RPCURI,""))
+11 IF RPCIEN'>0
Begin DoDot:1
+12 DO ERROR(2,RPCURI,"Remote Procedure Unknown: "_RPCURI_" cannot be found.")
+13 ;Write error in TMP **M2M
DO ERROR^XWBM2MC(7)
End DoDot:1
GOTO ENQ
+14 ;
+15 SET RPC0=$GET(^XWB(8994,RPCIEN,0))
+16 IF RPC0=""
Begin DoDot:1
+17 DO ERROR(3,RPCURI,"Remote Procedure Blank: '"_RPCURI_"' contains no information.")
End DoDot:1
GOTO ENQ
+18 ;
+19 SET RPCURI=$PIECE(RPC0,U)
+20 SET TAG=$PIECE(RPC0,U,2)
+21 SET ROU=$PIECE(RPC0,U,3)
+22 ;
+23 ; -- check inactive flag
+24 IF $PIECE(RPC0,U,6)=1!($PIECE(RPC0,U,6)=2)
Begin DoDot:1
+25 DO ERROR(4,RPCURI,"Remote Procedure InActive: '"_RPCURI_"' cannot be run at this time.")
End DoDot:1
GOTO ENQ
+26 ;
+27 SET XWBPTYPE=$PIECE(RPC0,U,4)
+28 SET XWBWRAP=$PIECE(RPC0,U,8)
+29 ;
+30 ; -- build method signature and call rpc
+31 SET METHSIG=TAG_"^"_ROU_"(.XWBR"_$GET(XWBDATA("PARAMS"))_")"
+32 ;
+33 IF $GET(XWBDEBUG)
DO LOG(METHSIG)
+34 ;See that the NULL device is current
+35 DO @METHSIG
+36 ;
+37 ; -- send results
+38 ;**M2M use server IO
DO USE^%ZISUTL("XWBM2M SERVER")
USE IO
+39 ;
+40 IF $GET(XWBDEBUG)
DO LOG(.XWBR)
+41 DO SEND(.XWBR)
+42 ;
ENQ ; -- end message handler
+1 DO CLEAN
+2 ;
+3 QUIT
+4 ;
CLEAN ; -- clean up message handler environment
+1 NEW POS
+2 ; -- kill parameters
+3 SET POS=0
+4 FOR
SET POS=$ORDER(XWBDATA("PARAMS",POS))
if 'POS
QUIT
KILL @XWBDATA("PARAMS",POS)
+5 QUIT
+6 ;
SEND(XWBR) ; -- stream rpc data to client
+1 NEW XWBFMT,XWBFILL
+2 SET XWBFMT=$$GETFMT()
+3 ; -- prepare socket for writing
+4 DO PRE^XWBRL
+5 ; -- initialize
+6 DO WRITE^XWBRL($$XMLHDR^XWBUTL())
+7 ;DO DOCTYPE
+8 DO WRITE^XWBRL("<vistalink type=""Gov.VA.Med.RPC.Response"" ><results type="""_XWBFMT_""" ><![CDATA[")
+9 ; -- results
+10 DO PROCESS
+11 ; -- finalize
+12 DO WRITE^XWBRL("]]></results></vistalink>")
+13 ; -- send eot and flush buffer
+14 DO POST^XWBRL
+15 ;
+16 QUIT
+17 ;
DOCTYPE ;
+1 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) >]>")
+2 QUIT
+3 ;
GETFMT() ; -- determine response format type
+1 IF XWBPTYPE=1!(XWBPTYPE=5)!(XWBPTYPE=6)
QUIT "string"
+2 IF XWBPTYPE=2
QUIT "array"
+3 ;
+4 QUIT $SELECT(XWBWRAP:"array",1:"string")
+5 ;
PROCESS ; -- send the real results
+1 NEW I,T,DEL,V
+2 ;
+3 ;*p34-Remove $C(13). CR were not being stripped out in results to escape CR.
+4 ;S DEL=$S(XWBMODE="RPCBroker":$C(13,10),1:$C(10))
+5 SET DEL=$SELECT(XWBMODE="RPCBroker":$CHAR(10),1:$CHAR(10))
+6 ;
+7 ;*p34-When write XWBR, go thru $$CHARCHK^XWBUTL first.
+8 ; -- single value
+9 IF XWBPTYPE=1
SET XWBR=$GET(XWBR)
DO WRITE^XWBRL($$CHARCHK^XWBUTL($GET(XWBR)))
QUIT
+10 ; -- table delimited by CR+LF - ARRAY
+11 IF XWBPTYPE=2
Begin DoDot:1
+12 SET I=""
FOR
SET I=$ORDER(XWBR(I))
if I=""
QUIT
DO WRITE^XWBRL($$CHARCHK^XWBUTL($GET(XWBR(I))))
DO WRITE^XWBRL(DEL)
End DoDot:1
QUIT
+13 ; -- word processing
+14 IF XWBPTYPE=3
Begin DoDot:1
+15 SET I=""
FOR
SET I=$ORDER(XWBR(I))
if I=""
QUIT
DO WRITE^XWBRL($$CHARCHK^XWBUTL($GET(XWBR(I))))
if XWBWRAP
DO WRITE^XWBRL(DEL)
End DoDot:1
QUIT
+16 ; -- global array
+17 IF XWBPTYPE=4
Begin DoDot:1
+18 SET I=$GET(XWBR)
if I=""
QUIT
SET T=$EXTRACT(I,1,$LENGTH(I)-1)
+19 IF $DATA(@I)>10
SET V=@I
DO WRITE^XWBRL($$CHARCHK^XWBUTL($GET(V)))
+20 FOR
SET I=$QUERY(@I)
if I=""!(I'[T)
QUIT
SET V=@I
DO WRITE^XWBRL($$CHARCHK^XWBUTL($GET(V)))
if XWBWRAP&(V'=DEL)
DO WRITE^XWBRL(DEL)
+21 IF $DATA(@XWBR)
KILL @XWBR
End DoDot:1
QUIT
+22 ; -- global instance
+23 IF XWBPTYPE=5
SET XWBR=$GET(@XWBR)
DO WRITE^XWBRL($$CHARCHK^XWBUTL($GET(XWBR)))
QUIT
+24 ; -- variable length records only good up to 255 char)
+25 IF XWBPTYPE=6
SET I=""
FOR
SET I=$ORDER(XWBR(I))
if I=""
QUIT
DO WRITE^XWBRL($CHAR($LENGTH(XWBR(I))))
DO WRITE^XWBRL(XWBR(I))
+26 QUIT
+27 ;
ERROR(CODE,RPCURI,MSG) ; -- send rpc application error
+1 DO PRE^XWBRL
+2 DO WRITE^XWBRL($$XMLHDR^XWBUTL())
+3 DO WRITE^XWBRL("<vistalink type=""VA.RPC.Error"" >")
+4 DO WRITE^XWBRL("<errors>")
+5 DO WRITE^XWBRL("<error code="""_CODE_""" uri="""_$GET(RPCURI)_""" >")
+6 DO WRITE^XWBRL("<msg>"_$GET(MSG)_"</msg>")
+7 DO WRITE^XWBRL("</error>")
+8 DO WRITE^XWBRL("</errors>")
+9 DO WRITE^XWBRL("</vistalink>")
+10 ; -- send eot and flush buffer
+11 DO POST^XWBRL
+12 QUIT
+13 ;
+14 ; ---------------------------------------------------------------------
+15 ; RPC Server: Request Message XML SAX Parser Callbacks
+16 ; ---------------------------------------------------------------------
ELEST(ELE,ATR) ; -- element start event handler
+1 IF ELE="vistalink"
KILL XWBSESS,XWBPARAM,XWBPN,XWBPTYPE
QUIT
+2 ;
+3 IF ELE="rpc"
SET XWBDATA("URI")=$$ESC^XWBRMX($GET(ATR("uri"),"##Unkown RPC##"))
QUIT
+4 ;
+5 IF ELE="param"
Begin DoDot:1
+6 SET XWBPARAM=1
+7 SET XWBPN="XWBP"_ATR("position")
+8 SET XWBDATA("PARAMS",ATR("position"))=XWBPN
+9 SET XWBPTYPE=ATR("type")
+10 ;To accumulate char
SET XWBCHRST=""
End DoDot:1
QUIT
+11 ;
+12 IF ELE="index"
Begin DoDot:1
+13 ;SET @XWBPN@($$ESC^XWBRMX(ATR("name")))=$$ESC^XWBRMX(ATR("value"))
+14 ;rwf
SET XWBPN("name")=$$ESC^XWBRMX(ATR("name"))
+15 SET XWBCHRST=""
End DoDot:1
QUIT
+16 ;
+17 QUIT
+18 ;
ELEND(ELE) ; -- element end event handler
+1 IF ELE="vistalink"
KILL XWBPOS,XWBSESS,XWBPARAM,XWBPN,XWBPTYPE,XWBCHRST
QUIT
+2 ;
+3 IF ELE="params"
Begin DoDot:1
+4 NEW POS,PARAMS
+5 SET PARAMS=""
SET POS=0
+6 FOR
SET POS=$ORDER(XWBDATA("PARAMS",POS))
if 'POS
QUIT
SET PARAMS=PARAMS_",."_XWBDATA("PARAMS",POS)
+7 SET XWBDATA("PARAMS")=PARAMS
End DoDot:1
QUIT
+8 ;
+9 IF ELE="param"
Begin DoDot:1
+10 IF $GET(XWBDEBUG)
IF $DATA(XWBPN)
IF $DATA(@XWBPN)
DO LOG(.@XWBPN)
+11 KILL XWBPARAM,XWBCHRST
End DoDot:1
QUIT
+12 ;
+13 QUIT
+14 ;
+15 ;This can be called more than once for one TEXT string.
CHR(TEXT) ; -- character value event handler <tag>TEXT</tag)
+1 ;
+2 IF $GET(XWBPARAM)
Begin DoDot:1
+3 ;What to do if string gets too long?
+4 ;IF XWBPTYPE="string" SET XWBCHRST=XWBCHRST_$$ESC^XWBRMX(TEXT),@XWBPN=XWBCHRST QUIT
+5 IF XWBPTYPE="string"
SET XWBCHRST=XWBCHRST_TEXT
SET @XWBPN=XWBCHRST
QUIT
+6 ;IF XWBPTYPE="ref" SET @XWBPN=$G(@$$ESC^XWBRMX(TEXT)) QUIT
+7 IF XWBPTYPE="ref"
SET XWBCHRST=XWBCHRST_TEXT
SET @XWBPN=@XWBCHRST
QUIT
+8 ;rwf
IF XWBPTYPE="array"
SET XWBCHRST=XWBCHRST_TEXT
SET @XWBPN@(XWBPN("name"))=XWBCHRST
QUIT
End DoDot:1
+9 QUIT
+10 ;
+11 ; ---------------------------------------------------------------------
+12 ; Parse Results of Successful Legacy RPC Request
+13 ; ---------------------------------------------------------------------
+14 ;
+15 ; [Public/Supported Method]
PARSE(XWBPARMS,XWBY) ; -- parse legacy rpc results ; uses SAX parser
+1 NEW XWBCHK,XWBOPT,XWBTYPE,XWBCNT
+2 ;
+3 ;**M2M Result will go here.
+4 IF XWBY=""
Begin DoDot:1
+5 IF $GET(XWBY)=""
SET XWBY=$NAME(^TMP("XWBM2MRPC",$JOB,"RESULTS"))
+6 SET XWBYX=XWBY
+7 KILL @XWBYX
End DoDot:1
+8 ;
+9 DO SET
+10 SET XWBOPT=""
+11 DO EN^MXMLPRSE(XWBPARMS("RESULTS"),.XWBCBK,.XWBOPT)
+12 QUIT
+13 ;
SET ; -- set the event interface entry points ;
+1 SET XWBCBK("STARTELEMENT")="RESELEST^XWBRPC"
+2 SET XWBCBK("ENDELEMENT")="RESELEND^XWBRPC"
+3 SET XWBCBK("CHARACTERS")="RESCHR^XWBRPC"
+4 QUIT
+5 ;
RESELEST(ELE,ATR) ; -- element start event handler
+1 IF ELE="results"
SET XWBTYPE=$GET(ATR("type"))
SET XWBCNT=0
+2 QUIT
+3 ;
RESELEND(ELE) ; -- element end event handler
+1 KILL XWBCNT,XWBTYPE
+2 QUIT
+3 ;
RESCHR(TEXT) ; -- character value event handler
+1 if $GET(XWBTYPE)=""
QUIT
+2 ; -- Sometimes sends in empty string
if '$LENGTH(TEXT)
QUIT
+3 ;
+4 ; -- bug in parser? always starts with $C(10)
IF XWBCNT=0
IF TEXT=$CHAR(10)
QUIT
+5 ;
+6 IF XWBTYPE="string"
Begin DoDot:1
+7 SET XWBCNT=XWBCNT+1
+8 SET @XWBY@(XWBCNT)=TEXT
End DoDot:1
QUIT
+9 ;
+10 IF XWBTYPE="array"
Begin DoDot:1
+11 SET XWBCNT=XWBCNT+1
+12 SET @XWBY@(XWBCNT)=$PIECE(TEXT,$CHAR(10))
End DoDot:1
+13 QUIT
+14 ;
PARSEX(XWBPARMS,XWBY) ; -- parse legacy rpc results ; uses DOM parser
+1 NEW XWBDOM
+2 SET XWBDOM=$$EN^MXMLDOM(XWBPARMS("RESULTS"),"")
+3 DO TEXT^MXMLDOM(XWBDOM,2,XWBY)
+4 DO DELETE^MXMLDOM(XWBDOM)
+5 QUIT
+6 ;
LOG(MSG) ;Debug log
+1 NEW CNT
+2 SET CNT=$GET(^TMP("XWBM2ML",$JOB))+1
SET ^($JOB)=CNT
+3 MERGE ^TMP("XWBM2ML",$JOB,CNT)=MSG
+4 QUIT
+5 ;
+6 ; -------------------------------------------------------------------
+7 ; Response Format Documentation
+8 ; -------------------------------------------------------------------
+9 ;
+10 ;
+11 ; [ Sample XML produced by a successful call of EN^XWBRPC(.XWBPARMS).
+12 ; SEND^XWBRPC does the actual work to produce response. ]
+13 ;
+14 ; <?xml version="1.0" encoding="utf-8" ?>
+15 ; <vistalink type="Gov.VA.Med.RPC.Response" >
+16 ; <results type="array" >
+17 ; <![CDATA[4261;;2961001.08^2^274^166^105^^2961001.1123^1^^9^2^8^10^^^^^^^10G1-ALN
+18 ; 4270;;2961002.08^2^274^166^112^^^1^^9^2^8^10^^^^^^^10G8-ALN
+19 ; 4274;;2961003.08^2^274^166^116^^^1^^9^2^8^10^^^^^^^10GD-ALN
+20 ; 4340;;2961117.08^2^274^166^182^^2961118.1425^1^^9^2^8^10^^^^^^^10K0-ALN
+21 ; 4342;;2961108.13^2^108^207^183^^2961118.1546^1^^9^2^8^10^^^^^^^10K2-ALN
+22 ; 6394;;3000607.084^2^165^68^6479^^3000622.13^1^^9^1^8^10^^^^^^^197M-ALN]]>
+23 ; </results>
+24 ; </vistalink>
+25 ;
+26 ; -------------------------------------------------------------------
+27 ;
+28 ; [ Sample XML produced by a unsuccessful call of EN^XWBRPC(.XWBPARMS).
+29 ; ERROR^XWBRPC does the actual work to produce response. ]
+30 ;
+31 ; <?xml version="1.0" encoding="utf-8" ?>
+32 ; <vistalink type="Gov.VA..Med.RPC.Error" >
+33 ; <errors>
+34 ; <error code="2" uri="XWB BAD NAME" >
+35 ; <msg>
+36 ; Remote Procedure Unknown: 'XWB BAD NAME' cannot be found.
+37 ; </msg>
+38 ; </error>
+39 ; </errors>
+40 ; </vistalink>
+41 ;
+42 ; -------------------------------------------------------------------
+43 ;
