source: WorldVistAEHR/trunk/r/VISTALINK-XOBV/XOBVLIB.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.2 KB
Line 
1XOBVLIB ;; mjk/alb - VistaLink Programmer Library ; 07/27/2002 13:00
2 ;;1.5;VistALink;;Sep 09, 2005
3 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
4 ;
5 QUIT
6 ; --------------------------------------------------------------
7 ; Application Developer Supported Calls
8 ; --------------------------------------------------------------
9 ;
10XMLHDR() ; -- provides current XML standard header
11 QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
12 ;
13CHARCHK(STR) ; -- replace xml character limits with entities
14 NEW A,I,X,Y,Z,NEWSTR
15 SET (Y,Z)=""
16 IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z
17 . FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
18 IF STR["<" FOR SET STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) QUIT:STR'["<"
19 IF STR[">" FOR SET STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) QUIT:STR'[">"
20 IF STR["'" FOR SET STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) QUIT:STR'["'"
21 IF STR["""" FOR SET STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) QUIT:STR'[""""
22 ;
23 FOR I=1:1:$LENGTH(STR) DO
24 . SET X=$EXTRACT(STR,I)
25 . SET A=$ASCII(X)
26 . IF A<31 SET STR=$PIECE(STR,X,1)_$PIECE(STR,X,2,99)
27 QUIT STR
28 ;
29STOP() ; -- called by application to determine if processing should stop gracefully
30 NEW XOBFLAG
31 ;
32 ; -- do checks (only one now is time out)
33 DO TOFLAG
34 ;
35 ; -- set 'stop' flag
36 SET XOBFLAG=$$TOCHK()
37 ;
38 QUIT XOBFLAG
39 ;
40GETTO() ; -- get time out value
41 QUIT $GET(XOBDATA("XOB RPC","TIMEOUT"),300)
42 ;
43SETTO(TO) ; -- set time out value on the fly
44 SET XOBDATA("XOB RPC","TIMEOUT")=TO
45 QUIT 1
46 ;
47 ; --------------------------------------------------------------
48 ; Foundations Developer Calls (Unsupported)
49 ; --------------------------------------------------------------
50 ;
51VLHDR(NUM) ; -- provides current VistaLink standard header
52 NEW X,TYPE,SCHEMA
53 ;
54 ; -- get type info
55 SET X=$PIECE($TEXT(TYPE+NUM),";;",2)
56 SET TYPE=$PIECE(X,"^",2)
57 SET SCHEMA=$PIECE(X,"^",3)
58 QUIT $$ENVHDR(TYPE,SCHEMA)
59 ;
60TYPE ; -- return message types [ number ^ message type ^ schema file ]
61 ;;1^gov.va.med.foundations.rpc.response^rpcResponse.xsd
62 ;;2^gov.va.med.foundations.rpc.fault^rpcFault.xsd
63 ;;3^gov.va.med.foundations.vistalink.system.fault^vlFault.xsd
64 ;;4^gov.va.med.foundations.vistalink.system.response^vlSimpleResponse.xsd
65 ;
66ERROR(XOBDAT) ; -- send error type message
67 NEW XOBI,XOBY,XOBOS
68 SET XOBY="XOBY"
69 ; -- build xml
70 DO BUILD(.XOBY,.XOBDAT)
71 ;
72 USE XOBPORT
73 DO OS^XOBVSKT
74 ; -- write xml
75 DO PRE^XOBVSKT
76 SET XOBI=0 FOR SET XOBI=$ORDER(XOBY(XOBI)) QUIT:'XOBI DO WRITE^XOBVSKT(XOBY(XOBI))
77 ; -- send eot and flush buffer
78 DO POST^XOBVSKT
79 QUIT
80 ;
81BUILD(XOBY,XOBDAT) ; -- store built xml in passed store reference (XOBY)
82 ; -- input format
83 ; XOBDAT("MESSAGE TYPE") = # type of message (ex. 2 = gov.va.med.foundations.vistalink.rpc.fault :: See TYPE tag)
84 ; XOBDAT("ERRORS",<integer>,"CODE") = error code
85 ; XOBDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
86 ; XOBDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
87 ;
88 ; -- SOAP related information
89 ; XOBDAT("ERRORS",<integer>,"FAULT CODE") = high level code on where error occurred (ex. Client, Server, etc.)
90 ; - Default: Server
91 ; XOBDAT("ERRORS",<integer>,"FAULT STRING") = high level fault type text (ex. System Error)
92 ; - Default: System Error
93 ; XOBDAT("ERRORS",<integer>,"FAULT ACTOR") = RPC, routine, etc. running when error occurred
94 ; - Default: [none]
95 ;
96 NEW XOBCODE,XOBI,XOBERR,XOBLINE,XOBETYPE
97 SET XOBLINE=0
98 ;
99 DO ADD($$VLHDR($GET(XOBDAT("MESSAGE TYPE"))))
100 DO ADD("<Fault>")
101 DO ADD("<FaultCode>"_$GET(XOBDAT("ERRORS",1,"FAULT CODE"),"Server")_"</FaultCode>")
102 DO ADD("<FaultString>"_$GET(XOBDAT("ERRORS",1,"FAULT STRING"),"System Error")_"</FaultString>")
103 DO ADD("<FaultActor>"_$GET(XOBDAT("ERRORS",1,"FAULT ACTOR"))_"</FaultActor>")
104 DO ADD("<Detail>")
105 SET XOBERR=0
106 FOR SET XOBERR=$ORDER(XOBDAT("ERRORS",XOBERR)) QUIT:'XOBERR DO
107 . SET XOBCODE=$GET(XOBDAT("ERRORS",XOBERR,"CODE"),0)
108 . SET XOBETYPE=$GET(XOBDAT("ERRORS",XOBERR,"ERROR TYPE"),0)
109 . DO ADD("<Error type="""_XOBETYPE_""" code="""_XOBCODE_""" >")
110 . DO ADD("<Message>")
111 . IF $GET(XOBDAT("ERRORS",XOBERR,"CDATA")) DO ADD("<![CDATA[")
112 . SET XOBI=0
113 . FOR SET XOBI=$ORDER(XOBDAT("ERRORS",XOBERR,"MESSAGE",XOBI)) QUIT:'XOBI DO
114 . . DO ADD(XOBDAT("ERRORS",XOBERR,"MESSAGE",XOBI))
115 . IF $GET(XOBDAT("ERRORS",XOBERR,"CDATA")) DO ADD("]]>")
116 . DO ADD("</Message>")
117 . DO ADD("</Error>")
118 DO ADD("</Detail>")
119 DO ADD("</Fault>")
120 DO ADD($$ENVFTR())
121 ;
122 QUIT
123 ;
124ADD(TXT) ; -- add line
125 SET XOBLINE=XOBLINE+1
126 SET @XOBY@(XOBLINE)=TXT
127 QUIT
128 ;
129GETRATE() ; -- get J2SE heartbeat rate in seconds
130 NEW X
131 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",2)
132 QUIT $SELECT(X:X,1:180)
133 ;
134GETDELTA() ; -- get J2SE latancy delta in seconds
135 NEW X
136 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",3)
137 QUIT $SELECT(X:X,1:180)
138 ;
139GETASTO() ; -- get J2EE application server time out in seconds (one day = 86400)
140 NEW X
141 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",4)
142 QUIT $SELECT(X:X,1:86400)
143 ;
144GETRASTO() ; -- get J2EE application server reauthenticated seesion time out in seconds (ten minutes = 600)
145 NEW X
146 SET X=$PIECE($GET(^XOB(18.01,1,0)),"^",5)
147 QUIT $SELECT(X:X,1:600)
148 ;
149TOFLAG ; -- set timed out flag
150 ; -- if run in non-VistALink environment never time out ; set both now & start = $h
151 SET XOBDATA("XOB RPC","TIMED OUT")=($$HDIFF^XLFDT($HOROLOG,$GET(XOBDATA("XOB RPC","START"),$HOROLOG),2)>$$GETTO())
152 QUIT
153 ;
154TOCHK() ; -- did RPC timeout?
155 QUIT +$GET(XOBDATA("XOB RPC","TIMED OUT"))
156 ;
157ENVHDR(TYPE,SCHEMA) ; -- vistalink beg tag (header)
158 NEW X,VLVER
159 SET X=$$XMLHDR()
160 SET X=X_"<VistaLink"
161 SET X=X_" messageType="""_TYPE_""""
162 ; -- indicates to VL v1.0 client that this VL v1.5 server is backwards compatible
163 SET VLVER="1.5"
164 IF $GET(XOBDATA("VL VERSION"))="1.0" SET VLVER="1.0"
165 SET X=X_" version="""_VLVER_""""
166 SET X=X_" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"""
167 SET X=X_" xsi:noNamespaceSchemaLocation="""_SCHEMA_""""
168 ;SET X=X_" xmlns=""http://med.va.gov/Foundations"""
169 SET X=X_">"
170 QUIT X
171 ;
172ENVFTR() ; -- vistalink end tag (footer)
173 QUIT "</VistaLink>"
174 ;
175SYSOS(XOBOS) ; -- get system operating system
176 ; -- DBIA #3522
177 QUIT $SELECT(XOBOS["OpenM":$$OS^%ZOSV(),XOBOS["DSM":"VMS",1:"Unknown")
178 ;
Note: See TracBrowser for help on using the repository browser.