Routine: XMDIR1

XMDIR1 ;(WASH ISC)/CAP-Load VACO Directories ;04/17/2002  08:47

 ;;8.0;MailMan;;Jun 28, 2002

 ; Entry points used by MailMan options (not covered by DBIA):

 ; OPTION   XMMGR-DIRECTORY-VACO

ENT ;Batch Entry point (TaskMan)

 K ZTREQ,^TMP("XMDIR1",$J) S XMA=0

 ;LOCK to indicate to XMA5 that MailLink in being updated

 L +^XMD("XMDIR1"):1 E  G RES:$D(ZTQUEUED) W !!,$C(7),"<<< This task seems to be running already !",!,"(It cannot be run multiple times concurrently.) >>>" G Q

 U IO(0) S XMDIR1A("CODE")=$S($G(XMDIR1A)=1:"1A",1:"1B")

 I '$D(ZTQUEUED) W !!,"Killing off old AUTOMATIC entries for this code ("_XMDIR1A("CODE")_").",!!

 N DIK

 S DA=0,DIK="^XMD(4.2997,"

 F XMA0=1:1 S DA=$O(^XMD(4.2997,"E",XMDIR1A("CODE"),DA)) Q:+DA'=DA  D ^DIK I '$D(ZTQUEUED),XMA0#10=0 W "."

 ;Kill off very old manual entries that haven't been used

 S DA=0,XMDIR1=$E(DT,1,5)-200,XMDIR1("CNT")=0

 F XMA0=XMA0:1 S DA=$O(^XMD(4.2997,"AC",DA)) Q:$S(DA>XMDIR1:1,DA="":1,1:0)  D ^DIK I '$D(ZTQUEUED),XMA0#10=0 W "."

 I '$D(ZTQUEUED) W !!,"Starting load",!!

 U IO

 ;Load WANG directory

 I $G(XMDIR1A("CODE"))="1A" D ^XMDIR1A

 ;Load NOAVA directory

 I $G(XMDIR1A("CODE"))="1B" D ^XMDIR1B

 K XMDIR1A,XMDIR1B

 I '$D(ZTQUEUED) W !!!,"Task Completed"

 S ^TMP("XMDIR1",$J,.0001)="Remote Directories summary:"

 S ^TMP("XMDIR1",$J,.0002)=""

 I $D(XMDIR1("W")) S ^TMP("XMDIR1",$J,.0003)=XMDIR1("W")_" Wang system records processed."

 I $D(XMDIR1("N")) S ^TMP("XMDIR1",$J,.0003)=XMDIR1("N")_" NOAVA system records processed."

 S XMSUB="REMOTE DIRECTORY AUTOMATIC UPDATE",XMTEXT="^TMP(""XMDIR1"",$J,"

 N XMDUZ S XMDUZ="|XMDIR1_REMOTE_DIRECTORY_UPDATE|",XMY("G.POSTMASTER@"_^XMB("NETNAME"))=""

 I $D(DUZ) S XMY(DUZ)=""

 I $O(XMY(0))="" S XMY(.5)=""

 D ^XMD K A

Q L -^XMD("XMDIR1") K ^TMP("XMDIR1",$J)

 ;Menu option to schedule task

OPTION G ENT:$D(ZTQUEUED)

 N %,%0,%1,%6,D,DA,I,J,X,Y,XMA0,XMB0,XMC0,XMDUZ,XMDIR1,XMSUB,XMY,XMTEXT

 W !!,"You are about to load a file containing a list of names and"

 W !,"addresses into you Remote User Directory (file 4.2997).  This"

 W !,"file originated either from a NOAVA system or a WANG system."

 W !,"Choose the correct file.  We will check it some for format.",!!

 S %ZIS("S")="I $P($G(^(""TYPE"")),U)[""HFS"""

 S %ZIS("A")="Enter either HFS-WANG-DIR or HFS-NOAVA-DIR: "

 S %ZIS("B")="HFS-NOAVA-DIR"

 S %ZIS="Q" D ^%ZIS Q:POP

 S XMF=IO,XMDIR1A=$S(ION="HFS-NOAVA-DIR":2,1:1)

 R !!,"Do you want your job queued? (Answer YES or NO)  NO// ",X:DTIME

 K D S:X="" X="NO" S X=$TR(X,"noyes","NOYES") I $E("YES",1,$L(X))=X S D=1

 W !!,"Before the update occurs entries older than 90 days in the directory"

 W !,"are deleted if they were automatically filed by this procedure."

 W !,"Manually entered entries are deleted if they haven't been used"

 W !,"for at least 2 years."

 W !!,"Users are informed that an update is occuring if they are using"

 W !,"MailLink help options.  But are allowed to continue.",!!

 R !!,"Are you sure you want to do this (Answer 'YES/NO'): NO//",X:DTIME

 S:X="" X="NO" S X=$TR(X,"noyes","NOYES") I $E("YES",1,$L(X))'=X W !!,"Nothing done.",$C(7),!! Q

 I '$G(D) G INT

 D ZTSK W !!,$C(7),"Task #"_ZTSK_" scheduled.",!!

 D ^%ZISC K ZTSK,ZTRTN,ZTDTH,XMDUZ,ZTDESC,IO("Q"),XMDIR1A,XMDIR1B

ER ;Display error

 S XMDIR1("CNT")=XMDIR1("CNT")+1,^TMP("XMDIR1",$J,XMDIR1("CNT"))=XME_":"_XMY Q

ZTSK ;Schedule to run in the evening

 S XMDUZ="[XMDIR1_DIRECTORY_CONVERSION]",ZTRTN="ENT^XMDIR1",ZTDTH=+$H_",64800",ZTSAVE("*")="",ZTDESC="Convert MailLink list"

 S ZTDTH="" D ^%ZTLOAD Q

 ;Job out this process from here

JOB S ZTQUEUED=1,U="^",(IO,IO(0))="" D DT^DICRW G XMDIR1

 ;Reschedule job to run later

RES S ZTREQ=$$HADD^XLFDT($H,,,5)_"^^MailLink Conversion Restart @ "_$H_"^XMZWANG" Q

HFSFILE S DIC="^%ZIS(1,",DIC(0)="AZQME",DIC("S")="I $P($G(^%ZIS(1,Y,""TYPE"")),U)[""HFS"""

 D ^DIC Q:Y<0

 S IOP=X D ^%ZIS Q:POP

 S XMF=$P(^%ZIS(1,IOS,0),U,2) Q

INT ;Interactive processing begins here

 S XMF=$P(^%ZIS(1,IOS,0),U,2)

 W !!,"Answer 'YES' if you mean 'YES'.  All other response mean 'NO'."

 W !,"The first file to be processed is for the "_XMF_"."

 W !,"Enter '^' to skip this portion of the process.",!!

 I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP=""

 S X="NOWANG^XMDIR1B",@^%ZOSF("TRAP")

 U IO R Y:1 U IO(0)

 W !!,"The following string was read from the first line of "_XMF_"."

 W !!,Y,!!,"Is this correct ? NO// " R %:DTIME

 S:%="" %="NO" S %=$TR(%,"noyes","NOYES")

 I $E("YES",1,$L(%))'=% D ^%ZISC Q

 W ! G ENT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMDIR1   4548     printed  Feb 18, 2025@23:37:41                                                                                                                                                                                                      Page 2

XMDIR1    ;(WASH ISC)/CAP-Load VACO Directories ;04/17/2002  08:47

 +1       ;;8.0;MailMan;;Jun 28, 2002

 +2       ; Entry points used by MailMan options (not covered by DBIA):

 +3       ; OPTION   XMMGR-DIRECTORY-VACO

 +4        QUIT

ENT       ;Batch Entry point (TaskMan)

 +1        KILL ZTREQ,^TMP("XMDIR1",$JOB)

           SET XMA=0

 +2       ;

 +3       ;LOCK to indicate to XMA5 that MailLink in being updated

 +4        LOCK +^XMD("XMDIR1"):1

          IF '$TEST

               if $DATA(ZTQUEUED)

                   GOTO RES

               WRITE !!,$CHAR(7),"<<< This task seems to be running already !",!,"(It cannot be run multiple times concurrently.) >>>"

               GOTO Q

 +5       ;

 +6        USE IO(0)

           SET XMDIR1A("CODE")=$SELECT($GET(XMDIR1A)=1:"1A",1:"1B")

 +7        IF '$DATA(ZTQUEUED)

               WRITE !!,"Killing off old AUTOMATIC entries for this code ("_XMDIR1A("CODE")_").",!!

 +8        NEW DIK

 +9        SET DA=0

           SET DIK="^XMD(4.2997,"

 +10       FOR XMA0=1:1

               SET DA=$ORDER(^XMD(4.2997,"E",XMDIR1A("CODE"),DA))

               if +DA'=DA

                   QUIT

               DO ^DIK

               IF '$DATA(ZTQUEUED)

                   IF XMA0#10=0

                       WRITE "."

 +11      ;

 +12      ;Kill off very old manual entries that haven't been used

 +13       SET DA=0

           SET XMDIR1=$EXTRACT(DT,1,5)-200

           SET XMDIR1("CNT")=0

 +14       FOR XMA0=XMA0:1

               SET DA=$ORDER(^XMD(4.2997,"AC",DA))

               if $SELECT(DA>XMDIR1

                   QUIT

               DO ^DIK

               IF '$DATA(ZTQUEUED)

                   IF XMA0#10=0

                       WRITE "."

 +15      ;

 +16       IF '$DATA(ZTQUEUED)

               WRITE !!,"Starting load",!!

 +17       USE IO

 +18      ;Load WANG directory

 +19       IF $GET(XMDIR1A("CODE"))="1A"

               DO ^XMDIR1A

 +20      ;

 +21      ;Load NOAVA directory

 +22       IF $GET(XMDIR1A("CODE"))="1B"

               DO ^XMDIR1B

 +23      ;

 +24       KILL XMDIR1A,XMDIR1B

 +25       IF '$DATA(ZTQUEUED)

               WRITE !!!,"Task Completed"

 +26      ;

 +27       SET ^TMP("XMDIR1",$JOB,.0001)="Remote Directories summary:"

 +28       SET ^TMP("XMDIR1",$JOB,.0002)=""

 +29       IF $DATA(XMDIR1("W"))

               SET ^TMP("XMDIR1",$JOB,.0003)=XMDIR1("W")_" Wang system records processed."

 +30       IF $DATA(XMDIR1("N"))

               SET ^TMP("XMDIR1",$JOB,.0003)=XMDIR1("N")_" NOAVA system records processed."

 +31       SET XMSUB="REMOTE DIRECTORY AUTOMATIC UPDATE"

           SET XMTEXT="^TMP(""XMDIR1"",$J,"

 +32       NEW XMDUZ

           SET XMDUZ="|XMDIR1_REMOTE_DIRECTORY_UPDATE|"

           SET XMY("G.POSTMASTER@"_^XMB("NETNAME"))=""

 +33       IF $DATA(DUZ)

               SET XMY(DUZ)=""

 +34       IF $ORDER(XMY(0))=""

               SET XMY(.5)=""

 +35       DO ^XMD

           KILL A

Q          LOCK -^XMD("XMDIR1")

           KILL ^TMP("XMDIR1",$JOB)

 +1        QUIT

 +2       ;

 +3       ;Menu option to schedule task

OPTION     if $DATA(ZTQUEUED)

               GOTO ENT

 +1        NEW %,%0,%1,%6,D,DA,I,J,X,Y,XMA0,XMB0,XMC0,XMDUZ,XMDIR1,XMSUB,XMY,XMTEXT

 +2        WRITE !!,"You are about to load a file containing a list of names and"

 +3        WRITE !,"addresses into you Remote User Directory (file 4.2997).  This"

 +4        WRITE !,"file originated either from a NOAVA system or a WANG system."

 +5        WRITE !,"Choose the correct file.  We will check it some for format.",!!

 +6        SET %ZIS("S")="I $P($G(^(""TYPE"")),U)[""HFS"""

 +7        SET %ZIS("A")="Enter either HFS-WANG-DIR or HFS-NOAVA-DIR: "

 +8        SET %ZIS("B")="HFS-NOAVA-DIR"

 +9        SET %ZIS="Q"

           DO ^%ZIS

           if POP

               QUIT

 +10       SET XMF=IO

           SET XMDIR1A=$SELECT(ION="HFS-NOAVA-DIR":2,1:1)

 +11       READ !!,"Do you want your job queued? (Answer YES or NO)  NO// ",X:DTIME

 +12       KILL D

           if X=""

               SET X="NO"

           SET X=$TRANSLATE(X,"noyes","NOYES")

           IF $EXTRACT("YES",1,$LENGTH(X))=X

               SET D=1

 +13       WRITE !!,"Before the update occurs entries older than 90 days in the directory"

 +14       WRITE !,"are deleted if they were automatically filed by this procedure."

 +15       WRITE !,"Manually entered entries are deleted if they haven't been used"

 +16       WRITE !,"for at least 2 years."

 +17       WRITE !!,"Users are informed that an update is occuring if they are using"

 +18       WRITE !,"MailLink help options.  But are allowed to continue.",!!

 +19       READ !!,"Are you sure you want to do this (Answer 'YES/NO'): NO//",X:DTIME

 +20       if X=""

               SET X="NO"

           SET X=$TRANSLATE(X,"noyes","NOYES")

           IF $EXTRACT("YES",1,$LENGTH(X))'=X

               WRITE !!,"Nothing done.",$CHAR(7),!!

               QUIT

 +21       IF '$GET(D)

               GOTO INT

 +22       DO ZTSK

           WRITE !!,$CHAR(7),"Task #"_ZTSK_" scheduled.",!!

 +23       DO ^%ZISC

           KILL ZTSK,ZTRTN,ZTDTH,XMDUZ,ZTDESC,IO("Q"),XMDIR1A,XMDIR1B

 +24       QUIT

ER        ;Display error

 +1        SET XMDIR1("CNT")=XMDIR1("CNT")+1

           SET ^TMP("XMDIR1",$JOB,XMDIR1("CNT"))=XME_":"_XMY

           QUIT

ZTSK      ;Schedule to run in the evening

 +1        SET XMDUZ="[XMDIR1_DIRECTORY_CONVERSION]"

           SET ZTRTN="ENT^XMDIR1"

           SET ZTDTH=+$HOROLOG_",64800"

           SET ZTSAVE("*")=""

           SET ZTDESC="Convert MailLink list"

 +2        SET ZTDTH=""

           DO ^%ZTLOAD

           QUIT

 +3       ;Job out this process from here

JOB        SET ZTQUEUED=1

           SET U="^"

           SET (IO,IO(0))=""

           DO DT^DICRW

           GOTO XMDIR1

 +1       ;Reschedule job to run later

RES        SET ZTREQ=$$HADD^XLFDT($HOROLOG,,,5)_"^^MailLink Conversion Restart @ "_$HOROLOG_"^XMZWANG"

           QUIT

HFSFILE    SET DIC="^%ZIS(1,"

           SET DIC(0)="AZQME"

           SET DIC("S")="I $P($G(^%ZIS(1,Y,""TYPE"")),U)[""HFS"""

 +1        DO ^DIC

           if Y<0

               QUIT

 +2        SET IOP=X

           DO ^%ZIS

           if POP

               QUIT

 +3        SET XMF=$PIECE(^%ZIS(1,IOS,0),U,2)

           QUIT

INT       ;Interactive processing begins here

 +1        SET XMF=$PIECE(^%ZIS(1,IOS,0),U,2)

 +2        WRITE !!,"Answer 'YES' if you mean 'YES'.  All other response mean 'NO'."

 +3        WRITE !,"The first file to be processed is for the "_XMF_"."

 +4        WRITE !,"Enter '^' to skip this portion of the process.",!!

 +5        IF $$NEWERR^%ZTER

               NEW $ETRAP,$ESTACK

               SET $ETRAP=""

 +6        SET X="NOWANG^XMDIR1B"

           SET @^%ZOSF("TRAP")

 +7        USE IO

           READ Y:1

           USE IO(0)

 +8        WRITE !!,"The following string was read from the first line of "_XMF_"."

 +9        WRITE !!,Y,!!,"Is this correct ? NO// "

           READ %:DTIME

 +10       if %=""

               SET %="NO"

           SET %=$TRANSLATE(%,"noyes","NOYES")

 +11       IF $EXTRACT("YES",1,$LENGTH(%))'=%

               DO ^%ZISC

               QUIT

 +12       WRITE !

           GOTO ENT

XMDIR1.m