Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XWBRPC

XWBRPC.m

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