XOBVLIB ;; mjk/alb - VistaLink Programmer Library ; 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
; --------------------------------------------------------------
; Application Developer Supported Calls
; --------------------------------------------------------------
;
XMLHDR() ; -- provides current XML standard header
QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
;
CHARCHK(STR) ; -- replace xml character limits with entities
NEW A,I,X,Y,Z,NEWSTR
SET (Y,Z)=""
IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z
. FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
IF STR["<" FOR SET STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) QUIT:STR'["<"
IF STR[">" FOR SET STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) QUIT:STR'[">"
IF STR["'" FOR SET STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) QUIT:STR'["'"
IF STR["""" FOR SET STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) QUIT:STR'[""""
;
FOR I=1:1:$LENGTH(STR) DO
. SET X=$EXTRACT(STR,I)
. SET A=$ASCII(X)
. IF A<31 SET STR=$PIECE(STR,X,1)_$PIECE(STR,X,2,99)
QUIT STR
;
STOP() ; -- called by application to determine if processing should stop gracefully
NEW XOBFLAG
;
; -- do checks (only one now is time out)
DO TOFLAG
;
; -- set 'stop' flag
SET XOBFLAG=$$TOCHK()
;
QUIT XOBFLAG
;
GETTO() ; -- get time out value
QUIT $GET(XOBDATA("XOB RPC","TIMEOUT"),300)
;
SETTO(TO) ; -- set time out value on the fly
SET XOBDATA("XOB RPC","TIMEOUT")=TO
QUIT 1
;
; --------------------------------------------------------------
; Foundations Developer Calls (Unsupported)
; --------------------------------------------------------------
;
VLHDR(NUM) ; -- provides current VistaLink standard header
NEW X,TYPE,SCHEMA
;
; -- get type info
SET X=$PIECE($TEXT(TYPE+NUM),";;",2)
SET TYPE=$PIECE(X,"^",2)
SET SCHEMA=$PIECE(X,"^",3)
QUIT $$ENVHDR(TYPE,SCHEMA)
;
TYPE ; -- return message types [ number ^ message type ^ schema file ]
;;1^gov.va.med.foundations.rpc.response^rpcResponse.xsd
;;2^gov.va.med.foundations.rpc.fault^rpcFault.xsd
;;3^gov.va.med.foundations.vistalink.system.fault^vlFault.xsd
;;4^gov.va.med.foundations.vistalink.system.response^vlSimpleResponse.xsd
;
ERROR(XOBDAT) ; -- send error type message
NEW XOBI,XOBY,XOBOS
SET XOBY="XOBY"
; -- build xml
DO BUILD(.XOBY,.XOBDAT)
;
USE XOBPORT
DO OS^XOBVSKT
; -- write xml
DO PRE^XOBVSKT
SET XOBI=0 FOR SET XOBI=$ORDER(XOBY(XOBI)) QUIT:'XOBI DO WRITE^XOBVSKT(XOBY(XOBI))
; -- send eot and flush buffer
DO POST^XOBVSKT
QUIT
;
BUILD(XOBY,XOBDAT) ; -- store built xml in passed store reference (XOBY)
; -- input format
; XOBDAT("MESSAGE TYPE") = # type of message (ex. 2 = gov.va.med.foundations.vistalink.rpc.fault :: See TYPE tag)
; XOBDAT("ERRORS",<integer>,"CODE") = error code
; XOBDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
; XOBDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
;
; -- SOAP related information
; XOBDAT("ERRORS",<integer>,"FAULT CODE") = high level code on where error occurred (ex. Client, Server, etc.)
; - Default: Server
; XOBDAT("ERRORS",<integer>,"FAULT STRING") = high level fault type text (ex. System Error)
; - Default: System Error
; XOBDAT("ERRORS",<integer>,"FAULT ACTOR") = RPC, routine, etc. running when error occurred
; - Default: [none]
;
NEW XOBCODE,XOBI,XOBERR,XOBLINE,XOBETYPE
SET XOBLINE=0
;
DO ADD($$VLHDR($GET(XOBDAT("MESSAGE TYPE"))))
DO ADD("<Fault>")
DO ADD("<FaultCode>"_$GET(XOBDAT("ERRORS",1,"FAULT CODE"),"Server")_"</FaultCode>")
DO ADD("<FaultString>"_$GET(XOBDAT("ERRORS",1,"FAULT STRING"),"System Error")_"</FaultString>")
DO ADD("<FaultActor>"_$GET(XOBDAT("ERRORS",1,"FAULT ACTOR"))_"</FaultActor>")
DO ADD("<Detail>")
SET XOBERR=0
FOR SET XOBERR=$ORDER(XOBDAT("ERRORS",XOBERR)) QUIT:'XOBERR DO
. SET XOBCODE=$GET(XOBDAT("ERRORS",XOBERR,"CODE"),0)
. SET XOBETYPE=$GET(XOBDAT("ERRORS",XOBERR,"ERROR TYPE"),0)
. DO ADD("<Error type="""_XOBETYPE_""" code="""_XOBCODE_""" >")
. DO ADD("<Message>")
. IF $GET(XOBDAT("ERRORS",XOBERR,"CDATA")) DO ADD("<![CDATA[")
. SET XOBI=0
. FOR SET XOBI=$ORDER(XOBDAT("ERRORS",XOBERR,"MESSAGE",XOBI)) QUIT:'XOBI DO
. . DO ADD(XOBDAT("ERRORS",XOBERR,"MESSAGE",XOBI))
. IF $GET(XOBDAT("ERRORS",XOBERR,"CDATA")) DO ADD("]]>")
. DO ADD("</Message>")
. DO ADD("</Error>")
DO ADD("</Detail>")
DO ADD("</Fault>")
DO ADD($$ENVFTR())
;
QUIT
;
ADD(TXT) ; -- add line
SET XOBLINE=XOBLINE+1
SET @XOBY@(XOBLINE)=TXT
QUIT
;
GETRATE() ; -- get J2SE heartbeat rate in seconds
NEW X
SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",2)
QUIT $SELECT(X:X,1:180)
;
GETDELTA() ; -- get J2SE latency delta in seconds
NEW X
SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",3)
QUIT $SELECT(X:X,1:180)
;
GETASTO() ; -- get J2EE application server time out in seconds (one day = 86400)
NEW X
SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",4)
QUIT $SELECT(X:X,1:86400)
;
GETRASTO() ; -- get J2EE application server reauthenticated session time out in seconds (ten minutes = 600)
NEW X
SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",5)
QUIT $SELECT(X:X,1:600)
;
TOFLAG ; -- set timed out flag
; -- if run in non-VistALink environment never time out ; set both now & start = $h
SET XOBDATA("XOB RPC","TIMED OUT")=($$HDIFF^XLFDT($HOROLOG,$GET(XOBDATA("XOB RPC","START"),$HOROLOG),2)>$$GETTO())
QUIT
;
TOCHK() ; -- did RPC timeout?
QUIT +$GET(XOBDATA("XOB RPC","TIMED OUT"))
;
ENVHDR(TYPE,SCHEMA) ; -- vistalink beg tag (header)
NEW X,VLVER
SET X=$$XMLHDR()
SET X=X_"<VistaLink"
SET X=X_" messageType="""_TYPE_""""
SET VLVER="1.6"
; -- indicates to VL v1.5 client that this VL v1.6 server is backwards compatible
IF $GET(XOBDATA("VL VERSION"))="1.5" SET VLVER="1.5"
; -- indicates to VL v1.0 client that this VL v1.6 server is backwards compatible
IF $GET(XOBDATA("VL VERSION"))="1.0" SET VLVER="1.0"
SET X=X_" version="""_VLVER_""""
SET X=X_" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"""
SET X=X_" xsi:noNamespaceSchemaLocation="""_SCHEMA_""""
;SET X=X_" xmlns=""http://domain.ext/Foundations"""
SET X=X_">"
QUIT X
;
ENVFTR() ; -- vistalink end tag (footer)
QUIT "</VistaLink>"
;
SYSOS(XOBOS) ; -- get system operating system
; -- DBIA #3522
QUIT $SELECT(XOBOS["OpenM":$$OS^%ZOSV(),XOBOS["DSM":"VMS",1:"Unknown")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVLIB 6651 printed Jun 11, 2024@22:30:28 Page 2
XOBVLIB ;; mjk/alb - VistaLink Programmer Library ; 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 ; Application Developer Supported Calls
+6 ; --------------------------------------------------------------
+7 ;
XMLHDR() ; -- provides current XML standard header
+1 QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
+2 ;
CHARCHK(STR) ; -- replace xml character limits with entities
+1 NEW A,I,X,Y,Z,NEWSTR
+2 SET (Y,Z)=""
+3 IF STR["&"
SET NEWSTR=STR
Begin DoDot:1
+4 FOR X=1:1
SET Y=Y_$PIECE(NEWSTR,"&",X)_"&"
SET Z=$PIECE(STR,"&",X+1,999)
if Z'["&"
QUIT
End DoDot:1
SET STR=Y_Z
+5 IF STR["<"
FOR
SET STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99)
if STR'["<"
QUIT
+6 IF STR[">"
FOR
SET STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99)
if STR'[">"
QUIT
+7 IF STR["'"
FOR
SET STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99)
if STR'["'"
QUIT
+8 IF STR[""""
FOR
SET STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99)
if STR'[""""
QUIT
+9 ;
+10 FOR I=1:1:$LENGTH(STR)
Begin DoDot:1
+11 SET X=$EXTRACT(STR,I)
+12 SET A=$ASCII(X)
+13 IF A<31
SET STR=$PIECE(STR,X,1)_$PIECE(STR,X,2,99)
End DoDot:1
+14 QUIT STR
+15 ;
STOP() ; -- called by application to determine if processing should stop gracefully
+1 NEW XOBFLAG
+2 ;
+3 ; -- do checks (only one now is time out)
+4 DO TOFLAG
+5 ;
+6 ; -- set 'stop' flag
+7 SET XOBFLAG=$$TOCHK()
+8 ;
+9 QUIT XOBFLAG
+10 ;
GETTO() ; -- get time out value
+1 QUIT $GET(XOBDATA("XOB RPC","TIMEOUT"),300)
+2 ;
SETTO(TO) ; -- set time out value on the fly
+1 SET XOBDATA("XOB RPC","TIMEOUT")=TO
+2 QUIT 1
+3 ;
+4 ; --------------------------------------------------------------
+5 ; Foundations Developer Calls (Unsupported)
+6 ; --------------------------------------------------------------
+7 ;
VLHDR(NUM) ; -- provides current VistaLink standard header
+1 NEW X,TYPE,SCHEMA
+2 ;
+3 ; -- get type info
+4 SET X=$PIECE($TEXT(TYPE+NUM),";;",2)
+5 SET TYPE=$PIECE(X,"^",2)
+6 SET SCHEMA=$PIECE(X,"^",3)
+7 QUIT $$ENVHDR(TYPE,SCHEMA)
+8 ;
TYPE ; -- return message types [ number ^ message type ^ schema file ]
+1 ;;1^gov.va.med.foundations.rpc.response^rpcResponse.xsd
+2 ;;2^gov.va.med.foundations.rpc.fault^rpcFault.xsd
+3 ;;3^gov.va.med.foundations.vistalink.system.fault^vlFault.xsd
+4 ;;4^gov.va.med.foundations.vistalink.system.response^vlSimpleResponse.xsd
+5 ;
ERROR(XOBDAT) ; -- send error type message
+1 NEW XOBI,XOBY,XOBOS
+2 SET XOBY="XOBY"
+3 ; -- build xml
+4 DO BUILD(.XOBY,.XOBDAT)
+5 ;
+6 USE XOBPORT
+7 DO OS^XOBVSKT
+8 ; -- write xml
+9 DO PRE^XOBVSKT
+10 SET XOBI=0
FOR
SET XOBI=$ORDER(XOBY(XOBI))
if 'XOBI
QUIT
DO WRITE^XOBVSKT(XOBY(XOBI))
+11 ; -- send eot and flush buffer
+12 DO POST^XOBVSKT
+13 QUIT
+14 ;
BUILD(XOBY,XOBDAT) ; -- store built xml in passed store reference (XOBY)
+1 ; -- input format
+2 ; XOBDAT("MESSAGE TYPE") = # type of message (ex. 2 = gov.va.med.foundations.vistalink.rpc.fault :: See TYPE tag)
+3 ; XOBDAT("ERRORS",<integer>,"CODE") = error code
+4 ; XOBDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
+5 ; XOBDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
+6 ;
+7 ; -- SOAP related information
+8 ; XOBDAT("ERRORS",<integer>,"FAULT CODE") = high level code on where error occurred (ex. Client, Server, etc.)
+9 ; - Default: Server
+10 ; XOBDAT("ERRORS",<integer>,"FAULT STRING") = high level fault type text (ex. System Error)
+11 ; - Default: System Error
+12 ; XOBDAT("ERRORS",<integer>,"FAULT ACTOR") = RPC, routine, etc. running when error occurred
+13 ; - Default: [none]
+14 ;
+15 NEW XOBCODE,XOBI,XOBERR,XOBLINE,XOBETYPE
+16 SET XOBLINE=0
+17 ;
+18 DO ADD($$VLHDR($GET(XOBDAT("MESSAGE TYPE"))))
+19 DO ADD("<Fault>")
+20 DO ADD("<FaultCode>"_$GET(XOBDAT("ERRORS",1,"FAULT CODE"),"Server")_"</FaultCode>")
+21 DO ADD("<FaultString>"_$GET(XOBDAT("ERRORS",1,"FAULT STRING"),"System Error")_"</FaultString>")
+22 DO ADD("<FaultActor>"_$GET(XOBDAT("ERRORS",1,"FAULT ACTOR"))_"</FaultActor>")
+23 DO ADD("<Detail>")
+24 SET XOBERR=0
+25 FOR
SET XOBERR=$ORDER(XOBDAT("ERRORS",XOBERR))
if 'XOBERR
QUIT
Begin DoDot:1
+26 SET XOBCODE=$GET(XOBDAT("ERRORS",XOBERR,"CODE"),0)
+27 SET XOBETYPE=$GET(XOBDAT("ERRORS",XOBERR,"ERROR TYPE"),0)
+28 DO ADD("<Error type="""_XOBETYPE_""" code="""_XOBCODE_""" >")
+29 DO ADD("<Message>")
+30 IF $GET(XOBDAT("ERRORS",XOBERR,"CDATA"))
DO ADD("<![CDATA[")
+31 SET XOBI=0
+32 FOR
SET XOBI=$ORDER(XOBDAT("ERRORS",XOBERR,"MESSAGE",XOBI))
if 'XOBI
QUIT
Begin DoDot:2
+33 DO ADD(XOBDAT("ERRORS",XOBERR,"MESSAGE",XOBI))
End DoDot:2
+34 IF $GET(XOBDAT("ERRORS",XOBERR,"CDATA"))
DO ADD("]]>")
+35 DO ADD("</Message>")
+36 DO ADD("</Error>")
End DoDot:1
+37 DO ADD("</Detail>")
+38 DO ADD("</Fault>")
+39 DO ADD($$ENVFTR())
+40 ;
+41 QUIT
+42 ;
ADD(TXT) ; -- add line
+1 SET XOBLINE=XOBLINE+1
+2 SET @XOBY@(XOBLINE)=TXT
+3 QUIT
+4 ;
GETRATE() ; -- get J2SE heartbeat rate in seconds
+1 NEW X
+2 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",2)
+3 QUIT $SELECT(X:X,1:180)
+4 ;
GETDELTA() ; -- get J2SE latency delta in seconds
+1 NEW X
+2 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",3)
+3 QUIT $SELECT(X:X,1:180)
+4 ;
GETASTO() ; -- get J2EE application server time out in seconds (one day = 86400)
+1 NEW X
+2 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",4)
+3 QUIT $SELECT(X:X,1:86400)
+4 ;
GETRASTO() ; -- get J2EE application server reauthenticated session time out in seconds (ten minutes = 600)
+1 NEW X
+2 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",5)
+3 QUIT $SELECT(X:X,1:600)
+4 ;
TOFLAG ; -- set timed out flag
+1 ; -- if run in non-VistALink environment never time out ; set both now & start = $h
+2 SET XOBDATA("XOB RPC","TIMED OUT")=($$HDIFF^XLFDT($HOROLOG,$GET(XOBDATA("XOB RPC","START"),$HOROLOG),2)>$$GETTO())
+3 QUIT
+4 ;
TOCHK() ; -- did RPC timeout?
+1 QUIT +$GET(XOBDATA("XOB RPC","TIMED OUT"))
+2 ;
ENVHDR(TYPE,SCHEMA) ; -- vistalink beg tag (header)
+1 NEW X,VLVER
+2 SET X=$$XMLHDR()
+3 SET X=X_"<VistaLink"
+4 SET X=X_" messageType="""_TYPE_""""
+5 SET VLVER="1.6"
+6 ; -- indicates to VL v1.5 client that this VL v1.6 server is backwards compatible
+7 IF $GET(XOBDATA("VL VERSION"))="1.5"
SET VLVER="1.5"
+8 ; -- indicates to VL v1.0 client that this VL v1.6 server is backwards compatible
+9 IF $GET(XOBDATA("VL VERSION"))="1.0"
SET VLVER="1.0"
+10 SET X=X_" version="""_VLVER_""""
+11 SET X=X_" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"""
+12 SET X=X_" xsi:noNamespaceSchemaLocation="""_SCHEMA_""""
+13 ;SET X=X_" xmlns=""http://domain.ext/Foundations"""
+14 SET X=X_">"
+15 QUIT X
+16 ;
ENVFTR() ; -- vistalink end tag (footer)
+1 QUIT "</VistaLink>"
+2 ;
SYSOS(XOBOS) ; -- get system operating system
+1 ; -- DBIA #3522
+2 QUIT $SELECT(XOBOS["OpenM":$$OS^%ZOSV(),XOBOS["DSM":"VMS",1:"Unknown")
+3 ;
