- XOBVRPCI ;; ld,mjk/alb - VistaLink Interface Implementation for RPCs; 07/27/2002 13:00
- ;;1.6;VistALink;;May 08, 2009;Build 15
- ;Per VHA directive 2004-038, this routine should not be modified.
- ;
- CALLBACK(CB) ; -- init callbacks implementation
- SET CB("STARTELEMENT")="ELEST^XOBVRPCI"
- SET CB("ENDELEMENT")="ELEND^XOBVRPCI"
- SET CB("CHARACTERS")="CHR^XOBVRPCI"
- QUIT
- ;
- READER(XOBUF,XOBDATA) ; -- proprietary format reader implementation
- DO START^XOBVRPCX(.XOBUF,.XOBDATA)
- QUIT
- ;
- REQHDLR(XOBDATA) ; -- request handler implementation
- DO EN^XOBVRPC(.XOBDATA)
- QUIT
- ;
- ; ------------------------------------------------------------------------
- ; RPC Server: Request Message XML SAX Parser Callbacks
- ; ------------------------------------------------------------------------
- ELEST(ELE,ATR) ; -- element start event handler
- IF ELE="VistaLink" DO QUIT
- . KILL XOBPARAM,XOBCTXT,XOBPN,XOBPTYPE
- . ; -- if called from VL v1.0 client then set up J2SE defaults
- . IF $GET(XOBDATA("VL VERSION"))="1.0" DO V1^XOBVRPCX
- ;
- IF ELE="RpcHandler" SET XOBDATA("XOB RPC","RPC HANDLER VERSION")=$GET(ATR("version")) QUIT
- ;
- IF ELE="Request" DO QUIT
- . SET XOBDATA("XOB RPC","RPC NAME")=$$ESC^XOBVRMX($GET(ATR("rpcName"),"##Unkown RPC##"))
- . NEW X
- . SET X=$$SETTO^XOBVLIB($GET(ATR("rpcClientTimeOut"),9000))
- . SET X=$$SETVER^XOBVRPCX($GET(ATR("rpcVersion"),0))
- ;
- IF ELE="RpcContext" SET XOBCTXT="" QUIT
- ;
- ; -------------------- Param Node Start Event Processing ---------------------------
- ;
- IF ELE="Param" DO QUIT
- . SET XOBPARAM=""
- . SET XOBPN="XOBP"_ATR("position")
- . SET XOBDATA("XOB RPC","PARAMS",ATR("position"))=XOBPN
- . SET XOBPTYPE=ATR("type")
- . SET:XOBPTYPE="array" @XOBPN=""
- ;
- IF ELE="Index" DO QUIT
- . KILL XOBPARAM
- . IF $DATA(ATR("name"))&$DATA(ATR("value")) DO
- . . SET @XOBPN@($$ESC^XOBVRMX(ATR("name")))=$$ESC^XOBVRMX(ATR("value"))
- ;
- IF ELE="Name" DO QUIT
- . SET XOBPARNM=""
- ;
- IF ELE="Value" DO QUIT
- . SET XOBPARVL=""
- ;
- ; -------------------- Security Node Start Event Processing ---------------------------
- ;
- IF ELE="Security" DO QUIT
- . SET XOBDATA("XOB RPC","SECURITY","TYPE")=$GET(ATR("type"))
- . SET XOBDATA("XOB RPC","SECURITY","DIV")=$GET(ATR("division"))
- . SET XOBDATA("XOB RPC","SECURITY","STATE")=$GET(ATR("state"),"notauthenticated")
- . KILL XOBSECFL
- . ;
- . ; -- use to make sure child nodes are from Security
- . ; parent when processing child node names
- . SET XOBSECFL=1
- ;
- IF ELE="AccessVerify",$GET(XOBSECFL),$EXTRACT($GET(XOBDATA("XOB RPC","SECURITY","TYPE")),1,2)="av" DO QUIT
- . SET XOBAVCOD=""
- ;
- IF ELE="KernelCcowToken",$GET(XOBSECFL),$GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="ccow" DO QUIT
- . SET XOBCCOWT=""
- ;
- IF ELE="Duz",$GET(XOBSECFL),$GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="duz" DO QUIT
- . SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$GET(ATR("value"))
- ;
- IF ELE="Vpid",$GET(XOBSECFL),$GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="vpid" DO QUIT
- . SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$GET(ATR("value"))
- ;
- IF ELE="ApplicationProxyName",$GET(XOBSECFL),$GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="appproxy" DO QUIT
- . SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$GET(ATR("value"))
- ;
- ; ---------------------------------------------------------------------------
- ;
- QUIT
- ;
- ELEND(ELE) ; -- element end event handler
- IF ELE="VistaLink" DO QUIT
- . SET XOBDATA("MODE")=$GET(ATR("mode"),"singleton")
- . KILL XOBPOS,XOBPARAM,XOBCTXT,XOBPN,XOBPTYPE
- ;
- IF ELE="RpcContext" DO QUIT
- . SET XOBDATA("XOB RPC","RPC CONTEXT")=$GET(XOBCTXT)
- ;
- IF ELE="Param" DO KILL XOBPARAM QUIT
- . IF XOBPTYPE="string" SET @XOBPN=$$ESC^XOBVRMX(XOBPARAM) QUIT
- . IF XOBPTYPE="ref" SET @XOBPN=$GET(@$$ESC^XOBVRMX(XOBPARAM)) QUIT
- ;
- IF ELE="Params" DO QUIT
- . NEW POS,PARAMS
- . SET PARAMS="",POS=0
- . FOR SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS)) QUIT:'POS SET PARAMS=PARAMS_",."_XOBDATA("XOB RPC","PARAMS",POS)
- . SET XOBDATA("XOB RPC","PARAMS")=PARAMS
- ;
- IF ELE="Index" DO QUIT
- . IF $DATA(XOBPARNM)&$DATA(XOBPARVL) DO
- . . KILL XOBPARAM
- . . IF $EXTRACT(XOBPARNM,1)=$CHAR(13) DO
- . . . SET @("@XOBPN@("_$$ESC^XOBVRMX($EXTRACT(XOBPARNM,2,$LENGTH(XOBPARNM)))_")=$$ESC^XOBVRMX(XOBPARVL)")
- . . ELSE DO
- . . . SET @XOBPN@($$ESC^XOBVRMX(XOBPARNM))=$$ESC^XOBVRMX(XOBPARVL)
- . . KILL XOBPARNM,XOBPARVL
- ;
- IF ELE="Name" DO QUIT
- . SET XOBPARNM("DONE")=1
- ;
- IF ELE="Value" DO QUIT
- . SET XOBPARVL("DONE")=1
- ;
- IF ELE="AccessVerify",$GET(XOBSECFL),$EXTRACT($GET(XOBDATA("XOB RPC","SECURITY","TYPE")),1,2)="av" DO QUIT
- . SET XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE")=XOBAVCOD KILL XOBAVCOD
- IF ELE="KernelCcowToken",$GET(XOBSECFL),$GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="ccow" DO QUIT
- . SET XOBDATA("XOB RPC","SECURITY","TYPE","CCOW")=XOBCCOWT KILL XOBCCOWT
- IF ELE="Security" KILL XOBSECFL QUIT
- ;
- QUIT
- ;
- CHR(TEXT) ; -- character value event handler <tag>TEXT</tag)
- ; -- need to concatenate because MXML parses on ENTITY characters (<>& etc.) and
- ; callback gets hit multiple times even though the tag text value is just one piece of data.
- ; (Yes, this seems kludgie!)
- IF $DATA(XOBPARAM) SET XOBPARAM=XOBPARAM_TEXT
- IF $DATA(XOBPARNM),'+$GET(XOBPARNM("DONE")) SET XOBPARNM=XOBPARNM_TEXT QUIT
- IF $DATA(XOBPARVL),'+$GET(XOBPARVL("DONE")) SET XOBPARVL=XOBPARVL_TEXT QUIT
- IF $DATA(XOBCTXT) SET XOBCTXT=XOBCTXT_TEXT QUIT
- IF $DATA(XOBAVCOD) SET XOBAVCOD=XOBAVCOD_TEXT QUIT
- IF $DATA(XOBCCOWT) SET XOBCCOWT=XOBCCOWT_TEXT QUIT
- QUIT
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVRPCI 5615 printed Feb 19, 2025@00:11:23 Page 2
- XOBVRPCI ;; ld,mjk/alb - VistaLink Interface Implementation for RPCs; 07/27/2002 13:00
- +1 ;;1.6;VistALink;;May 08, 2009;Build 15
- +2 ;Per VHA directive 2004-038, this routine should not be modified.
- +3 ;
- CALLBACK(CB) ; -- init callbacks implementation
- +1 SET CB("STARTELEMENT")="ELEST^XOBVRPCI"
- +2 SET CB("ENDELEMENT")="ELEND^XOBVRPCI"
- +3 SET CB("CHARACTERS")="CHR^XOBVRPCI"
- +4 QUIT
- +5 ;
- READER(XOBUF,XOBDATA) ; -- proprietary format reader implementation
- +1 DO START^XOBVRPCX(.XOBUF,.XOBDATA)
- +2 QUIT
- +3 ;
- REQHDLR(XOBDATA) ; -- request handler implementation
- +1 DO EN^XOBVRPC(.XOBDATA)
- +2 QUIT
- +3 ;
- +4 ; ------------------------------------------------------------------------
- +5 ; RPC Server: Request Message XML SAX Parser Callbacks
- +6 ; ------------------------------------------------------------------------
- ELEST(ELE,ATR) ; -- element start event handler
- +1 IF ELE="VistaLink"
- Begin DoDot:1
- +2 KILL XOBPARAM,XOBCTXT,XOBPN,XOBPTYPE
- +3 ; -- if called from VL v1.0 client then set up J2SE defaults
- +4 IF $GET(XOBDATA("VL VERSION"))="1.0"
- DO V1^XOBVRPCX
- End DoDot:1
- QUIT
- +5 ;
- +6 IF ELE="RpcHandler"
- SET XOBDATA("XOB RPC","RPC HANDLER VERSION")=$GET(ATR("version"))
- QUIT
- +7 ;
- +8 IF ELE="Request"
- Begin DoDot:1
- +9 SET XOBDATA("XOB RPC","RPC NAME")=$$ESC^XOBVRMX($GET(ATR("rpcName"),"##Unkown RPC##"))
- +10 NEW X
- +11 SET X=$$SETTO^XOBVLIB($GET(ATR("rpcClientTimeOut"),9000))
- +12 SET X=$$SETVER^XOBVRPCX($GET(ATR("rpcVersion"),0))
- End DoDot:1
- QUIT
- +13 ;
- +14 IF ELE="RpcContext"
- SET XOBCTXT=""
- QUIT
- +15 ;
- +16 ; -------------------- Param Node Start Event Processing ---------------------------
- +17 ;
- +18 IF ELE="Param"
- Begin DoDot:1
- +19 SET XOBPARAM=""
- +20 SET XOBPN="XOBP"_ATR("position")
- +21 SET XOBDATA("XOB RPC","PARAMS",ATR("position"))=XOBPN
- +22 SET XOBPTYPE=ATR("type")
- +23 if XOBPTYPE="array"
- SET @XOBPN=""
- End DoDot:1
- QUIT
- +24 ;
- +25 IF ELE="Index"
- Begin DoDot:1
- +26 KILL XOBPARAM
- +27 IF $DATA(ATR("name"))&$DATA(ATR("value"))
- Begin DoDot:2
- +28 SET @XOBPN@($$ESC^XOBVRMX(ATR("name")))=$$ESC^XOBVRMX(ATR("value"))
- End DoDot:2
- End DoDot:1
- QUIT
- +29 ;
- +30 IF ELE="Name"
- Begin DoDot:1
- +31 SET XOBPARNM=""
- End DoDot:1
- QUIT
- +32 ;
- +33 IF ELE="Value"
- Begin DoDot:1
- +34 SET XOBPARVL=""
- End DoDot:1
- QUIT
- +35 ;
- +36 ; -------------------- Security Node Start Event Processing ---------------------------
- +37 ;
- +38 IF ELE="Security"
- Begin DoDot:1
- +39 SET XOBDATA("XOB RPC","SECURITY","TYPE")=$GET(ATR("type"))
- +40 SET XOBDATA("XOB RPC","SECURITY","DIV")=$GET(ATR("division"))
- +41 SET XOBDATA("XOB RPC","SECURITY","STATE")=$GET(ATR("state"),"notauthenticated")
- +42 KILL XOBSECFL
- +43 ;
- +44 ; -- use to make sure child nodes are from Security
- +45 ; parent when processing child node names
- +46 SET XOBSECFL=1
- End DoDot:1
- QUIT
- +47 ;
- +48 IF ELE="AccessVerify"
- IF $GET(XOBSECFL)
- IF $EXTRACT($GET(XOBDATA("XOB RPC","SECURITY","TYPE")),1,2)="av"
- Begin DoDot:1
- +49 SET XOBAVCOD=""
- End DoDot:1
- QUIT
- +50 ;
- +51 IF ELE="KernelCcowToken"
- IF $GET(XOBSECFL)
- IF $GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="ccow"
- Begin DoDot:1
- +52 SET XOBCCOWT=""
- End DoDot:1
- QUIT
- +53 ;
- +54 IF ELE="Duz"
- IF $GET(XOBSECFL)
- IF $GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="duz"
- Begin DoDot:1
- +55 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$GET(ATR("value"))
- End DoDot:1
- QUIT
- +56 ;
- +57 IF ELE="Vpid"
- IF $GET(XOBSECFL)
- IF $GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="vpid"
- Begin DoDot:1
- +58 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$GET(ATR("value"))
- End DoDot:1
- QUIT
- +59 ;
- +60 IF ELE="ApplicationProxyName"
- IF $GET(XOBSECFL)
- IF $GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="appproxy"
- Begin DoDot:1
- +61 SET XOBDATA("XOB RPC","SECURITY","TYPE","VALUE")=$GET(ATR("value"))
- End DoDot:1
- QUIT
- +62 ;
- +63 ; ---------------------------------------------------------------------------
- +64 ;
- +65 QUIT
- +66 ;
- ELEND(ELE) ; -- element end event handler
- +1 IF ELE="VistaLink"
- Begin DoDot:1
- +2 SET XOBDATA("MODE")=$GET(ATR("mode"),"singleton")
- +3 KILL XOBPOS,XOBPARAM,XOBCTXT,XOBPN,XOBPTYPE
- End DoDot:1
- QUIT
- +4 ;
- +5 IF ELE="RpcContext"
- Begin DoDot:1
- +6 SET XOBDATA("XOB RPC","RPC CONTEXT")=$GET(XOBCTXT)
- End DoDot:1
- QUIT
- +7 ;
- +8 IF ELE="Param"
- Begin DoDot:1
- +9 IF XOBPTYPE="string"
- SET @XOBPN=$$ESC^XOBVRMX(XOBPARAM)
- QUIT
- +10 IF XOBPTYPE="ref"
- SET @XOBPN=$GET(@$$ESC^XOBVRMX(XOBPARAM))
- QUIT
- End DoDot:1
- KILL XOBPARAM
- QUIT
- +11 ;
- +12 IF ELE="Params"
- Begin DoDot:1
- +13 NEW POS,PARAMS
- +14 SET PARAMS=""
- SET POS=0
- +15 FOR
- SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS))
- if 'POS
- QUIT
- SET PARAMS=PARAMS_",."_XOBDATA("XOB RPC","PARAMS",POS)
- +16 SET XOBDATA("XOB RPC","PARAMS")=PARAMS
- End DoDot:1
- QUIT
- +17 ;
- +18 IF ELE="Index"
- Begin DoDot:1
- +19 IF $DATA(XOBPARNM)&$DATA(XOBPARVL)
- Begin DoDot:2
- +20 KILL XOBPARAM
- +21 IF $EXTRACT(XOBPARNM,1)=$CHAR(13)
- Begin DoDot:3
- +22 SET @("@XOBPN@("_$$ESC^XOBVRMX($EXTRACT(XOBPARNM,2,$LENGTH(XOBPARNM)))_")=$$ESC^XOBVRMX(XOBPARVL)")
- End DoDot:3
- +23 IF '$TEST
- Begin DoDot:3
- +24 SET @XOBPN@($$ESC^XOBVRMX(XOBPARNM))=$$ESC^XOBVRMX(XOBPARVL)
- End DoDot:3
- +25 KILL XOBPARNM,XOBPARVL
- End DoDot:2
- End DoDot:1
- QUIT
- +26 ;
- +27 IF ELE="Name"
- Begin DoDot:1
- +28 SET XOBPARNM("DONE")=1
- End DoDot:1
- QUIT
- +29 ;
- +30 IF ELE="Value"
- Begin DoDot:1
- +31 SET XOBPARVL("DONE")=1
- End DoDot:1
- QUIT
- +32 ;
- +33 IF ELE="AccessVerify"
- IF $GET(XOBSECFL)
- IF $EXTRACT($GET(XOBDATA("XOB RPC","SECURITY","TYPE")),1,2)="av"
- Begin DoDot:1
- +34 SET XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE")=XOBAVCOD
- KILL XOBAVCOD
- End DoDot:1
- QUIT
- +35 IF ELE="KernelCcowToken"
- IF $GET(XOBSECFL)
- IF $GET(XOBDATA("XOB RPC","SECURITY","TYPE"))="ccow"
- Begin DoDot:1
- +36 SET XOBDATA("XOB RPC","SECURITY","TYPE","CCOW")=XOBCCOWT
- KILL XOBCCOWT
- End DoDot:1
- QUIT
- +37 IF ELE="Security"
- KILL XOBSECFL
- QUIT
- +38 ;
- +39 QUIT
- +40 ;
- CHR(TEXT) ; -- character value event handler <tag>TEXT</tag)
- +1 ; -- need to concatenate because MXML parses on ENTITY characters (<>& etc.) and
- +2 ; callback gets hit multiple times even though the tag text value is just one piece of data.
- +3 ; (Yes, this seems kludgie!)
- +4 IF $DATA(XOBPARAM)
- SET XOBPARAM=XOBPARAM_TEXT
- +5 IF $DATA(XOBPARNM)
- IF '+$GET(XOBPARNM("DONE"))
- SET XOBPARNM=XOBPARNM_TEXT
- QUIT
- +6 IF $DATA(XOBPARVL)
- IF '+$GET(XOBPARVL("DONE"))
- SET XOBPARVL=XOBPARVL_TEXT
- QUIT
- +7 IF $DATA(XOBCTXT)
- SET XOBCTXT=XOBCTXT_TEXT
- QUIT
- +8 IF $DATA(XOBAVCOD)
- SET XOBAVCOD=XOBAVCOD_TEXT
- QUIT
- +9 IF $DATA(XOBCCOWT)
- SET XOBCCOWT=XOBCCOWT_TEXT
- QUIT
- +10 QUIT
- +11 ;