XWBUTL.m

XWBUTL ;OIFO-Oakland/REM - M2M Programmer Utilities ;05/17/2002  17:46

 ;;1.1;RPC BROKER;**28,34**;Mar 28, 1997;Build 13

 ;

 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

XWBUTL    ;OIFO-Oakland/REM - M2M Programmer Utilities ;05/17/2002  17:46

 +1       ;;1.1;RPC BROKER;**28,34**;Mar 28, 1997;Build 13

 +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