- XMS0BLOB ;(WASH ISC)/CAP-Send BLOBs (other body parts) ;04/18/2002 07:52
- ;;8.0;MailMan;;Jun 28, 2002
- ;
- ;This routine sends BLOBS (Basic Large Objects), also known in the
- ;messaging world as 'Other Body Parts' of messages.
- ;It can do this only with MailMan systems after (not including)
- ;version 7.0.
- ;
- ;A second portion of this code will be able to send to TCP/IP-SMTP
- ;systems that conform to MIME (MEE-MEE), an extension of RFC-822 that
- ;MailMan will conform to when dealing with MIME compatible structures.
- ;
- ;See XMR0BLOB for documentation on MPDUs (Message Protocol Data Units)
- ;exchanged between sender and receiver.
- ;
- ;Get data on BLOB from Imaging files
- S XMSBLOBX=0
- 0 S XMSBLOBX=$O(^XMB(3.9,XMZ,2005,XMSBLOBX)) G Q:XMSBLOBX="" S Y=$G(^(XMSBLOBX,0)) G 0:Y=""
- S X=+Y,ER=0,Y=$G(^MAG(2005,X,0)) G 0:Y=""
- S XMSBLOBT=Y,XMSBLOBT("#")=X,XMSBLOBT("NAME")=$P(Y,U),XMSBLOBT("FILE")=$P(Y,U,2),XMSBLOBT("DATE")=$P(Y,U,9)
- S Y(0)="" F %=3,4,5 S X=$P(Y,U,%) I X S Y(0)=$G(^MAG(2005.2,X,0)) Q:$L(Y(0))
- G 0:'$L(Y(0)) ;BLOB can not be sent -- no known disk reference
- S XMSBLOBT("DISK")=$P(Y(0),U,2),DIC=2005.02,DIC(0)="NZ"
- S X=$P(XMSBLOBT,U,6) D ^DIC G 0:Y<1 S XMSBLOBT("TYPE")=$P(Y,U,2)
- ;
- ;Send MPDU (Message Protocol Data Unit), Directory to send to returned
- ;
- S XMSG="MESS BLOB: "_XMSBLOBT("FILE")_"^"_XMSBLOBT("NAME")_"^"_XMSBLOBT("TYPE")_"^"_XMSBLOBT("DATE")
- 1 X XMSEN Q:ER X XMREC Q:ER I +XMRG'=250 G 0:$E(XMRG)=4 K ^XMB(3.9,XMZ,1,"AQUEUE",XMINST) N XMA0 S XMA0=XMCI_U_XMINST_U_XMZ D ERRR S XMINST=$P(XMA0,U,2),XMBLOBER=1,XMCI=$P(XMA0,U),XMZ=$P(XMA0,U,3) Q
- ;
- ;Determine IP address to send BLOB to / Use domain file data if it exists
- S %=$P(XMRG,U,2),X=$P($G(^DIC(4.2,XMINST,"IP")),U),%=$S($L(X):X,$L(%):%,1:"")
- I %="" S XMSG="MESS BLOB: < BLOB(s) not sent - No FTP channel defined !!! >" X XMSEN G ERR
- S XMSBLOBT("IP")=%
- ;
- ;FTP file to remote site
- ;
- K XMSFTP S XMSFTP(1)=$P($G(^XMB(1,1,"FTP-GET")),U),XMSFTP(2)=$P(XMRG,U,5),XMSFTP(2,"F")=XMSBLOBT("FILE"),XMSFTP(3)=XMSBLOBT("IP"),XMSFTP("IMAGE-PTR")=XMSBLOBT("#")
- F I=6,7,8 S XMSFTP(I)=$P(XMRG,U,I)
- I '$L($G(XMSFTP(6))) S %=$G(^DIC(4.2,XMINST,3)) I $L(%) S XMSFTP(7)=$P(%,";"),XMSFTP(7.1)=$P(%,";",2)
- D ^XMSFTP K XMSFTP
- G 0
- ;
- ;Record error, set error flag to RESET message transmission,
- ;remove message from queue, send message to sender.
- ERRR N ER,XMA0
- ERR ;
- N I,XMTEXT,XMSEN,XMREC,XMRECIP,XMSITE,XMSUBJ,XMIEN,XMTO,XMINSTR
- S XMINSTR("FROM")=.5
- S XMSUBJ="TRANSMISSION ERROR (Non-Textual Body-Part Message [BLOB])"
- S XMTEXT(1)="Error (sending your Multi-Body-Part Message):"
- S XMTEXT(2)=" "
- S XMTEXT(3)="Subject: "_$P(XMR,U)
- S XMTEXT(4)=" "
- S XMTEXT(5)=XMSG
- S XMTEXT(6)=" "
- S XMTEXT(7)="The message was not sent. It was removed from the transmission queue."
- S XMTEXT(8)="You should get this problem fixed and reforward this message"
- S XMSITE=$P(^DIC(4.2,XMINST,0),U)
- S XMTEXT(9)="to the recipients at "_XMSITE_":"
- S XMRECIP=":",I=9
- F S XMRECIP=$O(^XMB(3.9,XMZ,1,"C",XMRECIP)) Q:XMRECIP="" D
- . S XMIEN=""
- . F S XMIEN=$O(^XMB(3.9,XMZ,1,"C",XMRECIP,XMIEN)) Q:XMIEN="" D
- . . S XMREC=$G(^XMB(3.9,XMZ,1,XMIEN,0))
- . . Q:$P($P(XMREC,U,1),"@",2)'=XMSITE
- . . S I=I+1,XMTEXT(I)=$P(XMREC,U,1)
- . . S XMFWDBY=$P($G(^XMB(3.9,XMZ,1,XMIEN,"F")),U,2)
- . . S:XMFWDBY'="" XMTO(XMFWDBY)=""
- S:'$D(XMTO) XMTO($P(XMR,U,2))="" ; Sender of the message
- D SENDMSG^XMXSEND(.5,XMSUBJ,"XMTEXT",XMTO,.XMINSTR)
- Q
- ;Clean up and quit
- Q K XMSBLOBT,XMSBLOBX,DIC Q
- ;
- TEST S XMSEN="Q",XMREC="S XMRG=250",XMZ=18067
- G XMS0BLOB
- XMS0BLOB ;(WASH ISC)/CAP-Send BLOBs (other body parts) ;04/18/2002 07:52
- +1 ;;8.0;MailMan;;Jun 28, 2002
- +2 ;
- +3 ;This routine sends BLOBS (Basic Large Objects), also known in the
- +4 ;messaging world as 'Other Body Parts' of messages.
- +5 ;It can do this only with MailMan systems after (not including)
- +6 ;version 7.0.
- +7 ;
- +8 ;A second portion of this code will be able to send to TCP/IP-SMTP
- +9 ;systems that conform to MIME (MEE-MEE), an extension of RFC-822 that
- +10 ;MailMan will conform to when dealing with MIME compatible structures.
- +11 ;
- +12 ;See XMR0BLOB for documentation on MPDUs (Message Protocol Data Units)
- +13 ;exchanged between sender and receiver.
- +14 ;
- +15 ;Get data on BLOB from Imaging files
- +16 SET XMSBLOBX=0
- 0 SET XMSBLOBX=$ORDER(^XMB(3.9,XMZ,2005,XMSBLOBX))
- IF XMSBLOBX=""
- GOTO Q
- SET Y=$GET(^(XMSBLOBX,0))
- IF Y=""
- GOTO 0
- +1 SET X=+Y
- SET ER=0
- SET Y=$GET(^MAG(2005,X,0))
- IF Y=""
- GOTO 0
- +2 SET XMSBLOBT=Y
- SET XMSBLOBT("#")=X
- SET XMSBLOBT("NAME")=$PIECE(Y,U)
- SET XMSBLOBT("FILE")=$PIECE(Y,U,2)
- SET XMSBLOBT("DATE")=$PIECE(Y,U,9)
- +3 SET Y(0)=""
- FOR %=3,4,5
- SET X=$PIECE(Y,U,%)
- IF X
- SET Y(0)=$GET(^MAG(2005.2,X,0))
- IF $LENGTH(Y(0))
- QUIT
- +4 ;BLOB can not be sent -- no known disk reference
- IF '$LENGTH(Y(0))
- GOTO 0
- +5 SET XMSBLOBT("DISK")=$PIECE(Y(0),U,2)
- SET DIC=2005.02
- SET DIC(0)="NZ"
- +6 SET X=$PIECE(XMSBLOBT,U,6)
- DO ^DIC
- IF Y<1
- GOTO 0
- SET XMSBLOBT("TYPE")=$PIECE(Y,U,2)
- +7 ;
- +8 ;Send MPDU (Message Protocol Data Unit), Directory to send to returned
- +9 ;
- +10 SET XMSG="MESS BLOB: "_XMSBLOBT("FILE")_"^"_XMSBLOBT("NAME")_"^"_XMSBLOBT("TYPE")_"^"_XMSBLOBT("DATE")
- 1 XECUTE XMSEN
- IF ER
- QUIT
- XECUTE XMREC
- IF ER
- QUIT
- IF +XMRG'=250
- IF $EXTRACT(XMRG)=4
- GOTO 0
- KILL ^XMB(3.9,XMZ,1,"AQUEUE",XMINST)
- NEW XMA0
- SET XMA0=XMCI_U_XMINST_U_XMZ
- DO ERRR
- SET XMINST=$PIECE(XMA0,U,2)
- SET XMBLOBER=1
- SET XMCI=$PIECE(XMA0,U)
- SET XMZ=$PIECE(XMA0,U,3)
- QUIT
- +1 ;
- +2 ;Determine IP address to send BLOB to / Use domain file data if it exists
- +3 SET %=$PIECE(XMRG,U,2)
- SET X=$PIECE($GET(^DIC(4.2,XMINST,"IP")),U)
- SET %=$SELECT($LENGTH(X):X,$LENGTH(%):%,1:"")
- +4 IF %=""
- SET XMSG="MESS BLOB: < BLOB(s) not sent - No FTP channel defined !!! >"
- XECUTE XMSEN
- GOTO ERR
- +5 SET XMSBLOBT("IP")=%
- +6 ;
- +7 ;FTP file to remote site
- +8 ;
- +9 KILL XMSFTP
- SET XMSFTP(1)=$PIECE($GET(^XMB(1,1,"FTP-GET")),U)
- SET XMSFTP(2)=$PIECE(XMRG,U,5)
- SET XMSFTP(2,"F")=XMSBLOBT("FILE")
- SET XMSFTP(3)=XMSBLOBT("IP")
- SET XMSFTP("IMAGE-PTR")=XMSBLOBT("#")
- +10 FOR I=6,7,8
- SET XMSFTP(I)=$PIECE(XMRG,U,I)
- +11 IF '$LENGTH($GET(XMSFTP(6)))
- SET %=$GET(^DIC(4.2,XMINST,3))
- IF $LENGTH(%)
- SET XMSFTP(7)=$PIECE(%,";")
- SET XMSFTP(7.1)=$PIECE(%,";",2)
- +12 DO ^XMSFTP
- KILL XMSFTP
- +13 GOTO 0
- +14 ;
- +15 ;Record error, set error flag to RESET message transmission,
- +16 ;remove message from queue, send message to sender.
- ERRR NEW ER,XMA0
- ERR ;
- +1 NEW I,XMTEXT,XMSEN,XMREC,XMRECIP,XMSITE,XMSUBJ,XMIEN,XMTO,XMINSTR
- +2 SET XMINSTR("FROM")=.5
- +3 SET XMSUBJ="TRANSMISSION ERROR (Non-Textual Body-Part Message [BLOB])"
- +4 SET XMTEXT(1)="Error (sending your Multi-Body-Part Message):"
- +5 SET XMTEXT(2)=" "
- +6 SET XMTEXT(3)="Subject: "_$PIECE(XMR,U)
- +7 SET XMTEXT(4)=" "
- +8 SET XMTEXT(5)=XMSG
- +9 SET XMTEXT(6)=" "
- +10 SET XMTEXT(7)="The message was not sent. It was removed from the transmission queue."
- +11 SET XMTEXT(8)="You should get this problem fixed and reforward this message"
- +12 SET XMSITE=$PIECE(^DIC(4.2,XMINST,0),U)
- +13 SET XMTEXT(9)="to the recipients at "_XMSITE_":"
- +14 SET XMRECIP=":"
- SET I=9
- +15 FOR
- SET XMRECIP=$ORDER(^XMB(3.9,XMZ,1,"C",XMRECIP))
- IF XMRECIP=""
- QUIT
- Begin DoDot:1
- +16 SET XMIEN=""
- +17 FOR
- SET XMIEN=$ORDER(^XMB(3.9,XMZ,1,"C",XMRECIP,XMIEN))
- IF XMIEN=""
- QUIT
- Begin DoDot:2
- +18 SET XMREC=$GET(^XMB(3.9,XMZ,1,XMIEN,0))
- +19 IF $PIECE($PIECE(XMREC,U,1),"@",2)'=XMSITE
- QUIT
- +20 SET I=I+1
- SET XMTEXT(I)=$PIECE(XMREC,U,1)
- +21 SET XMFWDBY=$PIECE($GET(^XMB(3.9,XMZ,1,XMIEN,"F")),U,2)
- +22 IF XMFWDBY'=""
- SET XMTO(XMFWDBY)=""
- End DoDot:2
- End DoDot:1
- +23 ; Sender of the message
- IF '$DATA(XMTO)
- SET XMTO($PIECE(XMR,U,2))=""
- +24 DO SENDMSG^XMXSEND(.5,XMSUBJ,"XMTEXT",XMTO,.XMINSTR)
- +25 QUIT
- +26 ;Clean up and quit
- Q KILL XMSBLOBT,XMSBLOBX,DIC
- QUIT
- +1 ;
- TEST SET XMSEN="Q"
- SET XMREC="S XMRG=250"
- SET XMZ=18067
- +1 GOTO XMS0BLOB
