source: ccr/branches/ohum/p/C0CMIME.m@ 1499

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

Update based on OHUM's latest routines
File size: 11.4 KB
Line 
1C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
2 ;;1.2;C0C;;May 11, 2012;Build 47
3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU
4 ;General Public License See attached copy of the License.
5 ;
6 ;This program is free software; you can redistribute it and/or modify
7 ;it under the terms of the GNU General Public License as published by
8 ;the Free Software Foundation; either version 2 of the License, or
9 ;(at your option) any later version.
10 ;
11 ;This program is distributed in the hope that it will be useful,
12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;GNU General Public License for more details.
15 ;
16 ;You should have received a copy of the GNU General Public License along
17 ;with this program; if not, write to the Free Software Foundation, Inc.,
18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19 ;
20 Q
21 ;
22TEST(ZDFN) ;
23 D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH
24 ;M ZCOPY=ZCCR
25 S ZCOPY(1)=""
26 N ZI S ZI=0
27 F S ZI=$O(ZCCR(ZI)) Q:ZI="" D ; FOR EACH LINE
28 . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI)
29 ;D ENCODE("ZCOPY",1,ZCOPY(1))
30 S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
31 D CHUNK("G2","G",45)
32 Q
33ENCODE(ZRTN,ZARY) ;
34 ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING
35 ; ZARY IS PASSED BY NAME
36 ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN
37 ;
38 S ZCOPY(1)=""
39 N ZI S ZI=0
40 F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE
41 . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI)
42 N G
43 S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
44 D CHUNK(ZRTN,"G",45)
45 Q
46 ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN
47ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line
48 ; Call with LRSTR by reference, Remainder returned in LRSTR
49 ; IARY IS PASSED BY NAME
50 S LRQUIT=0,LRLEN=$L(LRSTR)
51 F D Q:LRQUIT
52 . I $L(LRSTR)<45 S LRQUIT=1 Q
53 . S LRX=$E(LRSTR,1,45)
54 . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX)
55 . S LRSTR=$E(LRSTR,46,LRLEN)
56 Q
57 ;
58TESTMAIL ;
59 ; TEST OF MAILSEND
60 ;S ZTO("glilly@glilly.net")=""
61 S ZTO("mish@nhin.openforum.opensourcevista.net")=""
62 ;S ZTO("martijn@djigzo.com")=""
63 ;S ZTO("profmish@gmail.com")=""
64 ;S ZTO("nanthracite@earthlink.net")=""
65 S ZFROM="ANTHRACITE.NANCY"
66 S ZATTACH=$NA(^GPL("CCR"))
67 I $G(@ZATTACH@(1))="" D ; NO CCR THERE
68 . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
69 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
70 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
71 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
72 ZWR GR
73 Q
74 ;
75TESTMAIL2 ;
76 ; TEST OF MAILSEND TO gpl.mdc-crew.net
77 N C0CGM
78 S C0CGM(1)="This is a test message."
79 S C0CGM(2)="A Continuity of Care record is attached"
80 S C0CGM(3)="It contains no Protected Health Information (PHI)"
81 S C0CGM(4)="It is purely test data used for software development"
82 S C0CGM(5)="It does not represent information about any person living or dead"
83 ;S ZTO("glilly@glilly.net")=""
84 ;S ZTO("george.lilly@pobox.com")=""
85 ;S ZTO("george@nhin.openforum.opensourcevista.net")=""
86 ;S ZTO("mish@nhin.openforum.opensourcevista.net")=""
87 S ZTO("brooks.richard@securemail.opensourcevista.net")=""
88 ;S ZTO("LILLY.GEORGE@mdc-crew.net")=""
89 ;S ZTO("ncoal@live.com")=""
90 ;S ZTO("martijn@djigzo.com")=""
91 ;S ZTO("profmish@gmail.com")=""
92 ;S ZTO("nanthracite@earthlink.net")=""
93 S ZTO("gpl.doctortest@gmail.com")=""
94 S ZFROM="LILLY.GEORGE"
95 S ZATTACH=$NA(^GPL("CCR"))
96 I $G(@ZATTACH@(1))="" D ; NO CCR THERE
97 . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
98 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
99 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
100 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
101 ZWR GR
102 Q
103 ;
104LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to
105 ; the email address in C0CTO
106 ; the directory and the "from" are all hard coded
107 ;
108 N ZZFROM S ZZFROM="LILLY.GEORGE"
109 N GN S GN=$NA(^TMP("C0CMIME2",$J))
110 N GN1 S GN1=$NA(@GN@(1))
111 K @GN
112 I '$D(C0CFILE) Q ; NO FILENAME PASSED
113 I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net"
114 S ZZTO(C0CTO)=""
115 N ZMESS S ZMESS(1)="file transmission from wvehr3-09"
116 N GD S GD="/home/wvehr3-09/EHR/" ; directory
117 I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q D ;
118 . W !,"error reading file",C0CFILE
119 D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE)
120 K @GN ; CLEAN UP
121 ;ZWR ZRTN
122 W !,$G(ZRTN(1))
123 Q
124 ;
125MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE
126 ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
127 ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
128 ; IF NULL, WILL SEND FROM THE CURRENT DUZ
129 ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
130 ; @TO@("addr1@domain1.net")
131 ; @CC@("addr2@domain2.com") both can be multiples
132 ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
133 ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
134 ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
135 ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml
136 ;
137 I '$D(FNAME) S FNAME="ccr.xml" ; default filename
138 N GN
139 S GN=$NA(^TMP($J,"C0CMIME"))
140 K @GN
141 S GM(1)="MIME-Version: 1.0"
142 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
143 S GM(3)=""
144 S GM(4)=""
145 ;S GM(5)="--123456788888"
146 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
147 S GM(5)="--123456899999"
148 S GM(6)="Content-Type: text/xml; name="_FNAME
149 S GM(7)="Content-Transfer-Encoding: base64"
150 S GM(8)="Content-Disposition: attachment; filename="_FNAME
151 S GM(9)=""
152 S GM(10)="" ; FOR THE END
153 ;S GM(11)="--123456788888--"
154 S GM(11)="--123456899999--"
155 S GM(12)=""
156 S GM(13)=""
157 S GG(1)="--123456899999"
158 S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed"
159 S GG(3)="Content-Transfer-Encoding: 7bit"
160 S GG(4)=""
161 S GG(5)="This is a test message."
162 S GG(6)="A Continuity of Care record is attached"
163 S GG(7)="It contains no Protected Health Information (PHI)"
164 S GG(8)="It is purely test data used for software development"
165 S GG(9)="It does not represent information about any person living or dead"
166 S GG(10)=""
167 S GG(11)="--123456899999--"
168 ;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
169 S GG(12)=""
170 ;S GG(13)="This is a test message."
171 S GG(14)="A Continuity of Care record is attached"
172 S GG(15)="It contains no Protected Health Information (PHI)"
173 S GG(16)="It is purely test data used for software development"
174 S GG(17)="It does not represent information about any person living or dead"
175 S GG(18)=""
176 S GG(19)="--123456899999"
177 S GG(20)="--987654321--"
178 K GBLD
179 ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE
180 ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE
181 I $D(MESSAGE)'="" D ; THERE IS A MESSAGE
182 . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY
183 . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE
184 . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE
185 D QUEUE^C0CXPATH("GBLD","GM",5,9)
186 I $D(ATTACH)'="" D ; IF WE HAVE AN ATTACHMENT
187 . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
188 . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
189 D QUEUE^C0CXPATH("GBLD","GM",11,12)
190 D BUILD^C0CXPATH("GBLD",GN)
191 ;S GGG=$NA(^GPL("MIME2"))
192 K @GN@(0) ; KILL THE LINE COUNT
193 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
194 M LRTO=@TO
195 I $D(CC) M LRTO=@CC
196 S LRINSTR("ADDR FLAGS")="R"
197 S LRINSTR("FROM")=$G(FROM)
198 S LRMSUBJ=$G(SUBJECT)
199 S LRMSUBJ=$E(LRMSUBJ,1,65)
200 D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
201 I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q ;
202 S RTN(1)="OK"
203 Q
204 ;
205MAILSEND0(LRMSUBJ) ; Send extract back to requestor.
206 ;
207 ;D TEST
208 S GN=$NA(^TMP($J,"C0CMIME"))
209 K @GN
210 ;M @GN=G2
211 S GM(1)="MIME-Version: 1.0"
212 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
213 S GM(3)=""
214 S GM(4)=""
215 S GM(5)="--1234567"
216 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
217 S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
218 S GM(7)="Content-Transfer-Encoding: base64"
219 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
220 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
221 S GM(9)=""
222 S GM(10)="" ; FOR THE END
223 S GM(11)="--frontier--"
224 S GM(12)="."
225 S GM(13)=""
226 K GBLD
227 ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
228 ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
229 ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
230 ;D BUILD^C0CXPATH("GBLD",GN)
231 S GGG=$NA(^GPL("MIME2"))
232 ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
233 D QUEUE^C0CXPATH("GBLD",GGG,21,159)
234 D BUILD^C0CXPATH("GBLD",GN)
235 K @GN@(0) ; KILL THE LINE COUNT
236 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
237 S XQSND="glilly@glilly.net"
238 ;S XQSND="nanthracite@earthlink.net"
239 ;S XQSND="dlefevre@orohosp.com"
240 ;S XQSND="gregwoodhouse@me.com"
241 ;S XQSND="rick.marshall@vistaexpertise.net"
242 S LRTO(XQSND)=""
243 S LRINSTR("ADDR FLAGS")="R"
244 S LRINSTR("FROM")="CCR_PACKAGE"
245 S LRMSUBJ="A SAMPLE CCR"
246 S LRMSUBJ=$E(LRMSUBJ,1,65)
247 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
248 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ;
249 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
250 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
251 Q
252 ;
253MAILSEND2(UDFN,ADDR) ; Send extract back to requestor.
254 ;
255 I +$G(UDFN)=0 S UDFN=2 ;
256 D TEST(UDFN)
257 S GN=$NA(^TMP($J,"C0CMIME"))
258 K @GN
259 ;M @GN=G2
260 S GM(1)="MIME-Version: 1.0"
261 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
262 S GM(3)=""
263 S GM(4)=""
264 S GM(5)="--1234567"
265 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
266 S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
267 S GM(7)="Content-Transfer-Encoding: base64"
268 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
269 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
270 S GM(9)=""
271 S GM(10)="" ; FOR THE END
272 S GM(11)="--1234567--"
273 S GM(12)=""
274 S GM(13)=""
275 K GBLD
276 D QUEUE^C0CXPATH("GBLD","GM",5,9)
277 D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
278 D QUEUE^C0CXPATH("GBLD","GM",10,12)
279 D BUILD^C0CXPATH("GBLD",GN)
280 S GGG=$NA(^GPL("MIME2"))
281 ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
282 ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
283 ;D BUILD^C0CXPATH("GBLD",GN)
284 K @GN@(0) ; KILL THE LINE COUNT
285 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
286 I $G(ADDR)'="" S XQSND=ADDR
287 E S XQSND="glilly@glilly.net"
288 ;S XQSND="nanthracite@earthlink.net"
289 ;S XQSND="dlefevre@orohosp.com"
290 ;S XQSND="gregwoodhouse@me.com"
291 ;S XQSND="rick.marshall@vistaexpertise.net"
292 S LRTO(XQSND)=""
293 ;S LRTO("glilly@glilly.net")=""
294 S LRINSTR("ADDR FLAGS")="R"
295 S LRINSTR("FROM")="ANTHRACITE.NANCY"
296 S LRMSUBJ="Sending a CCR with Mailman"
297 S LRMSUBJ=$E(LRMSUBJ,1,65)
298 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
299 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ;
300 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
301 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
302 Q
303 ;
304SIMPLE ;
305 S GN(1)="SIMPLE TEST MESSAGE"
306 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
307 S XQSND="glilly@glilly.net"
308 S LRTO(XQSND)=""
309 S LRINSTR("ADDR FLAGS")="R"
310 S LRINSTR("FROM")="CCR_PACKAGE"
311 S LRMSUBJ="A SAMPLE CCR"
312 S LRMSUBJ=$E(LRMSUBJ,1,65)
313 D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
314 Q
315CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS
316 ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
317 ; OUTXML IS ALSO PASSED BY NAME
318 ; IF ZSIZE IS NOT PASSED, 1000 IS USED
319 I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
320 N ZB,ZI,ZJ,ZK,ZL,ZN
321 S ZB=ZSIZE-1
322 S ZN=1
323 S ZI=0 ; BEGINNING OF INDEX TO INXML
324 F S ZI=$O(@INXML@(ZI)) Q:+ZI=0 D ; FOR EACH STRING IN INXML
325 . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
326 . F ZJ=1:ZSIZE:ZL D ;
327 . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
328 . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
329 . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
330 Q
331 ;
332CLEAN(IARY) ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
333 ;
334 N ZI S ZI=0
335 F S ZI=$O(@IARY@(ZI)) Q:+ZI=0 D ;
336 . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
337 . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
338 Q
339 ;
Note: See TracBrowser for help on using the repository browser.