Changeset 1428 for ccr/branches/ohum/p/C0CMIME.m
- Timestamp:
- May 11, 2012, 6:06:25 PM (13 years ago)
- File:
-
- 1 edited
-
ccr/branches/ohum/p/C0CMIME.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CMIME.m
r1342 r1428 1 C0CMIME 2 ;;1.0;C0C;;Mar 8, 2011;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 TEST(ZDFN) 23 24 25 26 27 28 29 30 31 32 33 ENCODE(ZRTN,ZARY) 34 35 36 37 38 39 40 41 42 43 44 45 46 47 ENCODEOLD(IARY,LRNODE,LRSTR) 48 49 50 51 52 53 54 55 56 57 58 TESTMAIL 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 TESTMAIL2 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 LINE(C0CFILE,C0CTO) 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) 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 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 MAILSEND0(LRMSUBJ) 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 MAILSEND2(UDFN,ADDR) 254 255 256 257 258 259 260 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 SIMPLE 305 306 307 308 309 310 311 312 313 314 315 CHUNK(OUTXML,INXML,ZSIZE) 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 CLEAN(IARY) 333 334 335 336 337 338 339 1 C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; 22 TEST(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 33 ENCODE(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 47 ENCODEOLD(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 ; 58 TESTMAIL ; 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 ; 75 TESTMAIL2 ; 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 ; 104 LINE(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 ; 125 MAILSEND(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 ; 205 MAILSEND0(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 ; 253 MAILSEND2(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 ; 304 SIMPLE ; 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 315 CHUNK(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 ; 332 CLEAN(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 TracChangeset
for help on using the changeset viewer.
