Changeset 1330 for ccr/branches/ohum/p/C0CMAIL2.m
- Timestamp:
- Jan 3, 2012, 11:45:29 PM (13 years ago)
- File:
-
- 1 edited
-
ccr/branches/ohum/p/C0CMAIL2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CMAIL2.m
r1329 r1330 1 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 ;;0.1;C0C;nopatch;noreleasedate 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 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 GETMSG(C0CDATA,C0CINPUT) 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 GATHER(DUZ,NAM,LST) 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 GETTYP(D0) 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 NAME(NM) 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 TIME(Y) 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 DETAIL(C0CDATA,C0CINPUT) 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 GETTYP2(D0) 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 DECODER 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 NORMAL(OUTXML,INXML) 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 UPPER(X) 435 436 437 438 ERROR(ER) 439 440 441 442 443 444 445 446 447 448 449 450 ER01 451 ER02 452 ER03 453 ER04 454 ER05 455 ER06 456 ER07 457 ER08 458 ER10 459 ER11 460 ER12 461 462 463 464 2 ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research 4 ; Modified 3110615@1040 5 ; rcr@rcresearch.us 6 ; Licensed under the terms of the GNU 7 ;General Public License See attached copy of the License. 8 ; 9 ;This program is free software; you can redistribute it and/or modify 10 ;it under the terms of the GNU General Public License as published by 11 ;the Free Software Foundation; either version 2 of the License, or 12 ;(at your option) any later version. 13 ; 14 ;This program is distributed in the hope that it will be useful, 15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;GNU General Public License for more details. 18 ; 19 ;You should have received a copy of the GNU General Public License along 20 ;with this program; if not, write to the Free Software Foundation, Inc., 21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 22 ; 23 ; ------------------ 24 ;Entry Points 25 ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments 26 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) 27 ; Input: 28 ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL 29 ; or "*" for all boxes, default is "IN" if missing]" 30 ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", 31 ; "*" for All or 9,999 maximum 32 ; MALL?1.n = that number of the n most recent 33 ; Internally: 34 ; BNAM = Box Name 35 ; Output: 36 ; C0CDATA 37 ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket 38 ; (BNAM,"MSG",C0CIEN,"FROM")=Name 39 ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address 40 ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address 41 ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title 42 ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments 43 ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text 44 ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text 45 ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes 46 ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) 47 ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line 48 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details 49 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data 50 ; 51 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments 52 ; Input; 53 ; D0 - The IEN for the message in file 3.9, MESSAGE global 54 ; Output 55 ; OUTBF - The array of your choice to save the expanded and decoded message. 56 ; 57 GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data 58 K:'$G(C0CDATA("KEEP")) C0CDATA 59 N U 60 S U="^" 61 D:$G(C0CINPUT) 62 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL 63 . S INPUT=C0CINPUT 64 . S DUZ=+INPUT 65 . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q 66 . ; 67 . D:$D(^XMB(3.7,DUZ,0))#2 68 . . S MBLST=$P(INPUT,";",2) 69 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag 70 . . S:MALL["*" MALL=99999 71 . . ; Only one of these can be correct 72 . . D 73 . . . ; If nul, make it "IN" only 74 . . . I MBLST="" D QUIT 75 . . . . S MBLST("IN")=0,I=0 76 . . . . D GATHER(DUZ,"IN",.LST) 77 . . . .QUIT 78 . . . ; 79 . . . ; If "*", Get all Mailboxes and look for New Messages 80 . . . I MBLST["*" D QUIT 81 . . . . N NAM,NUM 82 . . . . S NUM=0 83 . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D 84 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) 85 . . . . . D GATHER(DUZ,NAM,.LST) 86 . . . . .QUIT 87 . . . .QUIT 88 . . . ; 89 . . . ; If comma separated, look for mailboxes with new messages 90 . . . I $L(MBLST,",")>1 D QUIT 91 . . . . S NAM="" 92 . . . . N TN,V 93 . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D 94 . . . . . I $L(V) D QUIT 95 . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) 96 . . . . . . S:NAM="" NAM=V 97 . . . . . . D GATHER(DUZ,NAM,.LST) 98 . . . . . .QUIT 99 . . . . . ; 100 . . . . . D ERROR("ER08") 101 . . . . .QUIT 102 . . . .QUIT 103 . . . ; 104 . . . ; If only 1 mailbox named, go get it 105 . . . I $L(MBLST) D QUIT 106 . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT 107 . . . . ; 108 . . . . D ERROR("ER07") 109 . . .QUIT 110 . . MERGE C0CDATA=LST 111 . .QUIT 112 .QUIT 113 QUIT 114 ; =================== 115 GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail 116 N I,J,K,L 117 S (I,K)=0 118 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) 119 F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D 120 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) 121 . D ; :L 122 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails 123 . . S LST(NAM,"MSG",I)=L 124 . . D GETTYP(I) 125 . .QUIT 126 .QUIT 127 S LST(NAM,"NUMBER")=K 128 QUIT 129 ; =================== 130 ; D0 is the IEN into the Message Global ^XMB(3.9,D0) 131 ; The products of these emails are scanned to identify 132 ; the number of documents stored in the MIME package. 133 ; The protocol runs like this; 134 ; Line 1 is the --separator 135 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD 136 ; Line n+2 thru t-1 where t does NOT have "Content-" 137 ; Line t is Next Section Terminator, or Message Terminator, --separator 138 ; Line t+1 should not exist in the data set if Message Terminator 139 ; CON = "Content-" 140 ; FLG = "--" 141 ; SEP = FLG+7 or more characters ; Separator 142 ; END = SEP+FLG 143 ; SGC = Segment Count 144 ; Note: separator is a string of specific characters of 145 ; indeterminate length 146 ; LST() the transfer array 147 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line 148 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data 149 ; 150 GETTYP(D0) ; Look for the goodies in the Mail 151 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM 152 S CON="Content-" 153 S FLG="--" 154 S SEP="" ; Start SEP as null, so we can use this to help identify the type 155 S (BCN,CNT,D1,END,SGC)=0 156 S XX=$G(^XMB(3.9,D0,0)) 157 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 158 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) 159 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 160 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) 161 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) 162 ; Get the folks the email is sent to. 163 S D1=0 164 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D 165 . N T 166 . S T=+$G(^XMB(3.9,D0,1,D1,0)) 167 . S:T T=$P($G(^VA(200,+T,0)),"^") 168 . S LST("TO",D1)=T 169 . S T=$G(^XMB(3.9,D0,6,D1,0)) 170 . S:T T=$P($G(^VA(200,+T,0)),"^") 171 . S:T="" T="<Unknown>" 172 . S LST("TO NAME",D1)=T 173 .QUIT 174 ; Preload first Segment (0) with beginning on Line 1 175 ; if not a 64bit 176 S LST(NAM,"MSG",D0,"SEG",0)=1 177 S D1=.9999,SEP="@@" 178 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 179 . ; Clear any control characters (cr/lf/ff) off 180 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 181 . ; Enter once to set the SEP to capture the separator 182 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q 183 . . S SEP=X,END=X_FLG 184 . . S (CNT,SGC)=1,BCN=0 185 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 186 . .QUIT 187 . ; 188 . ; A new separator is set, process original 189 . I X=SEP D QUIT 190 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) 191 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) 192 . . S SGC=SGC+1,BCN=0 193 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 194 . .QUIT 195 . ; 196 . S BCN=BCN+$L(X) 197 . I X[CON D Q 198 . . S J=$P($P(X,";"),CON,2) 199 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) 200 . .QUIT 201 . ; 202 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X 203 .QUIT 204 QUIT 205 ; =================== 206 NAME(NM) ; Return the name of the Sender 207 N NAME 208 S NAME="<Unknown Sender>" 209 D 210 . ; Look first for a value to use with the NEW PERSON file 211 . ; 212 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q 213 . ; 214 . I $L(NM) S NAME=NM Q 215 . ; 216 . ; Else, pull the data from the message and display the foreign source 217 . ; of the message. 218 . N T 219 . S VAL=$G(^XMB(3.9,D0,.7)) 220 . S:VAL T=$P(^VA(200,VAL,0),U) 221 . I $L($G(T)) S NAME=T Q 222 . ; 223 .QUIT 224 QUIT NAME 225 ; =================== 226 TIME(Y) ; The time and date of the sending 227 X ^DD("DD") 228 QUIT Y 229 ; =================== 230 ; Segments in Message need to be identified and decoded properly 231 ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message 232 ; ARRAY will have the details of this one call 233 ; 234 ; Inputs; 235 ; C0CINPUT - The IEN of the message to expand 236 ; Outputs; 237 ; C0CDATA - Carrier for the returned structure of the Message 238 ; C0CDATA(D0,"SEG")=number of SEGMENTS 239 ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type 240 ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details 241 ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details 242 ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details 243 ; 244 DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery 245 N LST,D0,D1,U 246 S U="^" 247 S D0=+$G(C0CINPUT) 248 I D0 D QUIT 249 . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT 250 . ; 251 . D GETTYP2(D0) 252 . I $D(LST) M C0CDATA(D0)=LST Q 253 . ; 254 . D ERROR("ER02") 255 .QUIT 256 QUIT 257 ; =================== 258 ; End note if needed 259 ; MSK - Set of characters that do not exist in 64 bit encoding 260 GETTYP2(D0) ; Try to get the types and MSK for the 261 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM 262 S CON="Content-",U="^" 263 S FLG="--" 264 S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" 265 S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type 266 S (BCN,CNT,D1,END,SGC)=0 267 S XX=$G(^XMB(3.9,D0,0)) 268 ; S K=$P(^XMB(3.9,D0,2,0),U,3) 269 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 270 S LST("CREATED")=$$TIME($P(XX,U,3)) 271 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 272 S LST("FROM")=$$NAME(XXNM) 273 ; Get the folks the email is sent to. 274 S D1=0 275 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" 276 . N I,T 277 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) 278 . S:T T=$P($G(^VA(200,T,0)),"^") 279 . S LST("TO",+D1)=T 280 . S T=$G(^XMB(3.9,D0,6,+D1,0)) 281 . S:T="" T=$P($G(^VA(200,+T,0)),"^") 282 . S:T="" T="<Unknown>" 283 . S LST("TO NAME",D1)=T 284 .QUIT 285 ; Get the Header for the message 286 S D1=0 287 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D 288 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) 289 .QUIT 290 ; Start walking the different sections 291 S D1=.99999,SEP="@@",SGC=0 292 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 293 . ; Clear any control characters (cr/lf/ff) off 294 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 295 . ; Enter once to set the SEP to capture the separator 296 . I (SEP="@@")&(X?2."--"5.AN.E) D Q 297 . . I $L(X,FLG)>2 D ERROR("ER10") 298 . . S SEP=X,END=X_FLG 299 . . S (CNT,SGC)=1,BCN=0 300 . . S LST("SEG",SGC)=D1 301 . .QUIT 302 . ; 303 . ; A new SEGMENT separator is set, process original 304 . I X=SEP D QUIT 305 . . ; Save Current Values 306 . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) 307 . . ; Close this Segment and prepare to start a New Segment 308 . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) 309 . . ; Put the result in LST("SEG",SGC,"XML") 310 . . I $L(BF) D 311 . . . S ZN=1 312 . . . N I,T,TBF 313 . . . S TBF=BF 314 . . . F I=1:1:($L(TBF,"=")) D 315 . . . . S BF=$P(TBF,"=",I)_"=" 316 . . . . I BF'="=" D DECODER 317 . . . .QUIT 318 . . . S BF="" 319 . . .QUIT 320 . . S SGC=SGC+1,BCN=0 321 . . ; Incriment SGC to start a new Segment 322 . . S LST("SEG",SGC)=D1 323 . .QUIT 324 . ; 325 . ; Accumulate the 64 bit encoding 326 . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT 327 . ; 328 . ; Ending Condition, close out the Segment 329 . I X=END D QUIT 330 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) 331 . . I $L(BF) S ZN=1 D DECODER S BF="" Q 332 . .QUIT 333 . ; 334 . ; Accumulate the lengths of other lines of the message 335 . S BCN=BCN+$L(X) 336 . ; Split out the Content Info 337 . I X[CON D Q 338 . . S J=$P(X,CON,2) 339 . . I J[" boundary=" D 340 . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG 341 . . . Q:SEP?2"-"5.ANP 342 . . . ; 343 . . . D ERROR("ER11") 344 . . . Q:SEP'[" " 345 . . . ; 346 . . . D ERROR("ER12") 347 . . .QUIT 348 . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) 349 . .QUIT 350 . ; 351 . ; Everything else is Text, Check for CCR/CCD. 352 . N KK,UBF 353 . D 354 . . S UBF=$$UPPER(X) 355 . . I UBF["<CONTINUITYOFCARERECORD" S $P(LST("SEG",SGC),U,3)="CCR" Q 356 . . ; 357 . . I UBF["<CLINICALDOCUMENT" S $P(LST("SEG",SGC),U,3)="CCD" Q 358 . .QUIT 359 . ; Look for directives in the text before it gets published 360 . ; Look for "=3D" and replace it with a single "=". I can do more parsing 361 . ; but there may be situations where the line has been wrapped. 362 . D:X["=3D" 363 . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D" 364 . .QUIT 365 . S LST("SEG",SGC,"TXT",D1)=X 366 .QUIT 367 QUIT 368 ; =================== 369 ; Break down the Buffer Array so it can be saved. 370 ; BF is passed in. 371 DECODER ; 372 N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE 373 S ZBF=BF 374 ; Full Buffer, BF, now check for Encryption and Unpack 375 F RCNT=1:1:$L(ZBF,"=") D 376 . N BF 377 . S BF=$P(ZBF,"=",RCNT) 378 . ; Unpacking the 64 bit encoding 379 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) 380 . D:$L(TBF) 381 . . N C,OK,OKCNT,KK,XBF,UBF 382 . . D 383 . . . S UBF=$$UPPER(TBF) 384 . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q 385 . . . ; 386 . . . I UBF["<CLINICALDOCUMENT XMLNS=" S $P(LST("SEG",SGC),U,3)="CCD" Q 387 . . .QUIT 388 . . ; Check for Bad Signature Decoding, after 100 bad characters 389 . . S OK=1,OKCNT=0 390 . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q 391 . . ; 392 . . D 393 . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q 394 . . . ; 395 . . . S BF=BF_"=" 396 . . . D NORMAL(.XBF,.TBF) 397 . . .QUIT 398 . . M LST("SEG",SGC,"XML",RCNT)=XBF 399 . .QUIT 400 .QUIT 401 QUIT 402 ; =================== 403 ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT 404 ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT 405 ; >D NORMAL^C0CMAIL(.OUT,BF) 406 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML 407 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME 408 ; 409 N ZN,OUTBF,XX,ZSEP 410 S INXML=$TR(INXML,$C(10,12,13)) 411 S ZN=1,ZSEP=">" 412 S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 413 F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" 414 . S XX=$P(INXML,"><",ZN) 415 . S:$E($RE(XX))=">" ZSEP="" 416 . Q:XX="" 417 . ; 418 . S XX="<"_XX_ZSEP 419 . D 420 . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q 421 . . ; 422 . . D ERROR("ER05") 423 . . F ZL=ZL+1:1 D Q:XX="" 424 . . . N XL 425 . . . S XL=$E(XX,1,4000) 426 . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters 427 . . . S OUTBF(ZL)=XL 428 . . .QUIT 429 . .QUIT 430 .QUIT 431 M OUTXML=OUTBF 432 QUIT 433 ; =================== 434 UPPER(X) ; Convert any lowercase letters to Uppercase letters 435 QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 436 ; =================== 437 ; EN is a counter that remains between error events 438 ERROR(ER) ; Error Handler 439 N TXXQ,XXXQ 440 S XXXQ="Unknown Error Encountered = "_ER 441 S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) 442 I TXXQ'="" D 443 . I TXXQ["_" X "S TXXQ="_TXXQ 444 . S XXXQ=TXXQ 445 .QUIT 446 S EN(ER)=$G(EN(ER))+1 447 S LST("ERR",ER,EN(ER))=XXXQ 448 QUIT 449 ; =================== 450 ER01 ;;Message Missing 451 ER02 ;;Message Text Missing 452 ER03 ;;Message Not Identifiable 453 ER04 ;;Segment is too large 454 ER05 ;;Mailbox Missing 455 ER06 ;;"User Missing = "_$G(DUZ) 456 ER07 ;;"Bad DUZ = "_DUZ 457 ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) 458 ER10 ;;"Bad Separator found = "_X 459 ER11 ;;"Non-Standard Separator Found:>"_$G(J) 460 ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) 461 ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv 462 ; End note if needed 463 QUIT 464 ; ===================
Note:
See TracChangeset
for help on using the changeset viewer.
