XOBVRH ;mjk/alb - VistaLink Request Handler Utilities ; 07/27/2002 13:00
;;1.6;VistALink;;May 08, 2009;Build 15
;Per VHA directive 2004-038, this routine should not be modified.
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)
;
; -- bad message type (empty)
IF $GET(XOBMSG)="" DO QUIT TYPE
. SET TYPE=0
. SET XOBHDLR(0)=0
. SET XOBHDLR(0,"ERROR")="No message type defined"
;
; -- 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVRH 3334 printed Dec 13, 2024@02:44:48 Page 2
XOBVRH ;mjk/alb - VistaLink Request Handler Utilities ; 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 QUIT
+4 ;
+5 ; ------------------------------------------------------------------
+6 ; Message Type Handler Utilities
+7 ; ------------------------------------------------------------------
+8 ;
+9 ; -- set up msg type info using message name
MSGNAME(XOBMSG,XOBHDLR) ; -- set up msg type info
+1 QUIT $$SETMSG(XOBMSG,"NAME",.XOBHDLR)
+2 ;
+3 ; -- set up msg type info using message type
MSGTYPE(XOBMSG,XOBHDLR) ; -- set up msg type info
+1 QUIT $$SETMSG(XOBMSG,"MSGTYPE",.XOBHDLR)
+2 ;
+3 ; -- set up msg type info using proprietary string
MSGSINK(XOBMSG,XOBHDLR) ; -- set up msg type info
+1 QUIT $$SETMSG(XOBMSG,"D",.XOBHDLR)
+2 ;
CACHE(XOBHDLR) ; -- cache req handlers
+1 NEW TYPE,TYPE0,XOBOK
+2 SET TYPE=0
+3 SET XOBOK=1
+4 ;
+5 ; -- load request handler info
+6 FOR
SET TYPE=$ORDER(^XOB(18.05,"AS",1,TYPE))
if 'TYPE
QUIT
Begin DoDot:1
+7 SET TYPE0=$GET(^XOB(18.05,TYPE,0))
+8 DO SET(TYPE,TYPE0,.XOBHDLR)
+9 SET XOBOK=$GET(XOBHDLR(TYPE))
+10 IF 'XOBOK
SET XOBOK=XOBOK_U_$GET(XOBHDLR,"ERROR")
End DoDot:1
if 'XOBOK
QUIT
+11 QUIT XOBOK
+12 ;
+13 ; -- set up msg type info
SETMSG(XOBMSG,XOBXREF,XOBHDLR) ;
+1 NEW TYPE,TYPEO
+2 KILL XOBHDLR(0)
+3 ;
+4 ; -- bad message type (empty)
+5 IF $GET(XOBMSG)=""
Begin DoDot:1
+6 SET TYPE=0
+7 SET XOBHDLR(0)=0
+8 SET XOBHDLR(0,"ERROR")="No message type defined"
End DoDot:1
QUIT TYPE
+9 ;
+10 ; -- already cached?
+11 SET TYPE=$ORDER(XOBHDLR(XOBXREF,XOBMSG,""))
+12 IF TYPE
QUIT TYPE
+13 ;
+14 ; -- load req handler
+15 SET TYPE=+$ORDER(^XOB(18.05,XOBXREF,XOBMSG,""))
+16 IF TYPE
Begin DoDot:1
+17 SET TYPE0=$GET(^XOB(18.05,TYPE,0))
+18 DO SET(.TYPE,.TYPE0,.XOBHDLR)
End DoDot:1
+19 IF 'TYPE
Begin DoDot:1
+20 SET XOBHDLR(0)=0
+21 SET XOBHDLR(0,"ERROR")="No message type defined"
End DoDot:1
+22 QUIT TYPE
+23 ;
SET(TYPE,TYPE0,XOBHDLR) ; -- set nodes
+1 NEW IRTN,XOBICBK
+2 KILL XOBHDLR(TYPE)
+3 SET IRTN=$$IRTN(TYPE0)
+4 IF IRTN=""
Begin DoDot:1
+5 SET XOBHDLR(TYPE)=0
+6 IF TYPE0=""
SET XOBHDLR(TYPE,"ERROR")="No entry for message type ["_TYPE_"]"
QUIT
+7 IF IRTN=""
SET XOBHDLR(TYPE,"ERROR")="Invalid interface routine specified ["_$PIECE(TYPE0,U,5)_"]"
QUIT
End DoDot:1
GOTO SETQ
+8 ;
+9 SET XOBHDLR(TYPE)=1
+10 SET XOBHDLR(TYPE,"AUTHENTICATE")=+$PIECE(TYPE0,U,4)
+11 SET XOBHDLR(TYPE,"REQHDLR")="DO REQHDLR^"_IRTN_"(.XOBDATA)"
+12 SET XOBHDLR(TYPE,"READER")="DO READER^"_IRTN_"(.XOBX,.XOBDATA)"
+13 IF $PIECE(TYPE0,U,1)]""
SET XOBHDLR("NAME",$PIECE(TYPE0,U,1),TYPE)=""
+14 IF $PIECE(TYPE0,U,2)]""
SET XOBHDLR("MSGTYPE",$PIECE(TYPE0,U,2),TYPE)=""
+15 IF $PIECE(TYPE0,U,7)]""
SET XOBHDLR("D",$PIECE(TYPE0,U,7),TYPE)=""
+16 ;
+17 ; -- set up SAX callbacks
+18 SET XOBHDLR(TYPE,"CB","ELEST")="QUIT"
+19 SET XOBHDLR(TYPE,"CB","ELEND")="QUIT"
+20 SET XOBHDLR(TYPE,"CB","CHR")="QUIT"
+21 ;
+22 XECUTE "DO CALLBACK^"_IRTN_"(.XOBICBK)"
+23 IF $DATA(XOBICBK("STARTELEMENT"))
SET XOBHDLR(TYPE,"CB","ELEST")="DO "_XOBICBK("STARTELEMENT")_"(.ELE,.ATR)"
+24 IF $DATA(XOBICBK("ENDELEMENT"))
SET XOBHDLR(TYPE,"CB","ELEND")="DO "_XOBICBK("ENDELEMENT")_"(.ELE)"
+25 IF $DATA(XOBICBK("CHARACTERS"))
SET XOBHDLR(TYPE,"CB","CHR")="DO "_XOBICBK("CHARACTERS")_"(.TXT)"
SETQ ;
+1 QUIT
+2 ;
+3 ; -- get interface routine and test for existence
IRTN(XOBTYPE0) ;
+1 NEW X,RTN
+2 SET RTN=""
+3 SET X=$PIECE(XOBTYPE0,"^",5)
+4 IF X]""
Begin DoDot:1
+5 XECUTE ^%ZOSF("TEST")
+6 IF $TEST
SET RTN=X
End DoDot:1
+7 QUIT RTN
+8 ;
