source: ccr/branches/ohum/p/C0CMAIL2.m@ 1487

Last change on this file since 1487 was 1433, checked in by Sam Habiel, 13 years ago

Update based on OHUM's latest routines
File size: 14.6 KB
RevLine 
[1428]1C0CMAIL2 ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr ; 5/10/12 2:50pm
[1433]2 ;;1.2;C0C;;May 11, 2012;Build 47
[1428]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 ;
57GETMSG(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 ; ===================
115GATHER(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 ;
150GETTYP(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 ; ===================
206NAME(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 ; ===================
226TIME(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 ;
244DETAIL(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
260GETTYP2(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.
371DECODER ;
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)
406NORMAL(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 ; ===================
434UPPER(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
438ERROR(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 ; ===================
450ER01 ;;Message Missing
451ER02 ;;Message Text Missing
452ER03 ;;Message Not Identifiable
453ER04 ;;Segment is too large
454ER05 ;;Mailbox Missing
455ER06 ;;"User Missing = "_$G(DUZ)
456ER07 ;;"Bad DUZ = "_DUZ
457ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
458ER10 ;;"Bad Separator found = "_X
459ER11 ;;"Non-Standard Separator Found:>"_$G(J)
460ER12 ;;"Spaces are not allowed in Separators:>"_$G(J)
461 ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv
462 ; End note if needed
463 QUIT
464 ; ===================
Note: See TracBrowser for help on using the repository browser.