XMDIRQST ;(WASH ISC)/CWU-Request Email Directory ;04/18/2002 07:31
;;8.0;MailMan;;Jun 28, 2002
; Entry points used by MailMan options (not covered by DBIA):
; ALL XMMGR-DIRECTORY-ALL
; EDIT XMMGR-DIRECTORY-EDITGRP
; GROUP XMMGR-DIRECTORY-GROUP
; LISTGRP XMMGR-DIRECTORY-LISTGRP
; SINGLE XMMGR-DIRECTORY-SINGLE
Q
ALL N DIR,Y,A,DTOUT,DUOUT,NETADDR,XMSUB,XMY,ZTDTH,ZTSAVE
S DIR(0)="Y"
S DIR("A")="Request directories from all domains"
S DIR("B")="NO"
S DIR("?")="Enter YES to request directories from all domains."
D ^DIR I $D(DIRUT)!'Y Q
S I=0 F S I=$O(^DIC(4.2,I)) Q:I'=+I D S(I)
Q
SINGLE ;Send a request to one Domain
W !!,"Choose Domains to request Email Directories for."
N DIC,X,Y
S DIC("A")="Select DOMAIN Name: ",DIC="^DIC(4.2,",DIC(0)="AEQZ"
D ^DIC Q:Y<0
D S(+Y)
Q
S(I) ;Schedule Task to Send Request to Domain
N %,X,R ; I=IEN
;Do not send if No Domain Information, etc.
S %=$G(^DIC(4.2,+I,0)) I %="" W $C(7)," ??? No entry in Domain File (4.2) for domain '",I,"'. [S(I)+2^XMDIRQST]" Q
S X=$P(%,U),R=$P(%,U,3) I R W $C(7)," ??? The directory request for ",X," (`",I,") is NOT permitted since it is accessed via relay domain '",$P($G(^DIC(4.2,+R,0)),U)," (`",R,"). [S(I)+3^XMDIRQST] " Q
I X["FOC-AUSTIN" W $C(7)," ??? The request for a directory from ",X," (`",I,") is NOT permitted as it is through FOC-AUSTIN. [S(I)+4^XMDIRQST]" Q
I $E(X,1,2)="Q-" W $C(7)," ??? The request for a directory from ",X," (`",I,") is NOT permitted since it is a relay domain (Q-...). [S(I)+5^XMDIRQST]" Q
I X=^XMB("NETNAME") W $C(7)," ??? You may not request a directory from your own site." Q
TASK ; Set up Task
N XMTASK,NETADDR
S XMTASK=$G(ZTSK) N ZTSK
S NETADDR=X,ZTSAVE("NETADDR")=""
S ZTRTN="ONE^XMDIRQST",ZTDTH=+$H_",64800"
S ZTIO="",ZTDESC="Email Directory Request to - "_X
D ^%ZTLOAD
I 'XMTASK W !!,$C(7),"TASK #"_ZTSK_" scheduled for "_NETADDR
Q
ONE ;
N XMTEXT,XMINSTR
S XMINSTR("FROM")=.5
S XMTEXT(1)="Directory request"
D SENDMSG^XMXSEND(.5,"Request for Email Address Directory","XMTEXT","S.XMMGR-DIRECTORY-SEND@"_NETADDR,.XMINSTR)
Q
LISTGRP ;
N LSTBYGRP S LSTBYGRP=1
GROUP ;
N DIR,Y,DTOUT,DUOUT,NETADDR,XMGROUP,XMSUB,XMY,ZTDTH,ZTSAVE,ZTSK
S DIC="^DIC(4.2,",DIC(0)="AQZXC"
K DO S D="AE",DIC("A")="Enter Directory Group Number: "
S DIC("S")="I $O(^DIC(4.2,""AE"",X,""""))=+Y"
D IX^DIC
Q:Y<1 S (X,XMGROUP)=+^DIC(4.2,+Y,50)
W !!,"Group Number ",X," contains following Domain names : "
S I=0 F S I=$O(^DIC(4.2,"AE",X,I)) Q:I="" W !,$P(^DIC(4.2,I,0),U)
W !!
Q:$G(LSTBYGRP)
S DIR(0)="Y"
S DIR("A")="Do you wish to schedule Directory Request(s) for group number "_XMGROUP
S DIR("B")="NO"
S DIR("?")="Enter YES if you wish to request directories from all domains in the group."
D ^DIR Q:$D(DIRUT)!'Y
S I=0 F S I=$O(^DIC(4.2,"AE",XMGROUP,I)) Q:I="" D S(I)
Q
EDIT ;
W !!,"Enter the Domain name whose Directory Requests Flag you wish to edit."
K DIC S DIC="^DIC(4.2,",DIC(0)="AEQZ" D ^DIC
Q:$D(DTOUT)!$D(DUOUT)!(Y<1)
S DIE="^DIC(4.2,",DA=+Y,DR=50 D ^DIE
G EDIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMDIRQST 3121 printed Nov 22, 2024@17:21:40 Page 2
XMDIRQST ;(WASH ISC)/CWU-Request Email Directory ;04/18/2002 07:31
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; Entry points used by MailMan options (not covered by DBIA):
+3 ; ALL XMMGR-DIRECTORY-ALL
+4 ; EDIT XMMGR-DIRECTORY-EDITGRP
+5 ; GROUP XMMGR-DIRECTORY-GROUP
+6 ; LISTGRP XMMGR-DIRECTORY-LISTGRP
+7 ; SINGLE XMMGR-DIRECTORY-SINGLE
+8 QUIT
ALL NEW DIR,Y,A,DTOUT,DUOUT,NETADDR,XMSUB,XMY,ZTDTH,ZTSAVE
+1 SET DIR(0)="Y"
+2 SET DIR("A")="Request directories from all domains"
+3 SET DIR("B")="NO"
+4 SET DIR("?")="Enter YES to request directories from all domains."
+5 DO ^DIR
IF $DATA(DIRUT)!'Y
QUIT
+6 SET I=0
FOR
SET I=$ORDER(^DIC(4.2,I))
if I'=+I
QUIT
DO S(I)
+7 QUIT
SINGLE ;Send a request to one Domain
+1 WRITE !!,"Choose Domains to request Email Directories for."
+2 NEW DIC,X,Y
+3 SET DIC("A")="Select DOMAIN Name: "
SET DIC="^DIC(4.2,"
SET DIC(0)="AEQZ"
+4 DO ^DIC
if Y<0
QUIT
+5 DO S(+Y)
+6 QUIT
S(I) ;Schedule Task to Send Request to Domain
+1 ; I=IEN
NEW %,X,R
+2 ;Do not send if No Domain Information, etc.
+3 SET %=$GET(^DIC(4.2,+I,0))
IF %=""
WRITE $CHAR(7)," ??? No entry in Domain File (4.2) for domain '",I,"'. [S(I)+2^XMDIRQST]"
QUIT
+4 SET X=$PIECE(%,U)
SET R=$PIECE(%,U,3)
IF R
WRITE $CHAR(7)," ??? The directory request for ",X," (`",I,") is NOT permitted since it is accessed via relay domain '",$PIECE($GET(^DIC(4.2,+R,0)),U)," (`",R,"). [S(I)+3^XMDIRQST] "
QUIT
+5 IF X["FOC-AUSTIN"
WRITE $CHAR(7)," ??? The request for a directory from ",X," (`",I,") is NOT permitted as it is through FOC-AUSTIN. [S(I)+4^XMDIRQST]"
QUIT
+6 IF $EXTRACT(X,1,2)="Q-"
WRITE $CHAR(7)," ??? The request for a directory from ",X," (`",I,") is NOT permitted since it is a relay domain (Q-...). [S(I)+5^XMDIRQST]"
QUIT
+7 IF X=^XMB("NETNAME")
WRITE $CHAR(7)," ??? You may not request a directory from your own site."
QUIT
TASK ; Set up Task
+1 NEW XMTASK,NETADDR
+2 SET XMTASK=$GET(ZTSK)
NEW ZTSK
+3 SET NETADDR=X
SET ZTSAVE("NETADDR")=""
+4 SET ZTRTN="ONE^XMDIRQST"
SET ZTDTH=+$HOROLOG_",64800"
+5 SET ZTIO=""
SET ZTDESC="Email Directory Request to - "_X
+6 DO ^%ZTLOAD
+7 IF 'XMTASK
WRITE !!,$CHAR(7),"TASK #"_ZTSK_" scheduled for "_NETADDR
+8 QUIT
ONE ;
+1 NEW XMTEXT,XMINSTR
+2 SET XMINSTR("FROM")=.5
+3 SET XMTEXT(1)="Directory request"
+4 DO SENDMSG^XMXSEND(.5,"Request for Email Address Directory","XMTEXT","S.XMMGR-DIRECTORY-SEND@"_NETADDR,.XMINSTR)
+5 QUIT
LISTGRP ;
+1 NEW LSTBYGRP
SET LSTBYGRP=1
GROUP ;
+1 NEW DIR,Y,DTOUT,DUOUT,NETADDR,XMGROUP,XMSUB,XMY,ZTDTH,ZTSAVE,ZTSK
+2 SET DIC="^DIC(4.2,"
SET DIC(0)="AQZXC"
+3 KILL DO
SET D="AE"
SET DIC("A")="Enter Directory Group Number: "
+4 SET DIC("S")="I $O(^DIC(4.2,""AE"",X,""""))=+Y"
+5 DO IX^DIC
+6 if Y<1
QUIT
SET (X,XMGROUP)=+^DIC(4.2,+Y,50)
+7 WRITE !!,"Group Number ",X," contains following Domain names : "
+8 SET I=0
FOR
SET I=$ORDER(^DIC(4.2,"AE",X,I))
if I=""
QUIT
WRITE !,$PIECE(^DIC(4.2,I,0),U)
+9 WRITE !!
+10 if $GET(LSTBYGRP)
QUIT
+11 SET DIR(0)="Y"
+12 SET DIR("A")="Do you wish to schedule Directory Request(s) for group number "_XMGROUP
+13 SET DIR("B")="NO"
+14 SET DIR("?")="Enter YES if you wish to request directories from all domains in the group."
+15 DO ^DIR
if $DATA(DIRUT)!'Y
QUIT
+16 SET I=0
FOR
SET I=$ORDER(^DIC(4.2,"AE",XMGROUP,I))
if I=""
QUIT
DO S(I)
+17 QUIT
EDIT ;
+1 WRITE !!,"Enter the Domain name whose Directory Requests Flag you wish to edit."
+2 KILL DIC
SET DIC="^DIC(4.2,"
SET DIC(0)="AEQZ"
DO ^DIC
+3 if $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
QUIT
+4 SET DIE="^DIC(4.2,"
SET DA=+Y
SET DR=50
DO ^DIE
+5 GOTO EDIT
