XOBVRH.m

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

 ;

XOBVRH    ;mjk/alb - VistaLink Request Handler Utilities ; 07/27/2002  13:00

 +1       ;;1.5;VistALink;;Sep 09, 2005

 +2       ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]

 +3       ;

 +4        QUIT 

 +5       ;

 +6       ; ------------------------------------------------------------------

 +7       ;                       Message Type Handler Utilities

 +8       ; ------------------------------------------------------------------

 +9       ; 

 +10      ; -- 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       ; -- already cached?

 +5        SET TYPE=$ORDER(XOBHDLR(XOBXREF,XOBMSG,""))

 +6        IF TYPE

               QUIT TYPE

 +7       ;

 +8       ; -- load req handler

 +9        SET TYPE=+$ORDER(^XOB(18.05,XOBXREF,XOBMSG,""))

 +10       IF TYPE

               Begin DoDot:1

 +11               SET TYPE0=$GET(^XOB(18.05,TYPE,0))

 +12               DO SET(.TYPE,.TYPE0,.XOBHDLR)

               End DoDot:1

 +13       IF 'TYPE

               Begin DoDot:1

 +14               SET XOBHDLR(0)=0

 +15               SET XOBHDLR(0,"ERROR")="No message type defined"

               End DoDot:1

 +16       QUIT TYPE

 +17      ;

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       ;