XMR0BCP.m

XMR0B ;(WASH ISC)/THM/CAP-SMTP (HELO/MAIL) [ 11/22/95  11:15 AM ]

VER ;;7.1;Mailman;**1003**;OCT 27, 1998

VER ;;7.1;MailMan;**4,6,13**;Jun 02, 1994

HELO ;;HELLO COMMAND

 I XMP="" S XMSG="501 Missing domain specification" X XMSEN Q

 I '$D(^XMB("NETNAME")) S XMSG="550 Unchristened local domain" X XMSEN Q

 D R1^XMR S X=$P(XMP,"<") I $E(X,$L(X))="." S XMSG="Invalid Domain Name" X XMSEN Q

 S XMHELO("XMP")=X,Y=$$DOMAIN(X)

 S XMINST=+Y S:'$G(XMRDOM) XMRDOM=XMINST L +^DIC(4.2,+Y,"XMSSEND") I '$D(^XMBS(4.2999,+Y,0)) D STAT^XMC1(+Y)

 G H:XMBT S XMU=$P($P(XMP,"<",2),">")

 S Y(0)=^DIC(4.2,+Y,0) I XMU'=$P(Y(0),U,15) S XMB="XMVALBAD",XMB(1)=$P(XMP,"<") D ^XMB S XMSG="550 Bad validation number" X XMSEN G HQ

 I $L(XMU) S XMU=($R(8000000)+1000000)

 S XMSG="250 OK "_^XMB("NETNAME")

 ;Extra set below protect replicated DIC global by failing on 1st set

 ;Global does not get out of synch

 I $L(XMU) S XMSG=XMSG_" <"_XMU_">",^DIC(4.2,+Y,0)=Y(0),$P(Y(0),U,15)=XMU,^(0)=Y(0) K XMU

 S XMSG=XMSG_" ["_$P($T(VER),";",3)_",DUP,SER,FTP]"

H S XMSITE=$P(Y,U,2),XMSTATE="^MAIL^",XMCONT=XMCONT_"TURN^MESS^"

 X XMSEN

HQ L -^DIC(4.2,XMINST,"XMSSEND") Q

 ;

DOMAIN(X) ;Domain name of sender acceptable ?

 N DIC,ER,X9,XMA21A,XMP,XMR0B,XMSEN

 S DIC=4.2,DIC(0)="FMO",XMR0B=X D I2^XMA21A

 I Y>0 Q Y

 N % S (%,X)=XMR0B X ^%ZOSF("UPPERCASE") S XMR0B=Y

 F  S Y=$O(^DIC(4.2,"C",XMR0B,0)) D  Q:Y>0!'$L(XMR0B)

 . I Y>0 Q

 . S XMR0B=$P(XMR0B,".",2,$L(XMR0B,"."))

 . Q

 I Y>0 Q $$DQ(Y)

 Q $$DN(%)

DQ(Y) Q Y_"^"_$P(^DIC(4.2,+Y,0),U)

DN(X) ;Add new Domain

 N DA,DD,DO,XMR0B

 X ^%ZOSF("UPPERCASE") S (XMR0B,X)=$P(Y,".",$L(Y,".")),XMR0B("X")=Y

 S DIC="^DIC(4.2,",DIC("DR")="1///C"_$S(^XMB("NETNAME")="CMBSYB.HQW.IHS.GOV":"",1:";2///CMBSYB.HQW.IHS.GOV") D FILE^DICN  ;IHS/MFD changed FORUM.VA to CMBSYB.HQW.IHS

 K DA,DD,DO

 S ^DIC(4.2,+Y,1,0)="^4.21^1^1"

 S ^DIC(4.2,+Y,1,1,0)="AUTO^^^OTHER",^(1,0)="^^1^1^"_DT,^(1,0)="X Q"

 S ^DIC(4.2,+Y,1,"NOTES",0)="^^1^1^"_DT,^(1,0)="Auto-Created-XMR0B"

 N XMDUZ,XMSUB

 S XMDUZ=.5,XMSUB="New Domain created - "_$P(Y,U,2),XMTEXT="A("

 S A(1)="An incoming transmission from this previously undefined"

 S A(2)="domain ("_XMR0B("X")_") caused this new domain"

 S A(3)="("_$P(Y,U,2)_") to be created"

 S A(4)="",A(5)="to limit the number of entries that are created."

 S A(5)="The Internet Suffix is used for this purpose."

 S A(6)="Statistics are then collected for that level of activity."

 S XMY("G.POSTMASTER")="" D ^XMD

 I '$O(^DIC(4.2996,"B",X,0)) S XMR0B("Y")=Y,DIC="^DIC(4.2996,",DIC("DR")="1///AUTOMATIC-XMR0B" D FILE^DICN S Y=XMR0B("Y")

 Q $P(Y,U,1,2)

MAIL ;;START

 S XMP=$P(XMP,":",2,999) I XMP="" S XMSG="501 Invalid reverse-path specification" X XMSEN Q

 I $$REJ(XMP) S XMSG="502 No message receipt authorization." X XMSEN Q

 K XMY,XMY0,^TMP("XMY",$J),^TMP("XMY0",$J),XMA21G D G2^XMA2 S XMZHOLD=XMDUZ,XMDUZ=.5,XMKM=.95

 I '$D(^XMB(3.7,.5,2,.95,0)) S ^(0)="ARRIVING",^XMB(3.7,.5,2,"B","ARRIVING",.95)=""

 D S2^XMA1B

 S XMDUZ=XMZHOLD,XMBCK=XMP,XMSG="250 OK Message-ID:"_XMZ_"@"_^XMB("NETNAME"),XMSTATE="^LOCK^RCPT^DATA",XMLOCK="" X XMSEN Q:ER

 S X="N",%DT="T" D ^%DT S ^XMB(3.9,XMZ,0)="^^"_Y,X=Y,Y=$E(X,6,7)_" "_$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec",U,$E(X,4,5))_" "_$E(X,2,3) S:X\1'=X %=$P(X,".",2)_"0000",Y=Y_" "_$E(%,1,2)_":"_$E(%,3,4)

 S XMD=Y I $G(XMCHAN)="" S XMCHAN="Turn Around"

 S X=XMCHAN,X=$S(X'?.N:X,$D(^DIC(3.4,X,0)):$P(^(0),U),1:"")

 ;DON'T CHANGE ORDER OF .001 & .002 LINES !

 S ^XMB(3.9,XMZ,2,.001,0)="Received: "_$S($L($G(XMSITE("XMP"))):"from "_XMSITE("XMP")_" by "_^XMB("NETNAME")_", MailMan "_$P($T(VER),";",3)_"/"_X,1:"BATCH")_" ; "_XMD_" "_^XMB("TIMEZONE")

 Q

REJ(X) ;Check Senders rejected list

 I '$O(^XMBX(4.501,0)) G Q0

 N A,B,C,D,Y S C=^%ZOSF("UPPERCASE") X C S D=Y,A=""

 F  S A=$O(^XMBX(4.501,"B",A)) G Q0:A="" S X=A X C I D[Y S B=$O(^(A,0)) I B,'$P($G(^XMBX(4.501,B,0)),U,2) Q

 Q 1

Q0 Q 0

XMR0B     ;(WASH ISC)/THM/CAP-SMTP (HELO/MAIL) [ 11/22/95  11:15 AM ]

VER       ;;7.1;Mailman;**1003**;OCT 27, 1998

VER       ;;7.1;MailMan;**4,6,13**;Jun 02, 1994

HELO      ;;HELLO COMMAND

 +1        IF XMP=""

               SET XMSG="501 Missing domain specification"

               XECUTE XMSEN

               QUIT 

 +2        IF '$DATA(^XMB("NETNAME"))

               SET XMSG="550 Unchristened local domain"

               XECUTE XMSEN

               QUIT 

 +3        DO R1^XMR

           SET X=$PIECE(XMP,"<")

           IF $EXTRACT(X,$LENGTH(X))="."

               SET XMSG="Invalid Domain Name"

               XECUTE XMSEN

               QUIT 

 +4        SET XMHELO("XMP")=X

           SET Y=$$DOMAIN(X)

 +5        SET XMINST=+Y

           IF '$GET(XMRDOM)

               SET XMRDOM=XMINST

           LOCK +^DIC(4.2,+Y,"XMSSEND")

           IF '$DATA(^XMBS(4.2999,+Y,0))

               DO STAT^XMC1(+Y)

 +6        IF XMBT

               GOTO H

           SET XMU=$PIECE($PIECE(XMP,"<",2),">")

 +7        SET Y(0)=^DIC(4.2,+Y,0)

           IF XMU'=$PIECE(Y(0),U,15)

               SET XMB="XMVALBAD"

               SET XMB(1)=$PIECE(XMP,"<")

               DO ^XMB

               SET XMSG="550 Bad validation number"

               XECUTE XMSEN

               GOTO HQ

 +8        IF $LENGTH(XMU)

               SET XMU=($RANDOM(8000000)+1000000)

 +9        SET XMSG="250 OK "_^XMB("NETNAME")

 +10      ;Extra set below protect replicated DIC global by failing on 1st set

 +11      ;Global does not get out of synch

 +12       IF $LENGTH(XMU)

               SET XMSG=XMSG_" <"_XMU_">"

               SET ^DIC(4.2,+Y,0)=Y(0)

               SET $PIECE(Y(0),U,15)=XMU

               SET ^(0)=Y(0)

               KILL XMU

 +13       SET XMSG=XMSG_" ["_$PIECE($TEXT(VER),";",3)_",DUP,SER,FTP]"

H          SET XMSITE=$PIECE(Y,U,2)

           SET XMSTATE="^MAIL^"

           SET XMCONT=XMCONT_"TURN^MESS^"

 +1        XECUTE XMSEN

HQ         LOCK -^DIC(4.2,XMINST,"XMSSEND")

           QUIT 

 +1       ;

DOMAIN(X) ;Domain name of sender acceptable ?

 +1        NEW DIC,ER,X9,XMA21A,XMP,XMR0B,XMSEN

 +2        SET DIC=4.2

           SET DIC(0)="FMO"

           SET XMR0B=X

           DO I2^XMA21A

 +3        IF Y>0

               QUIT Y

 +4        NEW %

           SET (%,X)=XMR0B

           XECUTE ^%ZOSF("UPPERCASE")

           SET XMR0B=Y

 +5        FOR 

               SET Y=$ORDER(^DIC(4.2,"C",XMR0B,0))

               Begin DoDot:1

 +6                IF Y>0

                       QUIT 

 +7                SET XMR0B=$PIECE(XMR0B,".",2,$LENGTH(XMR0B,"."))

 +8                QUIT 

               End DoDot:1

               IF Y>0!'$LENGTH(XMR0B)

                   QUIT 

 +9        IF Y>0

               QUIT $$DQ(Y)

 +10       QUIT $$DN(%)

DQ(Y)      QUIT Y_"^"_$PIECE(^DIC(4.2,+Y,0),U)

DN(X)     ;Add new Domain

 +1        NEW DA,DD,DO,XMR0B

 +2        XECUTE ^%ZOSF("UPPERCASE")

           SET (XMR0B,X)=$PIECE(Y,".",$LENGTH(Y,"."))

           SET XMR0B("X")=Y

 +3       ;IHS/MFD changed FORUM.VA to CMBSYB.HQW.IHS

           SET DIC="^DIC(4.2,"

           SET DIC("DR")="1///C"_$SELECT(^XMB("NETNAME")="CMBSYB.HQW.IHS.GOV":"",1:";2///CMBSYB.HQW.IHS.GOV")

           DO FILE^DICN

 +4        KILL DA,DD,DO

 +5        SET ^DIC(4.2,+Y,1,0)="^4.21^1^1"

 +6        SET ^DIC(4.2,+Y,1,1,0)="AUTO^^^OTHER"

           SET ^(1,0)="^^1^1^"_DT

           SET ^(1,0)="X Q"

 +7        SET ^DIC(4.2,+Y,1,"NOTES",0)="^^1^1^"_DT

           SET ^(1,0)="Auto-Created-XMR0B"

 +8        NEW XMDUZ,XMSUB

 +9        SET XMDUZ=.5

           SET XMSUB="New Domain created - "_$PIECE(Y,U,2)

           SET XMTEXT="A("

 +10       SET A(1)="An incoming transmission from this previously undefined"

 +11       SET A(2)="domain ("_XMR0B("X")_") caused this new domain"

 +12       SET A(3)="("_$PIECE(Y,U,2)_") to be created"

 +13       SET A(4)=""

           SET A(5)="to limit the number of entries that are created."

 +14       SET A(5)="The Internet Suffix is used for this purpose."

 +15       SET A(6)="Statistics are then collected for that level of activity."

 +16       SET XMY("G.POSTMASTER")=""

           DO ^XMD

 +17       IF '$ORDER(^DIC(4.2996,"B",X,0))

               SET XMR0B("Y")=Y

               SET DIC="^DIC(4.2996,"

               SET DIC("DR")="1///AUTOMATIC-XMR0B"

               DO FILE^DICN

               SET Y=XMR0B("Y")

 +18       QUIT $PIECE(Y,U,1,2)

MAIL      ;;START

 +1        SET XMP=$PIECE(XMP,":",2,999)

           IF XMP=""

               SET XMSG="501 Invalid reverse-path specification"

               XECUTE XMSEN

               QUIT 

 +2        IF $$REJ(XMP)

               SET XMSG="502 No message receipt authorization."

               XECUTE XMSEN

               QUIT 

 +3        KILL XMY,XMY0,^TMP("XMY",$JOB),^TMP("XMY0",$JOB),XMA21G

           DO G2^XMA2

           SET XMZHOLD=XMDUZ

           SET XMDUZ=.5

           SET XMKM=.95

 +4        IF '$DATA(^XMB(3.7,.5,2,.95,0))

               SET ^(0)="ARRIVING"

               SET ^XMB(3.7,.5,2,"B","ARRIVING",.95)=""

 +5        DO S2^XMA1B

 +6        SET XMDUZ=XMZHOLD

           SET XMBCK=XMP

           SET XMSG="250 OK Message-ID:"_XMZ_"@"_^XMB("NETNAME")

           SET XMSTATE="^LOCK^RCPT^DATA"

           SET XMLOCK=""

           XECUTE XMSEN

           IF ER

               QUIT 

 +7        SET X="N"

           SET %DT="T"

           DO ^%DT

           SET ^XMB(3.9,XMZ,0)="^^"_Y

           SET X=Y

           SET Y=$EXTRACT(X,6,7)_" "_$PIECE("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec",U,$EXTRACT(X,4,5))_" "_$EXTRACT(X,2,3)

           IF X\1'=X

               SET %=$PIECE(X,".",2)_"0000"

               SET Y=Y_" "_$EXTRACT(%,1,2)_":"_$EXTRACT(%,3,4)

 +8        SET XMD=Y

           IF $GET(XMCHAN)=""

               SET XMCHAN="Turn Around"

 +9        SET X=XMCHAN

           SET X=$SELECT(X'?.N:X,$DATA(^DIC(3.4,X,0)):$PIECE(^(0),U),1:"")

 +10      ;DON'T CHANGE ORDER OF .001 & .002 LINES !

 +11       SET ^XMB(3.9,XMZ,2,.001,0)="Received: "_$SELECT($LENGTH($GET(XMSITE("XMP"))):"from "_XMSITE("XMP")_" by "_^XMB("NETNAME")_", MailMan "_$PIECE($TEXT(VER),";",3)_"/"_X,1:"BATCH")_" ; "_XMD_" "_^XMB("TIMEZONE")

 +12       QUIT 

REJ(X)    ;Check Senders rejected list

 +1        IF '$ORDER(^XMBX(4.501,0))

               GOTO Q0

 +2        NEW A,B,C,D,Y

           SET C=^%ZOSF("UPPERCASE")

           XECUTE C

           SET D=Y

           SET A=""

 +3        FOR 

               SET A=$ORDER(^XMBX(4.501,"B",A))

               IF A=""

                   GOTO Q0

               SET X=A

               XECUTE C

               IF D[Y

                   SET B=$ORDER(^(A,0))

                   IF B

                       IF '$PIECE($GET(^XMBX(4.501,B,0)),U,2)

                           QUIT 

 +4        QUIT 1

Q0         QUIT 0