- 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 Jan 18, 2025@03:45:51 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 ;