Changeset 1333 for ccr/branches/ohum/p/C0CMAIL3.m
- Timestamp:
- Jan 4, 2012, 12:05:49 AM (12 years ago)
- File:
-
- 1 edited
-
ccr/branches/ohum/p/C0CMAIL3.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CMAIL3.m
r1332 r1333 1 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 V ;;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 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 407 408 CONTENT(D1) 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 BOUNDARY(X) 427 428 429 430 431 432 433 434 435 436 437 438 439 DECODER(BF,TYP) 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 NORMAL(OUTXML,INXML) 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 UPPER(X) 504 505 506 507 ERROR(ER) 508 509 510 511 512 513 514 515 516 517 518 519 ER01 520 ER02 521 ER03 522 ER04 523 ER05 524 ER06 525 ER07 526 ER08 527 ER10 528 ER11 529 ER12 530 ER13 531 532 533 534 2 ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research 4 ; Modified 3110619@2038 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="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" 264 S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type 265 S (BCN,CNT,D1,END,SGC)=0 266 S XX=$G(^XMB(3.9,D0,0)) 267 ; S K=$P(^XMB(3.9,D0,2,0),U,3) 268 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 269 S LST("CREATED")=$$TIME($P(XX,U,3)) 270 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 271 S LST("FROM")=$$NAME(XXNM) 272 ; Get the folks the email is sent to. 273 S D1=0 274 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" 275 . N I,T 276 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) 277 . S:T T=$P($G(^VA(200,T,0)),"^") 278 . S LST("TO",+D1)=T 279 . S T=$G(^XMB(3.9,D0,6,+D1,0)) 280 . S:T="" T=$P($G(^VA(200,+T,0)),"^") 281 . S:T="" T="<Unknown>" 282 . S LST("TO NAME",D1)=T 283 .QUIT 284 ; Get the Header for the message and store as "HDR" 285 S D1=0,SGC=0 286 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D 287 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) 288 .QUIT 289 N BNDRY,STKL,SEG 290 S STKL=0,SEG=0 291 ; Find boundaries and map them 292 S D1=0 293 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 294 . ; Clear any control characters (cr/lf/ff) off 295 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 296 . ; Look for " boundary=" in the various parts. Map the establishment and the 297 . ; terminator markers and the actual boundary markers. 298 . I X[" boundary=" D Q 299 . . S SEP=$P(X," boundary=",2) 300 . . S:$E(SEP)="""" SEP=$TR(SEP,"""") 301 . . S STKL=STKL+1 302 . . S END=SEP_FLG 303 . . S BNDRY(STKL,SEP)=0 304 . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 305 . .QUIT 306 . ; 307 . ; Look for information as to how amy boudaries are present and where 308 . ; they terminate 309 . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") 310 . . ; Boundary Found 311 . . I $D(BNDRX(X)) D Q 312 . . . S SEG=SEG+1 313 . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" 314 . . . S BND1(D1)=STKL_";B;"_SEG_";"_X 315 . . . S BNDR(X,D1,"B")=STKL 316 . . . I BNDRX(X)=X D ERROR("ER13") 317 . . .QUIT 318 . . ; 319 . . ; Boundary Terminator 320 . . I $D(BNDRZ(X)) D Q 321 . . . S BNDR(X,D1,"E")=STKL 322 . . . S BNDRZ(X)=BNDRZ(X)+1 323 . . . S BND1(D1)=STKL_";E;"_SEG_";"_X 324 . . . S SEG=SEG+1 325 . . . I BNDRX(X)=X D ERROR("ER14") 326 . . . S STKL=STKL-1 327 . . .QUIT 328 . .QUIT 329 .QUIT 330 ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message 331 N A,B,C,STACK,STYP,SEG,AX 332 S D1=.99999,SGC=0 333 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 334 . ; Clear any control characters (cr/lf/ff) off 335 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 336 . ; 337 . D 338 . . I $D(BND1(D1)) D BOUNDARY(X) QUIT 339 . . ; 340 . . S DX=$O(BND1(D1)) 341 . . I DX="" D ERROR("ER15") Q 342 . . ; 343 . . ; Good situation, extract the parts for the section 344 . . S A=$G(BND1(DX)) 345 . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) 346 . .QUIT 347 . ; Enter once to set the SEP to capture the separator 348 . ; 349 . ; A new SEGMENT separator is set, process original 350 . I $D(BND1(X)) D QUIT 351 . . ; Save Current Values 352 . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) 353 . . ; Close this Segment and prepare to start a New Segment 354 . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) 355 . . ; Put the result in LST("SEG",SGC,"XML") 356 . . I $L(BF) D 357 . . . S ZN=1 358 . . . N I,T,TBF 359 . . . S TBF=BF 360 . . . F I=1:1:($L(TBF,"=")) D 361 . . . . S BF=$P(TBF,"=",I)_"=" 362 . . . . I "="'[BF D DECODER(.BF,.TYP) 363 . . . .QUIT 364 . . . S BF="" 365 . . .QUIT 366 . . S SGC=SGC+1,BCN=0 367 . . ; Incriment SGC to start a new Segment 368 . . S LST("SEG",SGC)=D1 369 . .QUIT 370 . ; 371 . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters 372 . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT 373 . ; 374 . ; Ending Condition, close out the Segment 375 . I $D(BNDRZ(X)) D QUIT 376 . . S $P(LST("SEG",SGC),"^",2)=D1-1 377 . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q 378 . .QUIT 379 . ; 380 . ; Accumulate the content lines of the message 381 . S BCN=BCN+$L(X) 382 . ; Split out the Content Info 383 . I X[CON D Q 384 . . S J=$P(X,CON,2) 385 . . S TYP="CONTENT" 386 . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) 387 . . D CONTENT(D1) 388 . .QUIT 389 . ; 390 . ; Everything else is Text, Check for CCR/CCD. 391 . N KK,UBF 392 . D 393 . . S UBF=$$UPPER(X) 394 . . I UBF["<CONTINUITYOFCARERECORD" S $P(LST("SEG",SGC),U,3)="CCR" Q 395 . . ; 396 . . I UBF["<CLINICALDOCUMENT" S $P(LST("SEG",SGC),U,3)="CCD" Q 397 . .QUIT 398 . ; Look for directives in the text before it gets published 399 . ; Look for "=3D" and replace it with a single "=". I can do more parsing 400 . ; but there may be situations where the line has been wrapped. 401 . D:X["=3D" 402 . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D" 403 . .QUIT 404 . S LST("SEG",SGC,TYP,D1)=X 405 .QUIT 406 QUIT 407 ; =================== 408 CONTENT(D1) ; Try pulling Content Statements 409 N J,UP,X 410 S X=$G(^XMB(3.9,D0,2,D1,0)) 411 S J=$P(X,CON,2) 412 S UP=$TR($$UPPER(X),"""") 413 S:$G(TYP)="" TYP="TXT" 414 D 415 . I UP["NAME=",($L(UP,".")>1) S TYP=$P(UP,".",2) Q 416 . I UP["XML" S TYP="XML" Q 417 . I UP["P7S" S TYP="P7S" Q 418 . I J[" boundary=" D BOUNDARY(J) 419 .QUIT 420 S LIS("CON",SGC,D1)=X 421 S LIS("CON",SGC,D1,"TYP")=TYP 422 ; If there is a follow-on, look for another line after this. 423 I $E($RE(X),1)=";" D CONTENT(D1+1) 424 QUIT 425 ; =================== 426 BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level 427 S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG 428 Q:SEP?2"-".ANP 429 ; 430 D ERROR("ER11") 431 Q:SEP'[" " 432 ; 433 D ERROR("ER12") 434 QUIT 435 ; =================== 436 ; Break down the Buffer Array so it can be saved. 437 ; BF is passed in. 438 ; TYP is the type of 439 DECODER(BF,TYP) ; 440 N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE 441 S:$G(TYP)="" TYP="XML" 442 S ZBF=BF 443 ; Full Buffer, BF, now check for Encryption and Unpack 444 F RCNT=1:1:$L(ZBF,"=") D 445 . N BF 446 . S BF=$P(ZBF,"=",RCNT) 447 . ; Unpacking the 64 bit encoding 448 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) 449 . D:$L(TBF) 450 . . N C,OK,OKCNT,KK,XBF,UBF 451 . . D 452 . . . S UBF=$$UPPER(TBF) 453 . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q 454 . . . ; 455 . . . I UBF["<CLINICALDOCUMENT XMLNS=" S $P(LST("SEG",SGC),U,3)="CCD" Q 456 . . .QUIT 457 . . ; Check for Bad Signature Decoding, after 100 bad characters 458 . . S OK=1,OKCNT=0 459 . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q 460 . . ; 461 . . D 462 . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q 463 . . . ; 464 . . . S BF=BF_"=" 465 . . . D NORMAL(.XBF,.TBF) 466 . . .QUIT 467 . . M LST("SEG",SGC,TYP,RCNT)=XBF 468 . .QUIT 469 .QUIT 470 QUIT 471 ; =================== 472 ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT 473 ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT 474 ; >D NORMAL^C0CMAIL(.OUT,BF) 475 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML 476 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME 477 ; 478 N ZN,OUTBF,XX,ZSEP 479 S INXML=$TR(INXML,$C(10,12,13)) 480 S ZN=1,ZSEP=">" 481 S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 482 F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" 483 . S XX=$P(INXML,"><",ZN) 484 . S:$E($RE(XX))=">" ZSEP="" 485 . Q:XX="" 486 . ; 487 . S XX="<"_XX_ZSEP 488 . D 489 . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q 490 . . ; 491 . . D ERROR("ER05") 492 . . F ZL=ZL+1:1 D Q:XX="" 493 . . . N XL 494 . . . S XL=$E(XX,1,4000) 495 . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters 496 . . . S OUTBF(ZL)=XL 497 . . .QUIT 498 . .QUIT 499 .QUIT 500 M OUTXML=OUTBF 501 QUIT 502 ; =================== 503 UPPER(X) ; Convert any lowercase letters to Uppercase letters 504 QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 505 ; =================== 506 ; EN is a counter that remains between error events 507 ERROR(ER) ; Error Handler 508 N TXXQ,XXXQ 509 S XXXQ="Unknown Error Encountered = "_ER 510 S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) 511 I TXXQ'="" D 512 . I TXXQ["_" X "S TXXQ="_TXXQ 513 . S XXXQ=TXXQ 514 .QUIT 515 S EN(ER)=$G(EN(ER))+1 516 S LST("ERR",ER,EN(ER))=XXXQ 517 QUIT 518 ; =================== 519 ER01 ;;Message Missing 520 ER02 ;;Message Text Missing 521 ER03 ;;Message Not Identifiable 522 ER04 ;;Segment is too large 523 ER05 ;;Mailbox Missing 524 ER06 ;;"User Missing = "_$G(DUZ) 525 ER07 ;;"Bad DUZ = "_DUZ 526 ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) 527 ER10 ;;"Bad Separator found = "_X 528 ER11 ;;"Non-Standard Separator Found:>"_$G(J) 529 ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) 530 ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X 531 ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv 532 ; End note if needed 533 QUIT 534 ; ===================
Note:
See TracChangeset
for help on using the changeset viewer.
