94 lines
3.0 KiB
Mathematica
94 lines
3.0 KiB
Mathematica
|
XOBVRH ;mjk/alb - VistaLink Request Handler Utilities ; 07/27/2002 13:00
|
||
|
|
;;1.5;VistALink;;Sep 09, 2005
|
||
|
|
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
|
||
|
|
;
|
||
|
|
QUIT
|
||
|
|
;
|
||
|
|
; ------------------------------------------------------------------
|
||
|
|
; Message Type Handler Utilities
|
||
|
|
; ------------------------------------------------------------------
|
||
|
|
;
|
||
|
|
; -- set up msg type info using message name
|
||
|
|
MSGNAME(XOBMSG,XOBHDLR) ; -- set up msg type info
|
||
|
|
QUIT $$SETMSG(XOBMSG,"NAME",.XOBHDLR)
|
||
|
|
;
|
||
|
|
; -- set up msg type info using message type
|
||
|
|
MSGTYPE(XOBMSG,XOBHDLR) ; -- set up msg type info
|
||
|
|
QUIT $$SETMSG(XOBMSG,"MSGTYPE",.XOBHDLR)
|
||
|
|
;
|
||
|
|
; -- set up msg type info using proprietary string
|
||
|
|
MSGSINK(XOBMSG,XOBHDLR) ; -- set up msg type info
|
||
|
|
QUIT $$SETMSG(XOBMSG,"D",.XOBHDLR)
|
||
|
|
;
|
||
|
|
CACHE(XOBHDLR) ; -- cache req handlers
|
||
|
|
NEW TYPE,TYPE0,XOBOK
|
||
|
|
SET TYPE=0
|
||
|
|
SET XOBOK=1
|
||
|
|
;
|
||
|
|
; -- load request handler info
|
||
|
|
FOR SET TYPE=$ORDER(^XOB(18.05,"AS",1,TYPE)) QUIT:'TYPE DO QUIT:'XOBOK
|
||
|
|
. SET TYPE0=$GET(^XOB(18.05,TYPE,0))
|
||
|
|
. DO SET(TYPE,TYPE0,.XOBHDLR)
|
||
|
|
. SET XOBOK=$GET(XOBHDLR(TYPE))
|
||
|
|
. IF 'XOBOK SET XOBOK=XOBOK_U_$GET(XOBHDLR,"ERROR")
|
||
|
|
QUIT XOBOK
|
||
|
|
;
|
||
|
|
; -- set up msg type info
|
||
|
|
SETMSG(XOBMSG,XOBXREF,XOBHDLR) ;
|
||
|
|
NEW TYPE,TYPEO
|
||
|
|
KILL XOBHDLR(0)
|
||
|
|
;
|
||
|
|
; -- already cached?
|
||
|
|
SET TYPE=$ORDER(XOBHDLR(XOBXREF,XOBMSG,""))
|
||
|
|
IF TYPE QUIT TYPE
|
||
|
|
;
|
||
|
|
; -- load req handler
|
||
|
|
SET TYPE=+$ORDER(^XOB(18.05,XOBXREF,XOBMSG,""))
|
||
|
|
IF TYPE DO
|
||
|
|
. SET TYPE0=$GET(^XOB(18.05,TYPE,0))
|
||
|
|
. DO SET(.TYPE,.TYPE0,.XOBHDLR)
|
||
|
|
IF 'TYPE DO
|
||
|
|
. SET XOBHDLR(0)=0
|
||
|
|
. SET XOBHDLR(0,"ERROR")="No message type defined"
|
||
|
|
QUIT TYPE
|
||
|
|
;
|
||
|
|
SET(TYPE,TYPE0,XOBHDLR) ; -- set nodes
|
||
|
|
NEW IRTN,XOBICBK
|
||
|
|
KILL XOBHDLR(TYPE)
|
||
|
|
SET IRTN=$$IRTN(TYPE0)
|
||
|
|
IF IRTN="" DO GOTO SETQ
|
||
|
|
. SET XOBHDLR(TYPE)=0
|
||
|
|
. IF TYPE0="" SET XOBHDLR(TYPE,"ERROR")="No entry for message type ["_TYPE_"]" QUIT
|
||
|
|
. IF IRTN="" SET XOBHDLR(TYPE,"ERROR")="Invalid interface routine specified ["_$PIECE(TYPE0,U,5)_"]" QUIT
|
||
|
|
;
|
||
|
|
SET XOBHDLR(TYPE)=1
|
||
|
|
SET XOBHDLR(TYPE,"AUTHENTICATE")=+$PIECE(TYPE0,U,4)
|
||
|
|
SET XOBHDLR(TYPE,"REQHDLR")="DO REQHDLR^"_IRTN_"(.XOBDATA)"
|
||
|
|
SET XOBHDLR(TYPE,"READER")="DO READER^"_IRTN_"(.XOBX,.XOBDATA)"
|
||
|
|
IF $PIECE(TYPE0,U,1)]"" SET XOBHDLR("NAME",$PIECE(TYPE0,U,1),TYPE)=""
|
||
|
|
IF $PIECE(TYPE0,U,2)]"" SET XOBHDLR("MSGTYPE",$PIECE(TYPE0,U,2),TYPE)=""
|
||
|
|
IF $PIECE(TYPE0,U,7)]"" SET XOBHDLR("D",$PIECE(TYPE0,U,7),TYPE)=""
|
||
|
|
;
|
||
|
|
; -- set up SAX callbacks
|
||
|
|
SET XOBHDLR(TYPE,"CB","ELEST")="QUIT"
|
||
|
|
SET XOBHDLR(TYPE,"CB","ELEND")="QUIT"
|
||
|
|
SET XOBHDLR(TYPE,"CB","CHR")="QUIT"
|
||
|
|
;
|
||
|
|
XECUTE "DO CALLBACK^"_IRTN_"(.XOBICBK)"
|
||
|
|
IF $DATA(XOBICBK("STARTELEMENT")) SET XOBHDLR(TYPE,"CB","ELEST")="DO "_XOBICBK("STARTELEMENT")_"(.ELE,.ATR)"
|
||
|
|
IF $DATA(XOBICBK("ENDELEMENT")) SET XOBHDLR(TYPE,"CB","ELEND")="DO "_XOBICBK("ENDELEMENT")_"(.ELE)"
|
||
|
|
IF $DATA(XOBICBK("CHARACTERS")) SET XOBHDLR(TYPE,"CB","CHR")="DO "_XOBICBK("CHARACTERS")_"(.TXT)"
|
||
|
|
SETQ ;
|
||
|
|
QUIT
|
||
|
|
;
|
||
|
|
; -- get interface routine and test for existence
|
||
|
|
IRTN(XOBTYPE0) ;
|
||
|
|
NEW X,RTN
|
||
|
|
SET RTN=""
|
||
|
|
SET X=$PIECE(XOBTYPE0,"^",5)
|
||
|
|
IF X]"" DO
|
||
|
|
. XECUTE ^%ZOSF("TEST")
|
||
|
|
. IF $TEST SET RTN=X
|
||
|
|
QUIT RTN
|
||
|
|
;
|