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

Last change on this file since 1186 was 1184, checked in by George Lilly, 14 years ago

VistACom changes
File size: 8.8 KB
Line 
1C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11
2 ;;1.0;C0C;;Mar 8, 2011;
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 ;S ZTO("glilly@glilly.net")=""
78 S ZTO("LILLY.GEORGE@mdc-crew.net")=""
79 ;S ZTO("martijn@djigzo.com")=""
80 ;S ZTO("profmish@gmail.com")=""
81 ;S ZTO("nanthracite@earthlink.net")=""
82 S ZFROM="ANTHRACITE.NANCY"
83 S ZATTACH=$NA(^GPL("CCR"))
84 I $G(@ZATTACH@(1))="" D ; NO CCR THERE
85 . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
86 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
87 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
88 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
89 ZWR GR
90 Q
91 ;
92MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FLAGS) ; MAIL SENDING INTERFACE
93 ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
94 ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
95 ; IF NULL, WILL SEND FROM THE CURRENT DUZ
96 ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
97 ; @TO@("addr1@domain1.net")
98 ; @CC@("addr2@domain2.com") both can be multiples
99 ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
100 ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
101 ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
102 ;
103 N GN
104 S GN=$NA(^TMP($J,"C0CMIME"))
105 K @GN
106 S GM(1)="MIME-Version: 1.0"
107 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
108 S GM(3)=" "
109 S GM(4)=" "
110 S GM(5)="--1234567"
111 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
112 S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
113 S GM(7)="Content-Transfer-Encoding: base64"
114 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
115 S GM(9)=" "
116 S GM(10)=" " ; FOR THE END
117 S GM(11)="--1234567--"
118 S GM(12)=" "
119 S GM(13)=" "
120 K GBLD
121 D QUEUE^C0CXPATH("GBLD","GM",5,9)
122 I $D(ATTACH)'="" D ; IF WE HAVE AN ATTACHMENT
123 . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
124 . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
125 D QUEUE^C0CXPATH("GBLD","GM",10,12)
126 D BUILD^C0CXPATH("GBLD",GN)
127 ;S GGG=$NA(^GPL("MIME2"))
128 K @GN@(0) ; KILL THE LINE COUNT
129 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
130 M LRTO=@TO
131 I $D(CC) M LRTO=@CC
132 S LRINSTR("ADDR FLAGS")="R"
133 S LRINSTR("FROM")=$G(FROM)
134 S LRMSUBJ=$G(SUBJECT)
135 S LRMSUBJ=$E(LRMSUBJ,1,65)
136 D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
137 I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q ;
138 S RTN(1)="OK"
139 Q
140 ;
141MAILSEND0(LRMSUBJ) ; Send extract back to requestor.
142 ;
143 ;D TEST
144 S GN=$NA(^TMP($J,"C0CMIME"))
145 K @GN
146 ;M @GN=G2
147 S GM(1)="MIME-Version: 1.0"
148 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
149 S GM(3)=" "
150 S GM(4)=" "
151 S GM(5)="--1234567"
152 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
153 S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
154 S GM(7)="Content-Transfer-Encoding: base64"
155 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
156 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
157 S GM(9)=" "
158 S GM(10)=" " ; FOR THE END
159 S GM(11)="--frontier--"
160 S GM(12)="."
161 S GM(13)=" "
162 K GBLD
163 ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
164 ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
165 ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
166 ;D BUILD^C0CXPATH("GBLD",GN)
167 S GGG=$NA(^GPL("MIME2"))
168 ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
169 D QUEUE^C0CXPATH("GBLD",GGG,21,159)
170 D BUILD^C0CXPATH("GBLD",GN)
171 K @GN@(0) ; KILL THE LINE COUNT
172 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
173 S XQSND="glilly@glilly.net"
174 ;S XQSND="nanthracite@earthlink.net"
175 ;S XQSND="dlefevre@orohosp.com"
176 ;S XQSND="gregwoodhouse@me.com"
177 ;S XQSND="rick.marshall@vistaexpertise.net"
178 S LRTO(XQSND)=""
179 S LRINSTR("ADDR FLAGS")="R"
180 S LRINSTR("FROM")="CCR_PACKAGE"
181 S LRMSUBJ="A SAMPLE CCR"
182 S LRMSUBJ=$E(LRMSUBJ,1,65)
183 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
184 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ;
185 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
186 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
187 Q
188 ;
189MAILSEND2(UDFN,ADDR) ; Send extract back to requestor.
190 ;
191 I +$G(UDFN)=0 S UDFN=2 ;
192 D TEST(UDFN)
193 S GN=$NA(^TMP($J,"C0CMIME"))
194 K @GN
195 ;M @GN=G2
196 S GM(1)="MIME-Version: 1.0"
197 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
198 S GM(3)=" "
199 S GM(4)=" "
200 S GM(5)="--1234567"
201 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
202 S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
203 S GM(7)="Content-Transfer-Encoding: base64"
204 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
205 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
206 S GM(9)=" "
207 S GM(10)=" " ; FOR THE END
208 S GM(11)="--1234567--"
209 S GM(12)=" "
210 S GM(13)=" "
211 K GBLD
212 D QUEUE^C0CXPATH("GBLD","GM",5,9)
213 D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
214 D QUEUE^C0CXPATH("GBLD","GM",10,12)
215 D BUILD^C0CXPATH("GBLD",GN)
216 S GGG=$NA(^GPL("MIME2"))
217 ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
218 ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
219 ;D BUILD^C0CXPATH("GBLD",GN)
220 K @GN@(0) ; KILL THE LINE COUNT
221 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
222 I $G(ADDR)'="" S XQSND=ADDR
223 E S XQSND="glilly@glilly.net"
224 ;S XQSND="nanthracite@earthlink.net"
225 ;S XQSND="dlefevre@orohosp.com"
226 ;S XQSND="gregwoodhouse@me.com"
227 ;S XQSND="rick.marshall@vistaexpertise.net"
228 S LRTO(XQSND)=""
229 ;S LRTO("glilly@glilly.net")=""
230 S LRINSTR("ADDR FLAGS")="R"
231 S LRINSTR("FROM")="ANTHRACITE.NANCY"
232 S LRMSUBJ="Sending a CCR with Mailman"
233 S LRMSUBJ=$E(LRMSUBJ,1,65)
234 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
235 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ;
236 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
237 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
238 Q
239 ;
240SIMPLE ;
241 S GN(1)="SIMPLE TEST MESSAGE"
242 K LRINSTR,LRTASK,LRTO,XMERR,XMZ
243 S XQSND="glilly@glilly.net"
244 S LRTO(XQSND)=""
245 S LRINSTR("ADDR FLAGS")="R"
246 S LRINSTR("FROM")="CCR_PACKAGE"
247 S LRMSUBJ="A SAMPLE CCR"
248 S LRMSUBJ=$E(LRMSUBJ,1,65)
249 D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
250 Q
251CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS
252 ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
253 ; OUTXML IS ALSO PASSED BY NAME
254 ; IF ZSIZE IS NOT PASSED, 1000 IS USED
255 I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
256 N ZB,ZI,ZJ,ZK,ZL,ZN
257 S ZB=ZSIZE-1
258 S ZN=1
259 S ZI=0 ; BEGINNING OF INDEX TO INXML
260 F S ZI=$O(@INXML@(ZI)) Q:+ZI=0 D ; FOR EACH STRING IN INXML
261 . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
262 . F ZJ=1:ZSIZE:ZL D ;
263 . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
264 . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
265 . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
266 Q
267 ;
268CLEAN(IARY) ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
269 ;
270 N ZI S ZI=0
271 F S ZI=$O(@IARY@(ZI)) Q:+ZI=0 D ;
272 . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
273 . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
274 Q
275 ;
Note: See TracBrowser for help on using the repository browser.