source: FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBUTL.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1XWBUTL ;OIFO-Oakland/REM - M2M Programmer Utilities ;05/17/2002 17:46
2 ;;1.1;RPC BROKER;**28,34**;Mar 28, 1997
3 ;
4 QUIT
5 ;
6 ;p34 -correct typo changing ">" to "<" in QUIT:STR'[">" - CHARCHK.
7 ; -add "[]" as escape characters - CHARCHK.
8 ;
9 ;
10XMLHDR() ; -- provides current XML standard header
11 QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
12 ;
13ERROR(XWBDAT) ; -- send error type message
14 NEW XWBI,XWBY
15 SET XWBY="XWBY"
16 ; -- build xml
17 DO BUILD(.XWBY,.XWBDAT)
18 ;
19 ; -- write xml
20 DO PRE^XWBRL
21 SET XWBI=0 FOR SET XWBI=$O(XWBY(XWBI)) Q:'XWBI DO WRITE^XWBRL(XWBY(XWBI))
22 ; -- send eot and flush buffer
23 DO POST^XWBRL
24 QUIT
25 ;
26BUILD(XWBY,XWBDAT) ; -- build xml in passed store reference (XWBY)
27 ; -- input format
28 ; XWBDAT("MESSAGE TYPE") = type of message (ex. Gov.VA.Med.RPC.Error)
29 ; XWBDAT("ERRORS",<integer>,"CODE") = error code
30 ; XWBDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
31 ; XWBDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
32 ;
33 NEW XWBCODE,XWBI,XWBERR,XWBLINE,XWBETYPE
34 SET XWBLINE=0
35 ;
36 DO ADD($$XMLHDR())
37 DO ADD("<vistalink type="""_$G(XWBDAT("MESSAGE TYPE"))_""" >")
38 DO ADD("<errors>")
39 SET XWBERR=0
40 FOR SET XWBERR=$O(XWBDAT("ERRORS",XWBERR)) Q:'XWBERR DO
41 . SET XWBCODE=$G(XWBDAT("ERRORS",XWBERR,"CODE"),0)
42 . SET XWBETYPE=$G(XWBDAT("ERRORS",XWBERR,"ERROR TYPE"),0)
43 . DO ADD("<error type="""_XWBETYPE_""" code="""_XWBCODE_""" >")
44 . DO ADD("<msg>")
45 . IF $G(XWBDAT("ERRORS",XWBERR,"CDATA")) DO ADD("<![CDATA[")
46 . SET XWBI=0
47 . FOR SET XWBI=$O(XWBDAT("ERRORS",XWBERR,"MESSAGE",XWBI)) Q:'XWBI DO
48 . . DO ADD(XWBDAT("ERRORS",XWBERR,"MESSAGE",XWBI))
49 . IF $G(XWBDAT("ERRORS",XWBERR,"CDATA")) DO ADD("]]>")
50 . DO ADD("</msg>")
51 . DO ADD("</error>")
52 DO ADD("</errors>")
53 DO ADD("</vistalink>")
54 ;
55 QUIT
56 ;
57ADD(TXT) ; -- add line
58 SET XWBLINE=XWBLINE+1
59 SET @XWBY@(XWBLINE)=TXT
60 QUIT
61 ;
62CHARCHK(STR) ; -- replace xml character limits with entities
63 NEW A,I,X,Y,Z,NEWSTR
64 SET (Y,Z)=""
65 IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z
66 . FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
67 ;
68 ;*p34-typo, change ">" to "<" in Q:STR'[...
69 IF STR["<" FOR SET STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) Q:STR'["<"
70 IF STR[">" FOR SET STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) Q:STR'[">"
71 IF STR["'" FOR SET STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) Q:STR'["'"
72 IF STR["""" FOR SET STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) QUIT:STR'[""""
73 ;
74 ;*p34-add "[]" as escape characters.
75 IF STR["[" FOR SET STR=$PIECE(STR,"[",1)_"&#91;"_$PIECE(STR,"[",2,99) Q:STR'["["
76 IF STR["]" FOR SET STR=$PIECE(STR,"]",1)_"&#93;"_$PIECE(STR,"]",2,99) Q:STR'["]"
77 ;
78 ;Remove ctrl char's
79 S STR=$TR(STR,$C(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31))
80 ;FOR I=1:1:$LENGTH(STR) DO
81 ;. SET X=$EXTRACT(STR,I)
82 ;. SET A=$ASCII(X)
83 ;. IF A<31 S STR=$P(STR,X,1)_$P(STR,X,2,99)
84 QUIT STR
85 ;
86 ;D=0 STR 2 NUM, D=1 NUM 2 STR
87NUM(STR,D) ;Convert a string to numbers
88 N I,Y
89 S Y="",D=$G(D,0)
90 I D=0 F I=1:1:$L(STR) S Y=Y_$E(1000+$A(STR,I),2,4)
91 I D=1 F I=1:3:$L(STR) S Y=Y_$C($E(STR,I,I+2))
92 Q Y
Note: See TracBrowser for help on using the repository browser.