XMRFTPUX ;(WASH ISC)/THM/CAP-SMTP Receiver (RFC 821) ;04/17/2002 11:20
;;8.0;MailMan;;Jun 28, 2002
;Modified for TCP/IP under INET_SERVERS of Wollongong
;Send out FTP jobs that are due
FTP N %,DA,DIK,XMA0,XMC0,XMSFTP,Y,Z,XMCOM S XMA0=$H*86400+$P($H,",",2)
F1 S Z=0,Z=$O(^XMBX(4.2995,Z)) G FQ:+Z'=Z I '$D(^(Z,0)) G QQ^XMRTCP
S Y=^XMBX(4.2995,Z,0),XMSFTP=$P(Y,U,4),XMRTCPY="MM-FTP-"_$P(Y,U),XMCOM=$P(Y,U)
I XMCOM'?1"XM".E D RUNQ G QQ^XMRTCP
F2 F S %=$S($G(XMC0):XMC0,1:$$CK^XMRTCP(1)) G F3:%
;Copy file to export directory
F3 S XMC0=% I XMSFTP S %=$$FCHK(Z,XMA0,XMSFTP) G F1:%
S XMRTCP("NAME")=XMRTCPY D REN
G RUN
FQ I $G(XMC0) L -^XMBX("TCPCHAN-COUNT",XMC0)
Q
;Submit FTP process
RUN I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP=""
S X="RUNQ^XMRFTP",@^%ZOSF("TRAP")
S %=$ZC(%SPAWN,"@"_XMCOM),%=$ZC(%SPAWN,"DELETE "_XMCOM_".*")
RUNQ ;Remove from 4.2995
I $D(Z) N DIK,DA S DIK="^XMBX(4.2995,",DA=Z K XMRTCPY D ^DIK Q
Q
REN I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP=""
S X="DUPNAME^XMRTCP",@^%ZOSF("TRAP")
I ^%ZOSF("OS")["VAX" S X=$ZC(%SETPRN,$E(XMRTCP("NAME"),1,13))
D START^XMRTCPGO
Q
FCHK(Z,Y,F) ;Is file in export directory ?
Q 0 ;****************
N %,%0,%1,%2,I,X,XMIO
S XMIO=$I,%=^XMBX(4.2995,Z,0),%0=$P(%,U,5),%2=$P(%,U,4)
I '%0 S $P(^XMBX(4.2995,Z,0),U,5)=Y,%=$$EXPORT^MAGAPI("MAIL",F,"WAIT") Q %
S %=$P(^MAG(2005,%2,0),U,2)
CONT S %0="XMS"_$E(Z,$L(Z)-4,$L(Z))_".LIS"
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP=""
S X="FPQ^XMRFTP",@^%ZOSF("TRAP"),X=$ZC(%SPAWN,"PURGE "_%0)
FPQ I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP=""
S X="Q0^XMRFTP",@^%ZOSF("TRAP"),X=$ZC(%SPAWN,"DIR/OUTPUT="_%0_" NFA0:[EXPORT.MAIL]"_%)
O %0 U %0
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP=""
S X="FCHKQ^XMRFTP",@^%ZOSF("TRAP")
F R X:9 Q:X[%
FCHKQ C %0 U XMIO
I X'[% Q 1
Q 0
Q0 Q 1
FER N X S X=$P($G(^XMBX(4.2995,Z,0)),U,2)
I 'X S X=$H*86400+$P($H,",",2),$P(^(0),U,2)=X
Q:$H*86400+$P($H,",",2)-%>99
N Z S XMDUZ=.5,XMSUB="ERROR moving File from Image Server"
S XMTEXT="A(",A(1)="The error was: "_%_"."
S A(2)="The COM file being processed was: "_Y,XMY(.5)=""
D ^XMD Q
IMAGENT(Y,F) ;
N %,%0,XMIO,X
I ^%ZOSF("OS")["MSM" S X=$ZOS(12,NEWPATH,"") I $P(X,U)=F QUIT "5 -IMAGE ALREADY THERE"
S Z=$P($H,",",2)#1000,XMIO=$I,%=F
G CONT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMRFTPUX 2303 printed Dec 13, 2024@02:12:59 Page 2
XMRFTPUX ;(WASH ISC)/THM/CAP-SMTP Receiver (RFC 821) ;04/17/2002 11:20
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ;Modified for TCP/IP under INET_SERVERS of Wollongong
+3 ;Send out FTP jobs that are due
FTP NEW %,DA,DIK,XMA0,XMC0,XMSFTP,Y,Z,XMCOM
SET XMA0=$HOROLOG*86400+$PIECE($HOROLOG,",",2)
F1 SET Z=0
SET Z=$ORDER(^XMBX(4.2995,Z))
if +Z'=Z
GOTO FQ
IF '$DATA(^(Z,0))
GOTO QQ^XMRTCP
+1 SET Y=^XMBX(4.2995,Z,0)
SET XMSFTP=$PIECE(Y,U,4)
SET XMRTCPY="MM-FTP-"_$PIECE(Y,U)
SET XMCOM=$PIECE(Y,U)
+2 IF XMCOM'?1"XM".E
DO RUNQ
GOTO QQ^XMRTCP
F2 FOR
SET %=$SELECT($GET(XMC0):XMC0,1:$$CK^XMRTCP(1))
if %
GOTO F3
+1 ;Copy file to export directory
F3 SET XMC0=%
IF XMSFTP
SET %=$$FCHK(Z,XMA0,XMSFTP)
if %
GOTO F1
+1 SET XMRTCP("NAME")=XMRTCPY
DO REN
+2 GOTO RUN
FQ IF $GET(XMC0)
LOCK -^XMBX("TCPCHAN-COUNT",XMC0)
+1 QUIT
+2 ;Submit FTP process
RUN IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP=""
+1 SET X="RUNQ^XMRFTP"
SET @^%ZOSF("TRAP")
+2 SET %=$ZC(%SPAWN,"@"_XMCOM)
SET %=$ZC(%SPAWN,"DELETE "_XMCOM_".*")
RUNQ ;Remove from 4.2995
+1 IF $DATA(Z)
NEW DIK,DA
SET DIK="^XMBX(4.2995,"
SET DA=Z
KILL XMRTCPY
DO ^DIK
QUIT
+2 QUIT
REN IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP=""
+1 SET X="DUPNAME^XMRTCP"
SET @^%ZOSF("TRAP")
+2 IF ^%ZOSF("OS")["VAX"
SET X=$ZC(%SETPRN,$EXTRACT(XMRTCP("NAME"),1,13))
+3 DO START^XMRTCPGO
+4 QUIT
FCHK(Z,Y,F) ;Is file in export directory ?
+1 ;****************
QUIT 0
+2 NEW %,%0,%1,%2,I,X,XMIO
+3 SET XMIO=$IO
SET %=^XMBX(4.2995,Z,0)
SET %0=$PIECE(%,U,5)
SET %2=$PIECE(%,U,4)
+4 IF '%0
SET $PIECE(^XMBX(4.2995,Z,0),U,5)=Y
SET %=$$EXPORT^MAGAPI("MAIL",F,"WAIT")
QUIT %
+5 SET %=$PIECE(^MAG(2005,%2,0),U,2)
CONT SET %0="XMS"_$EXTRACT(Z,$LENGTH(Z)-4,$LENGTH(Z))_".LIS"
+1 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP=""
+2 SET X="FPQ^XMRFTP"
SET @^%ZOSF("TRAP")
SET X=$ZC(%SPAWN,"PURGE "_%0)
FPQ IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP=""
+1 SET X="Q0^XMRFTP"
SET @^%ZOSF("TRAP")
SET X=$ZC(%SPAWN,"DIR/OUTPUT="_%0_" NFA0:[EXPORT.MAIL]"_%)
+2 OPEN %0
USE %0
+3 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP=""
+4 SET X="FCHKQ^XMRFTP"
SET @^%ZOSF("TRAP")
+5 FOR
READ X:9
if X[%
QUIT
FCHKQ CLOSE %0
USE XMIO
+1 IF X'[%
QUIT 1
+2 QUIT 0
Q0 QUIT 1
FER NEW X
SET X=$PIECE($GET(^XMBX(4.2995,Z,0)),U,2)
+1 IF 'X
SET X=$HOROLOG*86400+$PIECE($HOROLOG,",",2)
SET $PIECE(^(0),U,2)=X
+2 if $HOROLOG*86400+$PIECE($HOROLOG,",",2)-%>99
QUIT
+3 NEW Z
SET XMDUZ=.5
SET XMSUB="ERROR moving File from Image Server"
+4 SET XMTEXT="A("
SET A(1)="The error was: "_%_"."
+5 SET A(2)="The COM file being processed was: "_Y
SET XMY(.5)=""
+6 DO ^XMD
QUIT
IMAGENT(Y,F) ;
+1 NEW %,%0,XMIO,X
+2 IF ^%ZOSF("OS")["MSM"
SET X=$ZOS(12,NEWPATH,"")
IF $PIECE(X,U)=F
QUIT "5 -IMAGE ALREADY THERE"
+3 SET Z=$PIECE($HOROLOG,",",2)#1000
SET XMIO=$IO
SET %=F
+4 GOTO CONT
