Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XOBVLIB

XOBVLIB.m

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