XMRTCP ;(WASH ISC)/THM/CAP-SMTP Receiver ;10/09/2002 14:23
;;8.0;MailMan;**7**;Jun 28, 2002
;Modified for TCP/IP under INET_SERVERS of Wollongong
;
POLL ;Poll all domains with flags set
;Fake TaskMan Env.
S U="^",X="ERR^XMRTCP",@^%ZOSF("TRAP"),XMDUZ=.5
K XM S IOP="NULL",%IS=0 D ^%ZIS I '$D(IOT) S IOT=""
HANG S IO(0)=IO,ZTQUEUED=$S($D(ZTQUEUED):ZTQUEUED,1:1),ZTSK=$S($D(ZTSK):ZTSK,1:"N/A"),XM="",XMLTCPT=""
I $G(^TMP("XMRTCP",0)) S XMLTCPT=^(0) K ^(0)
L Q:$P(^XMB(1,1,0),U,18)=1
;
;Any queues flagged (x-ref is set by TCP/IP POLL FLAG in domain file)
S XMLTCPT=$O(^DIC(4.2,"ATCP",1,XMLTCPT)) G QQ:XMLTCPT=""
S XMINST=XMLTCPT
;
RQ ;Transmit messages / execute TURN command
;Are there messages to send ?
I '$O(^XMB(3.7,.5,2,XMINST+1000,1,0)) G L
;Job out, if all slots full wait and try again.
S %=$$CK(1) I '% S XMLTCPT=$O(^DIC(4.2,"ATCP",1,XMLTCPT),-1) H 60 G L
D SETUP L +^XMBX("TCPCHAN",XMINST):3 E L -^XMBX("TCPCHAN-COUNT",%) G L
;
S XMRTCP("CNT")=%
;
;Change name (prevent dupe error), then JOB myself
Q:$E($G(XMRTCP("NAME")),1,6)="MM-FTP"
S XMRTCP("NAME")="MM-TCP-"_XMINST D REN^XMRFTP
S X=^%ZOSF("ERRTN"),@^%ZOSF("TRAP")
;
;Deliver messages
;
;INIT
S XMSITE=$P(^DIC(4.2,XMINST,0),"^")
D XMTCHECK^XMKPR(XMINST,.XMB)
S XMOKTYPE("TCPCHAN")="" ;Find and use TCP/IP channel script
D SCRIPT^XMKPR1(XMINST,XMSITE,.XMB,.XMOKTYPE) Q:'XMB("SCR IEN")
; Check that last try is at least 1 minute ago.
; If we've completed a cycle of scripts, wait until 1 hour has passed
; before we start the next cycle.
I XMB("TRIES"),$$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60<1 G HALT
E I XMB("ITERATIONS"),XMB("SCR IEN")=XMB("FIRST SCRIPT"),$$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60\60<1 G HALT
S ZTIO=$P(XMB("SCRIPT"),U,5)
D XMTAUDT^XMTDR(XMINST,.XMB)
D ENT^XMC1
H 30
D KILL
G HALT
;
;Pause between POLLINGS
QQ D KILL S X=$H*86400+$P($H,",",2) G:$O(^XMBX(4.2995,0)) FTP^XMRFTP
S X=22-($H*86400+$P($H,",",2)-X) I X>0 H X
G POLL
;
;Entry on dupe name
DUPNAME S X="ERR^XMRTCP",@^%ZOSF("TRAP") H 15 G L
;
;Clean up before next transmission
KILL D KL1^XMC K DIC,XMB,XMDT,ZTPAR
L Q
;
SETUP ;Set up environment
N IO S IO="",IO(0)="" D DT^DICRW
Q
ERR D @^%ZOSF("ERRTN") H 60
I '$F(":MM-TCP:MM-FTP:",":"_$E($G(XMRTCP("NAME")),1,6)_":") D KILL G POLL
HALT ;
;I ^%ZOSF("OS")["VAX" U IO:DISCONNECT
;G ^XUSCLEAN ; Writes to IO.
G H2^XUSCLEAN ; Supposedly doesn't write to IO.
;
;Entry for Inet_servers interface RECEIVER
;SMTP service request invokes MailMan
;
SOC25 S (XMRPORT,IO,IO(0))=%,X=$E(%_"-INETMM",1,15) D SETENV^%ZOSV
D DT^DICRW,DUZ^XUP(.5)
S X="ERR^ZU",@^%ZOSF("TRAP"),ER=0
O IO:(SHARE,MAILBOX) U IO
S XMCHAN="TCP/IP-MAILMAN",XMNO220=""
D ENT^XMR
G HALT
;
;Check if slot on TCP/IP to use
CK(X) S I=$P(^XMB(1,1,0),"^",17)
F %=1:1 L +^XMBX("TCPCHAN-COUNT",%):1 Q:$T Q:%=I
Q $S($T:%,1:0)
JOB ;
H 90 ;wait for RVG mounts
S $P(^XMB(1,1,0),"^",18)="" ;Clear the TCP/IP poller run flag
START G START^XMRTCPGO
ERRSCRPT ;TRAP transmission errors
S ER=1
I ^%ZOSF("OS")["VAX DSM" S $ECODE=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMRTCP 3156 printed Dec 13, 2024@02:13:07 Page 2
XMRTCP ;(WASH ISC)/THM/CAP-SMTP Receiver ;10/09/2002 14:23
+1 ;;8.0;MailMan;**7**;Jun 28, 2002
+2 ;Modified for TCP/IP under INET_SERVERS of Wollongong
+3 ;
POLL ;Poll all domains with flags set
+1 ;Fake TaskMan Env.
+2 SET U="^"
SET X="ERR^XMRTCP"
SET @^%ZOSF("TRAP")
SET XMDUZ=.5
+3 KILL XM
SET IOP="NULL"
SET %IS=0
DO ^%ZIS
IF '$DATA(IOT)
SET IOT=""
HANG SET IO(0)=IO
SET ZTQUEUED=$SELECT($DATA(ZTQUEUED):ZTQUEUED,1:1)
SET ZTSK=$SELECT($DATA(ZTSK):ZTSK,1:"N/A")
SET XM=""
SET XMLTCPT=""
+1 IF $GET(^TMP("XMRTCP",0))
SET XMLTCPT=^(0)
KILL ^(0)
L if $PIECE(^XMB(1,1,0),U,18)=1
QUIT
+1 ;
+2 ;Any queues flagged (x-ref is set by TCP/IP POLL FLAG in domain file)
+3 SET XMLTCPT=$ORDER(^DIC(4.2,"ATCP",1,XMLTCPT))
if XMLTCPT=""
GOTO QQ
+4 SET XMINST=XMLTCPT
+5 ;
RQ ;Transmit messages / execute TURN command
+1 ;Are there messages to send ?
+2 IF '$ORDER(^XMB(3.7,.5,2,XMINST+1000,1,0))
GOTO L
+3 ;Job out, if all slots full wait and try again.
+4 SET %=$$CK(1)
IF '%
SET XMLTCPT=$ORDER(^DIC(4.2,"ATCP",1,XMLTCPT),-1)
HANG 60
GOTO L
+5 DO SETUP
LOCK +^XMBX("TCPCHAN",XMINST):3
IF '$TEST
LOCK -^XMBX("TCPCHAN-COUNT",%)
GOTO L
+6 ;
+7 SET XMRTCP("CNT")=%
+8 ;
+9 ;Change name (prevent dupe error), then JOB myself
+10 if $EXTRACT($GET(XMRTCP("NAME")),1,6)="MM-FTP"
QUIT
+11 SET XMRTCP("NAME")="MM-TCP-"_XMINST
DO REN^XMRFTP
+12 SET X=^%ZOSF("ERRTN")
SET @^%ZOSF("TRAP")
+13 ;
+14 ;Deliver messages
+15 ;
+16 ;INIT
+17 SET XMSITE=$PIECE(^DIC(4.2,XMINST,0),"^")
+18 DO XMTCHECK^XMKPR(XMINST,.XMB)
+19 ;Find and use TCP/IP channel script
SET XMOKTYPE("TCPCHAN")=""
+20 DO SCRIPT^XMKPR1(XMINST,XMSITE,.XMB,.XMOKTYPE)
if 'XMB("SCR IEN")
QUIT
+21 ; Check that last try is at least 1 minute ago.
+22 ; If we've completed a cycle of scripts, wait until 1 hour has passed
+23 ; before we start the next cycle.
+24 IF XMB("TRIES")
IF $$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60<1
GOTO HALT
+25 IF '$TEST
IF XMB("ITERATIONS")
IF XMB("SCR IEN")=XMB("FIRST SCRIPT")
IF $$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60\60<1
GOTO HALT
+26 SET ZTIO=$PIECE(XMB("SCRIPT"),U,5)
+27 DO XMTAUDT^XMTDR(XMINST,.XMB)
+28 DO ENT^XMC1
+29 HANG 30
+30 DO KILL
+31 GOTO HALT
+32 ;
+33 ;Pause between POLLINGS
QQ DO KILL
SET X=$HOROLOG*86400+$PIECE($HOROLOG,",",2)
if $ORDER(^XMBX(4.2995,0))
GOTO FTP^XMRFTP
+1 SET X=22-($HOROLOG*86400+$PIECE($HOROLOG,",",2)-X)
IF X>0
HANG X
+2 GOTO POLL
+3 ;
+4 ;Entry on dupe name
DUPNAME SET X="ERR^XMRTCP"
SET @^%ZOSF("TRAP")
HANG 15
GOTO L
+1 ;
+2 ;Clean up before next transmission
KILL DO KL1^XMC
KILL DIC,XMB,XMDT,ZTPAR
+1 LOCK
QUIT
+2 ;
SETUP ;Set up environment
+1 NEW IO
SET IO=""
SET IO(0)=""
DO DT^DICRW
+2 QUIT
ERR DO @^%ZOSF("ERRTN")
HANG 60
+1 IF '$FIND(":MM-TCP:MM-FTP:",":"_$EXTRACT($GET(XMRTCP("NAME")),1,6)_":")
DO KILL
GOTO POLL
HALT ;
+1 ;I ^%ZOSF("OS")["VAX" U IO:DISCONNECT
+2 ;G ^XUSCLEAN ; Writes to IO.
+3 ; Supposedly doesn't write to IO.
GOTO H2^XUSCLEAN
+4 ;
+5 ;Entry for Inet_servers interface RECEIVER
+6 ;SMTP service request invokes MailMan
+7 ;
SOC25 SET (XMRPORT,IO,IO(0))=%
SET X=$EXTRACT(%_"-INETMM",1,15)
DO SETENV^%ZOSV
+1 DO DT^DICRW
DO DUZ^XUP(.5)
+2 SET X="ERR^ZU"
SET @^%ZOSF("TRAP")
SET ER=0
+3 OPEN IO:(SHARE,MAILBOX)
USE IO
+4 SET XMCHAN="TCP/IP-MAILMAN"
SET XMNO220=""
+5 DO ENT^XMR
+6 GOTO HALT
+7 ;
+8 ;Check if slot on TCP/IP to use
CK(X) SET I=$PIECE(^XMB(1,1,0),"^",17)
+1 FOR %=1:1
LOCK +^XMBX("TCPCHAN-COUNT",%):1
if $TEST
QUIT
if %=I
QUIT
+2 QUIT $SELECT($TEST:%,1:0)
JOB ;
+1 ;wait for RVG mounts
HANG 90
+2 ;Clear the TCP/IP poller run flag
SET $PIECE(^XMB(1,1,0),"^",18)=""
START GOTO START^XMRTCPGO
ERRSCRPT ;TRAP transmission errors
+1 SET ER=1
+2 IF ^%ZOSF("OS")["VAX DSM"
SET $ECODE=""
+3 QUIT
