XWBUTL ;OIFO-Oakland/REM - M2M Programmer Utilities ;05/17/2002 17:46
;;1.1;RPC BROKER;**28,34**;Mar 28, 1997
;
QUIT
;
;p34 -correct typo changing ">" to "<" in QUIT:STR'[">" - CHARCHK.
; -add "[]" as escape characters - CHARCHK.
;
;
XMLHDR() ; -- provides current XML standard header
QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
;
ERROR(XWBDAT) ; -- send error type message
NEW XWBI,XWBY
SET XWBY="XWBY"
; -- build xml
DO BUILD(.XWBY,.XWBDAT)
;
; -- write xml
DO PRE^XWBRL
SET XWBI=0 FOR SET XWBI=$O(XWBY(XWBI)) Q:'XWBI DO WRITE^XWBRL(XWBY(XWBI))
; -- send eot and flush buffer
DO POST^XWBRL
QUIT
;
BUILD(XWBY,XWBDAT) ; -- build xml in passed store reference (XWBY)
; -- input format
; XWBDAT("MESSAGE TYPE") = type of message (ex. Gov.VA.Med.RPC.Error)
; XWBDAT("ERRORS",<integer>,"CODE") = error code
; XWBDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
; XWBDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
;
NEW XWBCODE,XWBI,XWBERR,XWBLINE,XWBETYPE
SET XWBLINE=0
;
DO ADD($$XMLHDR())
DO ADD("<vistalink type="""_$G(XWBDAT("MESSAGE TYPE"))_""" >")
DO ADD("<errors>")
SET XWBERR=0
FOR SET XWBERR=$O(XWBDAT("ERRORS",XWBERR)) Q:'XWBERR DO
. SET XWBCODE=$G(XWBDAT("ERRORS",XWBERR,"CODE"),0)
. SET XWBETYPE=$G(XWBDAT("ERRORS",XWBERR,"ERROR TYPE"),0)
. DO ADD("<error type="""_XWBETYPE_""" code="""_XWBCODE_""" >")
. DO ADD("<msg>")
. IF $G(XWBDAT("ERRORS",XWBERR,"CDATA")) DO ADD("<![CDATA[")
. SET XWBI=0
. FOR SET XWBI=$O(XWBDAT("ERRORS",XWBERR,"MESSAGE",XWBI)) Q:'XWBI DO
. . DO ADD(XWBDAT("ERRORS",XWBERR,"MESSAGE",XWBI))
. IF $G(XWBDAT("ERRORS",XWBERR,"CDATA")) DO ADD("]]>")
. DO ADD("</msg>")
. DO ADD("</error>")
DO ADD("</errors>")
DO ADD("</vistalink>")
;
QUIT
;
ADD(TXT) ; -- add line
SET XWBLINE=XWBLINE+1
SET @XWBY@(XWBLINE)=TXT
QUIT
;
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'["&"
;
;*p34-typo, change ">" to "<" in Q:STR'[...
IF STR["<" FOR SET STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<"
IF STR[">" FOR SET STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">"
IF STR["'" FOR SET STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'"
IF STR["""" FOR SET STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) QUIT:STR'[""""
;
;*p34-add "[]" as escape characters.
IF STR["[" FOR SET STR=$PIECE(STR,"[",1)_"["_$PIECE(STR,"[",2,99) Q:STR'["["
IF STR["]" FOR SET STR=$PIECE(STR,"]",1)_"]"_$PIECE(STR,"]",2,99) Q:STR'["]"
;
;Remove ctrl char's
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))
;FOR I=1:1:$LENGTH(STR) DO
;. SET X=$EXTRACT(STR,I)
;. SET A=$ASCII(X)
;. IF A<31 S STR=$P(STR,X,1)_$P(STR,X,2,99)
QUIT STR
;
;D=0 STR 2 NUM, D=1 NUM 2 STR
NUM(STR,D) ;Convert a string to numbers
N I,Y
S Y="",D=$G(D,0)
I D=0 F I=1:1:$L(STR) S Y=Y_$E(1000+$A(STR,I),2,4)
I D=1 F I=1:3:$L(STR) S Y=Y_$C($E(STR,I,I+2))
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBUTL 3246 printed Apr 09, 2024@21:39:43 Page 2
XWBUTL ;OIFO-Oakland/REM - M2M Programmer Utilities ;05/17/2002 17:46
+1 ;;1.1;RPC BROKER;**28,34**;Mar 28, 1997
+2 ;
+3 QUIT
+4 ;
+5 ;p34 -correct typo changing ">" to "<" in QUIT:STR'[">" - CHARCHK.
+6 ; -add "[]" as escape characters - CHARCHK.
+7 ;
+8 ;
XMLHDR() ; -- provides current XML standard header
+1 QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
+2 ;
ERROR(XWBDAT) ; -- send error type message
+1 NEW XWBI,XWBY
+2 SET XWBY="XWBY"
+3 ; -- build xml
+4 DO BUILD(.XWBY,.XWBDAT)
+5 ;
+6 ; -- write xml
+7 DO PRE^XWBRL
+8 SET XWBI=0
FOR
SET XWBI=$ORDER(XWBY(XWBI))
if 'XWBI
QUIT
DO WRITE^XWBRL(XWBY(XWBI))
+9 ; -- send eot and flush buffer
+10 DO POST^XWBRL
+11 QUIT
+12 ;
BUILD(XWBY,XWBDAT) ; -- build xml in passed store reference (XWBY)
+1 ; -- input format
+2 ; XWBDAT("MESSAGE TYPE") = type of message (ex. Gov.VA.Med.RPC.Error)
+3 ; XWBDAT("ERRORS",<integer>,"CODE") = error code
+4 ; XWBDAT("ERRORS",<integer>,"ERROR TYPE") = type of error (system/application/security)
+5 ; XWBDAT("ERRORS",<integer>,"MESSAGE",<integer>) = error message
+6 ;
+7 NEW XWBCODE,XWBI,XWBERR,XWBLINE,XWBETYPE
+8 SET XWBLINE=0
+9 ;
+10 DO ADD($$XMLHDR())
+11 DO ADD("<vistalink type="""_$GET(XWBDAT("MESSAGE TYPE"))_""" >")
+12 DO ADD("<errors>")
+13 SET XWBERR=0
+14 FOR
SET XWBERR=$ORDER(XWBDAT("ERRORS",XWBERR))
if 'XWBERR
QUIT
Begin DoDot:1
+15 SET XWBCODE=$GET(XWBDAT("ERRORS",XWBERR,"CODE"),0)
+16 SET XWBETYPE=$GET(XWBDAT("ERRORS",XWBERR,"ERROR TYPE"),0)
+17 DO ADD("<error type="""_XWBETYPE_""" code="""_XWBCODE_""" >")
+18 DO ADD("<msg>")
+19 IF $GET(XWBDAT("ERRORS",XWBERR,"CDATA"))
DO ADD("<![CDATA[")
+20 SET XWBI=0
+21 FOR
SET XWBI=$ORDER(XWBDAT("ERRORS",XWBERR,"MESSAGE",XWBI))
if 'XWBI
QUIT
Begin DoDot:2
+22 DO ADD(XWBDAT("ERRORS",XWBERR,"MESSAGE",XWBI))
End DoDot:2
+23 IF $GET(XWBDAT("ERRORS",XWBERR,"CDATA"))
DO ADD("]]>")
+24 DO ADD("</msg>")
+25 DO ADD("</error>")
End DoDot:1
+26 DO ADD("</errors>")
+27 DO ADD("</vistalink>")
+28 ;
+29 QUIT
+30 ;
ADD(TXT) ; -- add line
+1 SET XWBLINE=XWBLINE+1
+2 SET @XWBY@(XWBLINE)=TXT
+3 QUIT
+4 ;
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 ;
+6 ;*p34-typo, change ">" to "<" in Q:STR'[...
+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 IF STR["'"
FOR
SET STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99)
if STR'["'"
QUIT
+10 IF STR[""""
FOR
SET STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99)
if STR'[""""
QUIT
+11 ;
+12 ;*p34-add "[]" as escape characters.
+13 IF STR["["
FOR
SET STR=$PIECE(STR,"[",1)_"["_$PIECE(STR,"[",2,99)
if STR'["["
QUIT
+14 IF STR["]"
FOR
SET STR=$PIECE(STR,"]",1)_"]"_$PIECE(STR,"]",2,99)
if STR'["]"
QUIT
+15 ;
+16 ;Remove ctrl char's
+17 SET STR=$TRANSLATE(STR,$CHAR(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))
+18 ;FOR I=1:1:$LENGTH(STR) DO
+19 ;. SET X=$EXTRACT(STR,I)
+20 ;. SET A=$ASCII(X)
+21 ;. IF A<31 S STR=$P(STR,X,1)_$P(STR,X,2,99)
+22 QUIT STR
+23 ;
+24 ;D=0 STR 2 NUM, D=1 NUM 2 STR
NUM(STR,D) ;Convert a string to numbers
+1 NEW I,Y
+2 SET Y=""
SET D=$GET(D,0)
+3 IF D=0
FOR I=1:1:$LENGTH(STR)
SET Y=Y_$EXTRACT(1000+$ASCII(STR,I),2,4)
+4 IF D=1
FOR I=1:3:$LENGTH(STR)
SET Y=Y_$CHAR($EXTRACT(STR,I,I+2))
+5 QUIT Y
