VBECVLC ;HOIFO/BNT-VBECS VistALink Client ;07/27/2002
;;2.0;VBEC;;Jun 05, 2015;Build 4
;
; Note: This routine supports data exchange with an FDA registered
; medical device. As such, it may not be changed in any way without
; prior written approval from the medical device manufacturer.
;
; Integration Agreements:
; Call to XOBVLIB Supported by IA #4090
; Reference to %ZOSV supported by IA #10097
; Reference to %ZTER supported by IA #1621
;
QUIT
;
EXECUTE(VBECPRMS) ; -- Main entry point
NEW X,VBECI,VBECOK,VBECRES,VBECREF,VBECROOT,VBECREQ,VBECREAD,VBECTO,VBECFRST,VBECSTOP,VBECRL
NEW $ETRAP,$ESTACK S $ETRAP="D SYSERR^VBECVLC"
;
; -- if no 'results' node set, set it and kill it!
IF $G(VBECPRMS("RESULTS"))="" SET VBECPRMS("RESULTS")=$NA(^TMP("VBECVLC",$J,"XML"))
SET VBECROOT=VBECPRMS("RESULTS")
KILL @VBECROOT
;
SET VBECREQ=VBECPRMS("REQUEST")
;
; -- intialize result flag to 'failed' (0)
SET VBECRES=0
;
; -- application can pass in address/port
IF '$D(VBECPRMS("ADDRESS")) D CLIERR(1,.VBECROOT) GOTO MAINQ
IF '$D(VBECPRMS("PORT")) D CLIERR(2,.VBECROOT) GOTO MAINQ
;
; Retry open only once to prevent delay in calling application
SET VBECPRMS("RETRIES")=1
IF '$$OPEN^VBECRL(.VBECPRMS) D CLIERR(3,.VBECROOT) GOTO MAINQ
;
; -- write request
DO PRE^VBECRL
SET VBECI=0 FOR SET VBECI=$O(@VBECREQ@(VBECI)) Q:'VBECI DO WRITE^VBECRL(@VBECREQ@(VBECI))
;
; -- send eot and flush buffer
DO POST^VBECRL
;
; -- set inputs and read results
SET VBECREAD=255,VBECTO=1,VBECFRST=0,VBECSTOP=0
SET VBECOK=$$READ^VBECRL(VBECROOT,.VBECREAD,.VBECTO,.VBECFRST,.VBECSTOP)
;
; -- close port
DO CLOSE^VBECRL(.VBECPRMS)
;
; -- set result flag to 'successful' (1)
SET VBECRES=1
;
MAINQ ;
QUIT VBECRES
;
; -----------------------------------------------------
; Client Error Handler
; -----------------------------------------------------
CLIERR(VBECCODE,VBECROOT) ; -- send client error message
NEW VBECDAT
SET VBECDAT("MESSAGE TYPE")="gov.va.med.foundations.rpc.fault"
SET VBECDAT("ERRORS",1,"CODE")=1
SET VBECDAT("ERRORS",1,"ERROR TYPE")="client"
SET VBECDAT("ERRORS",1,"CDATA")=1
SET VBECDAT("ERRORS",1,"MESSAGE")=$P($TEXT(CLIERRS+VBECCODE),";;",2)
DO BUILD(.VBECROOT,.VBECDAT)
QUIT
;
; ------------------------------------------------------
; System Error Handler
; ------------------------------------------------------
SYSERR ; -- send system error message
NEW VBECDAT,VBECMSG,$ETRAP
SET $ETRAP="D ^%ZTER HALT" ; -- If we get an error in the error handler just Halt
SET VBECMSG=$$EC^%ZOSV ; -- Get the error code
DO ^%ZTER ; -- Save off the error
;
SET VBECDAT("MESSAGE TYPE")="gov.va.med.foundations.rpc.fault"
SET VBECDAT("ERRORS",1,"CODE")=1
SET VBECDAT("ERRORS",1,"ERROR TYPE")="system"
SET VBECDAT("ERRORS",1,"CDATA")=1
SET VBECDAT("ERRORS",1,"MESSAGE")=$P($TEXT(SYSERRS+1),";;",2)_VBECMSG
DO BUILD(.VBECROOT,.VBECDAT)
QUIT
;
BUILD(VBECY,VBECDAT) ; -- store built xml in passed store reference (VBECY)
; -- input format
; VBECDAT("MESSAGE TYPE") = type of message (ex. gov.va.med.foundations.rpc.fault)
; VBECDAT("ERRORS",<integer>,"CODE") = error code
; VBECDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
; VBECDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
;
NEW VBECCODE,VBECI,VBECERR,VBECLINE,VBECETYP
SET VBECLINE=0
;
DO ADD($$XMLHDR^XOBVLIB())
DO ADD("<VistaLink messageType="""_$G(VBECDAT("MESSAGE TYPE"))_""" version=""1.0"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xsi:noNamespaceSchemaLocation=""rpcFault.xsd"" >")
DO ADD("xmlns=""http://domain.ext/Foundations"">")
DO ADD("<Fault>")
DO ADD("<FaultString>Internal Application Error</FaultString>")
DO ADD("<FaultActor>VBECS VistaLink Client</FaultActor>")
SET VBECERR=0
FOR SET VBECERR=$O(VBECDAT("ERRORS",VBECERR)) Q:'VBECERR DO
. SET VBECCODE=$G(VBECDAT("ERRORS",VBECERR,"CODE"),0)
. SET VBECETYP=$G(VBECDAT("ERRORS",VBECERR,"ERROR TYPE"),0)
. DO ADD("<Detail>")
. DO ADD("<Error code="""_VBECCODE_""" type="""_VBECETYP_""" >")
. DO ADD("<Message>"_$$CHARCHK^XOBVLIB(VBECDAT("ERRORS",VBECERR,"MESSAGE"))_"</Message>")
. DO ADD("</Error>")
. DO ADD("</Detail>")
DO ADD("</Fault>")
DO ADD("</VistaLink>")
;
QUIT
;
ADD(TXT) ; -- add line
SET VBECLINE=VBECLINE+1
SET @VBECY@(VBECLINE)=TXT
QUIT
;
CLIERRS ; -- VistALink client errors
;;'Address' parameter not specified.
;;'Port' parameter not specified.
;;Unable to retrieve patient information at this time, please contact the Blood Bank. [restart VBECS VistALink listener]
;
SYSERRS ; -- application errors
;;A system error occurred in M: "
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECVLC 4801 printed Apr 09, 2024@21:46:07 Page 2
VBECVLC ;HOIFO/BNT-VBECS VistALink Client ;07/27/2002
+1 ;;2.0;VBEC;;Jun 05, 2015;Build 4
+2 ;
+3 ; Note: This routine supports data exchange with an FDA registered
+4 ; medical device. As such, it may not be changed in any way without
+5 ; prior written approval from the medical device manufacturer.
+6 ;
+7 ; Integration Agreements:
+8 ; Call to XOBVLIB Supported by IA #4090
+9 ; Reference to %ZOSV supported by IA #10097
+10 ; Reference to %ZTER supported by IA #1621
+11 ;
+12 QUIT
+13 ;
EXECUTE(VBECPRMS) ; -- Main entry point
+1 NEW X,VBECI,VBECOK,VBECRES,VBECREF,VBECROOT,VBECREQ,VBECREAD,VBECTO,VBECFRST,VBECSTOP,VBECRL
+2 NEW $ETRAP,$ESTACK
SET $ETRAP="D SYSERR^VBECVLC"
+3 ;
+4 ; -- if no 'results' node set, set it and kill it!
+5 IF $GET(VBECPRMS("RESULTS"))=""
SET VBECPRMS("RESULTS")=$NAME(^TMP("VBECVLC",$JOB,"XML"))
+6 SET VBECROOT=VBECPRMS("RESULTS")
+7 KILL @VBECROOT
+8 ;
+9 SET VBECREQ=VBECPRMS("REQUEST")
+10 ;
+11 ; -- intialize result flag to 'failed' (0)
+12 SET VBECRES=0
+13 ;
+14 ; -- application can pass in address/port
+15 IF '$DATA(VBECPRMS("ADDRESS"))
DO CLIERR(1,.VBECROOT)
GOTO MAINQ
+16 IF '$DATA(VBECPRMS("PORT"))
DO CLIERR(2,.VBECROOT)
GOTO MAINQ
+17 ;
+18 ; Retry open only once to prevent delay in calling application
+19 SET VBECPRMS("RETRIES")=1
+20 IF '$$OPEN^VBECRL(.VBECPRMS)
DO CLIERR(3,.VBECROOT)
GOTO MAINQ
+21 ;
+22 ; -- write request
+23 DO PRE^VBECRL
+24 SET VBECI=0
FOR
SET VBECI=$ORDER(@VBECREQ@(VBECI))
if 'VBECI
QUIT
DO WRITE^VBECRL(@VBECREQ@(VBECI))
+25 ;
+26 ; -- send eot and flush buffer
+27 DO POST^VBECRL
+28 ;
+29 ; -- set inputs and read results
+30 SET VBECREAD=255
SET VBECTO=1
SET VBECFRST=0
SET VBECSTOP=0
+31 SET VBECOK=$$READ^VBECRL(VBECROOT,.VBECREAD,.VBECTO,.VBECFRST,.VBECSTOP)
+32 ;
+33 ; -- close port
+34 DO CLOSE^VBECRL(.VBECPRMS)
+35 ;
+36 ; -- set result flag to 'successful' (1)
+37 SET VBECRES=1
+38 ;
MAINQ ;
+1 QUIT VBECRES
+2 ;
+3 ; -----------------------------------------------------
+4 ; Client Error Handler
+5 ; -----------------------------------------------------
CLIERR(VBECCODE,VBECROOT) ; -- send client error message
+1 NEW VBECDAT
+2 SET VBECDAT("MESSAGE TYPE")="gov.va.med.foundations.rpc.fault"
+3 SET VBECDAT("ERRORS",1,"CODE")=1
+4 SET VBECDAT("ERRORS",1,"ERROR TYPE")="client"
+5 SET VBECDAT("ERRORS",1,"CDATA")=1
+6 SET VBECDAT("ERRORS",1,"MESSAGE")=$PIECE($TEXT(CLIERRS+VBECCODE),";;",2)
+7 DO BUILD(.VBECROOT,.VBECDAT)
+8 QUIT
+9 ;
+10 ; ------------------------------------------------------
+11 ; System Error Handler
+12 ; ------------------------------------------------------
SYSERR ; -- send system error message
+1 NEW VBECDAT,VBECMSG,$ETRAP
+2 ; -- If we get an error in the error handler just Halt
SET $ETRAP="D ^%ZTER HALT"
+3 ; -- Get the error code
SET VBECMSG=$$EC^%ZOSV
+4 ; -- Save off the error
DO ^%ZTER
+5 ;
+6 SET VBECDAT("MESSAGE TYPE")="gov.va.med.foundations.rpc.fault"
+7 SET VBECDAT("ERRORS",1,"CODE")=1
+8 SET VBECDAT("ERRORS",1,"ERROR TYPE")="system"
+9 SET VBECDAT("ERRORS",1,"CDATA")=1
+10 SET VBECDAT("ERRORS",1,"MESSAGE")=$PIECE($TEXT(SYSERRS+1),";;",2)_VBECMSG
+11 DO BUILD(.VBECROOT,.VBECDAT)
+12 QUIT
+13 ;
BUILD(VBECY,VBECDAT) ; -- store built xml in passed store reference (VBECY)
+1 ; -- input format
+2 ; VBECDAT("MESSAGE TYPE") = type of message (ex. gov.va.med.foundations.rpc.fault)
+3 ; VBECDAT("ERRORS",<integer>,"CODE") = error code
+4 ; VBECDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
+5 ; VBECDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
+6 ;
+7 NEW VBECCODE,VBECI,VBECERR,VBECLINE,VBECETYP
+8 SET VBECLINE=0
+9 ;
+10 DO ADD($$XMLHDR^XOBVLIB())
+11 DO ADD("<VistaLink messageType="""_$GET(VBECDAT("MESSAGE TYPE"))_""" version=""1.0"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xsi:noNamespaceSchemaLocation=""rpcFault.xsd"" >")
+12 DO ADD("xmlns=""http://domain.ext/Foundations"">")
+13 DO ADD("<Fault>")
+14 DO ADD("<FaultString>Internal Application Error</FaultString>")
+15 DO ADD("<FaultActor>VBECS VistaLink Client</FaultActor>")
+16 SET VBECERR=0
+17 FOR
SET VBECERR=$ORDER(VBECDAT("ERRORS",VBECERR))
if 'VBECERR
QUIT
Begin DoDot:1
+18 SET VBECCODE=$GET(VBECDAT("ERRORS",VBECERR,"CODE"),0)
+19 SET VBECETYP=$GET(VBECDAT("ERRORS",VBECERR,"ERROR TYPE"),0)
+20 DO ADD("<Detail>")
+21 DO ADD("<Error code="""_VBECCODE_""" type="""_VBECETYP_""" >")
+22 DO ADD("<Message>"_$$CHARCHK^XOBVLIB(VBECDAT("ERRORS",VBECERR,"MESSAGE"))_"</Message>")
+23 DO ADD("</Error>")
+24 DO ADD("</Detail>")
End DoDot:1
+25 DO ADD("</Fault>")
+26 DO ADD("</VistaLink>")
+27 ;
+28 QUIT
+29 ;
ADD(TXT) ; -- add line
+1 SET VBECLINE=VBECLINE+1
+2 SET @VBECY@(VBECLINE)=TXT
+3 QUIT
+4 ;
CLIERRS ; -- VistALink client errors
+1 ;;'Address' parameter not specified.
+2 ;;'Port' parameter not specified.
+3 ;;Unable to retrieve patient information at this time, please contact the Blood Bank. [restart VBECS VistALink listener]
+4 ;
SYSERRS ; -- application errors
+1 ;;A system error occurred in M: "
