source: ccr/trunk/p/C0CMIME.m@ 1800

Last change on this file since 1800 was 1586, checked in by Sam Habiel, 12 years ago

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