Routine: APCLSIL3

APCLSIL3 ; IHS/CMI/LAB - ili surveillance ;

 ;;3.0;IHS PCC REPORTS;**24,26,27,28,29,30**;FEB 05, 1997;Build 27

INFORM ;

 W:$D(IOF) @IOF

 W !,$$CTR($$LOC)

 W !,$$CTR($$USR)

 W !!,"This report will create a search template of visits that meet the "

 W !,"Surveillance ILI criteria.  You will be asked the provide the date"

 W !,"range of visits, a name for the visit search template to be created, and"

 W !,"the device to which the cover page/summary will be printed.",!

 W !,"The visits must meet the following criteria:"

 W !?5," - must be in the date range selected by the user"

 W !?5," - must have a service category of H OR A, O, R or S (outpatient)"

 W !?5," - must have at least one diagnosis that is contained in the "

 W !?8,"SURVEILLANCE ILI taxonomy with a temperature recorded on the visit"

 W !?8,"with a value >=100 OR there must be at least one diagnosis in the"

 W !?8,"SURVEILLANCE ILI NO TMP NEEDED taxonomy."

 W !?5," - if ambulatory, must be to a clinic in the SURVEILLANCE ILI CLINICS taxonomy"

 W !?8,"or the provider must be a PHN"

 W !?5," - the patient's name must not contain 'DEMO,PATIENT' (demo patients"

 W !?8,"skipped)"

W !

 D EXIT

 S APCLCTAX=$O(^ATXAX("B","SURVEILLANCE ILI CLINICS",0))  ;clinic taxonomy

 S APCLDTAX=$O(^ATXAX("B","SURVEILLANCE ILI",0))  ;dx taxonomy

 S APCLTTAX=$O(^ATXAX("B","SURVEILLANCE ILI NO TMP NEEDED",0))

 I 'APCLDTAX W !!,"SURVEILLANCE ILI ICD taxonomy missing...cannot continue." D EXIT Q

 I 'APCLCTAX W !!,"SURVEILLANCE ILI CLINICS taxonomy missing...cannot continue." D EXIT Q

 I 'APCLTTAX W !!,"SURVEILLANCE ILI NO TMP NEEDED taxonomy missing...cannot continue." D EXIT Q

DATES K APCLED,APCLBD

 K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Visit Date"

 D ^DIR G:Y<1 EXIT S APCLBD=Y

 K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Visit Date"

 D ^DIR G:Y<1 EXIT S APCLED=Y

 I APCLED<APCLBD D  G DATES

 . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."

 S APCLSD=$$FMADD^XLFDT(APCLBD,-1)_".9999"

STMP ;

 S APCLSTMP=""

 D ^APCLSTMV

 I APCLSTMP="" G DATES

ZIS ;call to XBDBQUE

 S XBRP="PRINT^APCLSIL3",XBRC="PROC1^APCLSIL3",XBRX="EXIT^APCLSIL3",XBNS="APCL"

 D ^XBDBQUE

 D EXIT

EXIT ;clean up and exit

 D EN^XBVK("APCL")

 D ^XBFMK

PROC1 ;

 S APCLJ=$J,APCLH=$H

 S APCLCTAX=$O(^ATXAX("B","SURVEILLANCE ILI CLINICS",0))  ;clinic taxonomy

 S APCLDTAX=$O(^ATXAX("B","SURVEILLANCE ILI",0))  ;dx taxonomy

 I 'APCLCTAX D EXIT Q

 I 'APCLDTAX D EXIT Q

 I 'APCLTTAX D EXIT Q

 S APCLVTOT=0,APCLPTOT=0  ;visit counter

 F  S APCLSD=$O(^AUPNVSIT("B",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED)  D

 .S APCLV=0 F  S APCLV=$O(^AUPNVSIT("B",APCLSD,APCLV)) Q:APCLV'=+APCLV  D

 ..Q:'$D(^AUPNVSIT(APCLV,0))  ;no zero node

 ..Q:$P(^AUPNVSIT(APCLV,0),U,11)  ;deleted visit

 ..Q:"AORHS"'[$P(^AUPNVSIT(APCLV,0),U,7)  ;just want outpatient

 ..S X=0,P=0 F  S X=$O(^AUPNVPRV("AD",APCLV,X)) Q:X'=+X!(P)  D

 ...Q:'$D(^AUPNVPRV(X,0))

 ...S Y=$P(^AUPNVPRV(X,0),U)

 ...S Z=$$VALI^XBDIQ1(200,Y,53.5)

 ...Q:'Z

 ...I $P($G(^DIC(7,Z,9999999)),U,1)=13 S P=1

 ..I P G P

 ..S APCLCLIN=$$CLINIC^APCLV(APCLV,"I")  ;get clinic code

 ..I $P(^AUPNVSIT(APCLV,0),U,7)'="H" Q:APCLCLIN=""

 ..I $P(^AUPNVSIT(APCLV,0),U,7)'="H" Q:'$D(^ATXAX(APCLCTAX,21,"B",APCLCLIN))  ;not in clinic taxonomy

 ..S APCLLOC=$P(^AUPNVSIT(APCLV,0),U,6)  Q:APCLLOC=""  ;no location ???

 ..S APCLDATE=$P($P(^AUPNVSIT(APCLV,0),U),".")

P ..S DFN=$P(^AUPNVSIT(APCLV,0),U,5)

 ..Q:DFN=""

 ..Q:'$D(^DPT(DFN,0))

 ..Q:$P(^DPT(DFN,0),U)["DEMO,PATIENT"

 ..Q:$$DEMO^APCLUTL(DFN,"E")  ;exclude demo patients

 ..S APCLASUF=$P($G(^AUTTLOC(APCLLOC,0)),U,10)

 ..I APCLASUF="" Q  ;no ASUFAC????

 ..S ^TMP($J,"APCLLOCT",APCLASUF,$$JDATE^APCLSILI(APCLDATE))=$G(^TMP($J,"APCLLOCT",APCLASUF,$$JDATE^APCLSILI(APCLDATE)))+1   ;total number of visits on this date/location

 ..S G=0

 ..S X=0 F  S X=$O(^AUPNVPOV("AD",APCLV,X)) Q:X'=+X  D

 ...S T=$P(^AUPNVPOV(X,0),U)

 ...I $$ICD^APCLSILU(T,APCLTTAX,9) S G=1

 ...I $$ICD^APCLSILU(T,APCLDTAX,9),$$TMP100^APCLSILI(APCLV) S G=1

 ..Q:'G  ;no diagnosis

..;

 ..D SET

..Q

.Q

 K ^XTMP("APCLSILI",APCLJ,APCLH)

PRINT ;EP - called from xbdbque

 S APCLPG=0

 D HEADER

 W !!,"Search Template Created: ",$P(^DIBT(APCLSTMP,0),U)

 W !!,"Total # of visits meeting criteria and placed in the template:  ",APCLVTOT

 W !!,"Total # of patients for these visits:  ",APCLPTOT,!

 D EOP

SET ;

 S APCLVTOT=APCLVTOT+1

 S ^DIBT(APCLSTMP,1,APCLV)=""

 Q:$D(^XTMP("APCLSILI",APCLJ,APCLH,"PATS",DFN))

 S APCLPTOT=APCLPTOT+1

 S ^XTMP("APCLSILI",APCLJ,APCLH,"PATS",DFN)=""

HEADER ;

 I 'APCLPG G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQ="" Q

HEAD1 ;

 W:$D(IOF) @IOF S APCLPG=APCLPG+1

 W $P(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!

 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!

 W !,$$CTR("SURVEILLANCE ILI VISIT SEARCH"),!

 W !,$$CTR("DATE RANGE: "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED),80),!

 W !,$$REPEAT^XLFSTR("-",79)

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT["TRM")!$D(IO("S"))

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR(0)="E" D ^DIR

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

STOPD ;EP

 W !!,"This option is used to set a stop date for sending ILI surveillance"

 W !,"visit data to IHS/CDC.  Currently the stop date is preset for "

 W !,"September 1, 2009."

 W !!,"When the nightly export runs, it will check this date. If the stop "

 W !,"date is less than the export date, no data will be exported."

 W !!,"For example, if you want to have the export of data stop on "

 W !,"August 1, 2009, then enter that date here.  If you want to continue"

 W !,"the export indefinitely, select a date in the future.",!

 S DA=$O(^APCLCNTL("B","ILI STOP DATE",0))

 I 'DA W !!,"ILI CONTROL FILE ENTRY MISSING.  NOTIFY PROGRAMMER." K DA Q

 S DIE="^APCLCNTL(",DR=".03"

 D ^DIE

 K DIE,DA

 W !!

 D PAUSE^APCLVL01

PURGE ;EP - CALLED TO PURGE

 W:'$D(ZTQUEUED) !!,"Now cleaning up host files older than 7 DAYS"

 K APCLFILE,APCLDIR

 S APCLDIR=$P($G(^AUTTSITE(1,1)),"^",2)

 I APCLDIR="" S APCLDIR=$P($G(^XTV(8989.3,1,"DEV")),"^",1)

 I APCLDIR="" Q

 S APCLASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)

 S APCLDT=$$FMADD^XLFDT(DT,-7)

 S APCLDT=$$DATE^APCLSILI(APCLDT)

 S APCLFLST=$$LIST^%ZISH(APCLDIR,"FLU_"_APCLASU_"*",.APCLFILE)

 Q:'$O(APCLFILE(""))

 S APCLX=0 F  S APCLX=$O(APCLFILE(APCLX)) Q:APCLX'=+APCLX  D

 .S D=$P($P(APCLFILE(APCLX),"."),"_",3)

 .I D<APCLDT S N=APCLFILE(APCLX) S APCLM=$$DEL^%ZISH(APCLDIR,N)

PURGEPOP ;

 K APCLFILE

 S APCLFLST=$$LIST^%ZISH(APCLDIR,"FLUPOP_"_APCLASU_"*",.APCLFILE)

 Q:'$O(APCLFILE(""))

 S APCLX=0 F  S APCLX=$O(APCLFILE(APCLX)) Q:APCLX'=+APCLX  D

 .S D=$P($P(APCLFILE(APCLX),"."),"_",3)

 .I D<APCLDT S N=APCLFILE(APCLX) S APCLM=$$DEL^%ZISH(APCLDIR,N)

APCLSIL3  ; IHS/CMI/LAB - ili surveillance ;

 +1       ;;3.0;IHS PCC REPORTS;**24,26,27,28,29,30**;FEB 05, 1997;Build 27

 +2       ;

 +3       ;

INFORM    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,$$CTR($$LOC)

 +3        WRITE !,$$CTR($$USR)

 +4        WRITE !!,"This report will create a search template of visits that meet the "

 +5        WRITE !,"Surveillance ILI criteria.  You will be asked the provide the date"

 +6        WRITE !,"range of visits, a name for the visit search template to be created, and"

 +7        WRITE !,"the device to which the cover page/summary will be printed.",!

 +8        WRITE !,"The visits must meet the following criteria:"

 +9        WRITE !?5," - must be in the date range selected by the user"

 +10       WRITE !?5," - must have a service category of H OR A, O, R or S (outpatient)"

 +11       WRITE !?5," - must have at least one diagnosis that is contained in the "

 +12       WRITE !?8,"SURVEILLANCE ILI taxonomy with a temperature recorded on the visit"

 +13       WRITE !?8,"with a value >=100 OR there must be at least one diagnosis in the"

 +14       WRITE !?8,"SURVEILLANCE ILI NO TMP NEEDED taxonomy."

 +15       WRITE !?5," - if ambulatory, must be to a clinic in the SURVEILLANCE ILI CLINICS taxonomy"

 +16       WRITE !?8,"or the provider must be a PHN"

 +17       WRITE !?5," - the patient's name must not contain 'DEMO,PATIENT' (demo patients"

 +18       WRITE !?8,"skipped)"

 +19       WRITE !

 +20       DO EXIT

 +21      ;clinic taxonomy

           SET APCLCTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI CLINICS",0))

 +22      ;dx taxonomy

           SET APCLDTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI",0))

 +23       SET APCLTTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI NO TMP NEEDED",0))

 +24       IF 'APCLDTAX

               WRITE !!,"SURVEILLANCE ILI ICD taxonomy missing...cannot continue."

               DO EXIT

               QUIT

 +25       IF 'APCLCTAX

               WRITE !!,"SURVEILLANCE ILI CLINICS taxonomy missing...cannot continue."

               DO EXIT

               QUIT

 +26       IF 'APCLTTAX

               WRITE !!,"SURVEILLANCE ILI NO TMP NEEDED taxonomy missing...cannot continue."

               DO EXIT

               QUIT

 +27      ;

DATES      KILL APCLED,APCLBD

 +1        KILL DIR

           WRITE !

           SET DIR(0)="DO^::EXP"

           SET DIR("A")="Enter Beginning Visit Date"

 +2        DO ^DIR

           IF Y<1

               GOTO EXIT

           SET APCLBD=Y

 +3        KILL DIR

           SET DIR(0)="DO^:DT:EXP"

           SET DIR("A")="Enter Ending Visit Date"

 +4        DO ^DIR

           IF Y<1

               GOTO EXIT

           SET APCLED=Y

 +5       ;

 +6        IF APCLED<APCLBD

               Begin DoDot:1

 +7                WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."

               End DoDot:1

               GOTO DATES

 +8        SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)_".9999"

 +9       ;

STMP      ;

 +1        SET APCLSTMP=""

 +2        DO ^APCLSTMV

 +3        IF APCLSTMP=""

               GOTO DATES

 +4       ;

ZIS       ;call to XBDBQUE

 +1        SET XBRP="PRINT^APCLSIL3"

           SET XBRC="PROC1^APCLSIL3"

           SET XBRX="EXIT^APCLSIL3"

           SET XBNS="APCL"

 +2        DO ^XBDBQUE

 +3        DO EXIT

 +4        QUIT

 +5       ;

EXIT      ;clean up and exit

 +1        DO EN^XBVK("APCL")

 +2        DO ^XBFMK

 +3        QUIT

PROC1     ;

 +1        SET APCLJ=$JOB

           SET APCLH=$HOROLOG

 +2       ;clinic taxonomy

           SET APCLCTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI CLINICS",0))

 +3       ;dx taxonomy

           SET APCLDTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI",0))

 +4        IF 'APCLCTAX

               DO EXIT

               QUIT

 +5        IF 'APCLDTAX

               DO EXIT

               QUIT

 +6        IF 'APCLTTAX

               DO EXIT

               QUIT

 +7       ;

 +8       ;visit counter

           SET APCLVTOT=0

           SET APCLPTOT=0

 +9        FOR

               SET APCLSD=$ORDER(^AUPNVSIT("B",APCLSD))

               IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)

                   QUIT

               Begin DoDot:1

 +10               SET APCLV=0

FOR

                       SET APCLV=$ORDER(^AUPNVSIT("B",APCLSD,APCLV))

                       IF APCLV'=+APCLV

                           QUIT

                       Begin DoDot:2

 +11      ;no zero node

                           IF '$DATA(^AUPNVSIT(APCLV,0))

                               QUIT

 +12      ;deleted visit

                           IF $PIECE(^AUPNVSIT(APCLV,0),U,11)

                               QUIT

 +13      ;just want outpatient

                           IF "AORHS"'[$PIECE(^AUPNVSIT(APCLV,0),U,7)

                               QUIT

 +14                       SET X=0

                           SET P=0

FOR

                               SET X=$ORDER(^AUPNVPRV("AD",APCLV,X))

                               IF X'=+X!(P)

                                   QUIT

                               Begin DoDot:3

 +15                               IF '$DATA(^AUPNVPRV(X,0))

                                       QUIT

 +16                               SET Y=$PIECE(^AUPNVPRV(X,0),U)

 +17                               SET Z=$$VALI^XBDIQ1(200,Y,53.5)

 +18                               IF 'Z

                                       QUIT

 +19                               IF $PIECE($GET(^DIC(7,Z,9999999)),U,1)=13

                                       SET P=1

                               End DoDot:3

 +20                       IF P

                               GOTO P

 +21      ;get clinic code

                           SET APCLCLIN=$$CLINIC^APCLV(APCLV,"I")

 +22                       IF $PIECE(^AUPNVSIT(APCLV,0),U,7)'="H"

                               IF APCLCLIN=""

                                   QUIT

 +23      ;not in clinic taxonomy

                           IF $PIECE(^AUPNVSIT(APCLV,0),U,7)'="H"

                               IF '$DATA(^ATXAX(APCLCTAX,21,"B",APCLCLIN))

                                   QUIT

 +24      ;no location ???

                           SET APCLLOC=$PIECE(^AUPNVSIT(APCLV,0),U,6)

                           IF APCLLOC=""

                               QUIT

 +25                       SET APCLDATE=$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),".")

P                          SET DFN=$PIECE(^AUPNVSIT(APCLV,0),U,5)

 +1                        IF DFN=""

                               QUIT

 +2                        IF '$DATA(^DPT(DFN,0))

                               QUIT

 +3                        IF $PIECE(^DPT(DFN,0),U)["DEMO,PATIENT"

                               QUIT

 +4       ;exclude demo patients

                           IF $$DEMO^APCLUTL(DFN,"E")

                               QUIT

 +5                        SET APCLASUF=$PIECE($GET(^AUTTLOC(APCLLOC,0)),U,10)

 +6       ;no ASUFAC????

                           IF APCLASUF=""

                               QUIT

 +7       ;total number of visits on this date/location

                           SET ^TMP($JOB,"APCLLOCT",APCLASUF,$$JDATE^APCLSILI(APCLDATE))=$GET(^TMP($JOB,"APCLLOCT",APCLASUF,$$JDATE^APCLSILI(APCLDATE)))+1

 +8                        SET G=0

 +9                        SET X=0

FOR

                               SET X=$ORDER(^AUPNVPOV("AD",APCLV,X))

                               IF X'=+X

                                   QUIT

                               Begin DoDot:3

 +10                               SET T=$PIECE(^AUPNVPOV(X,0),U)

 +11                               IF $$ICD^APCLSILU(T,APCLTTAX,9)

                                       SET G=1

 +12                               IF $$ICD^APCLSILU(T,APCLDTAX,9)

                                       IF $$TMP100^APCLSILI(APCLV)

                                           SET G=1

                               End DoDot:3

 +13      ;no diagnosis

                           IF 'G

                               QUIT

 +14      ;

 +15                       DO SET

 +16                       QUIT

                       End DoDot:2

 +17               QUIT

               End DoDot:1

 +18       KILL ^XTMP("APCLSILI",APCLJ,APCLH)

 +19       QUIT

PRINT     ;EP - called from xbdbque

 +1        SET APCLPG=0

 +2        DO HEADER

 +3        WRITE !!,"Search Template Created: ",$PIECE(^DIBT(APCLSTMP,0),U)

 +4        WRITE !!,"Total # of visits meeting criteria and placed in the template:  ",APCLVTOT

 +5        WRITE !!,"Total # of patients for these visits:  ",APCLPTOT,!

 +6        DO EOP

 +7        QUIT

SET       ;

 +1        SET APCLVTOT=APCLVTOT+1

 +2        SET ^DIBT(APCLSTMP,1,APCLV)=""

 +3        IF $DATA(^XTMP("APCLSILI",APCLJ,APCLH,"PATS",DFN))

               QUIT

 +4        SET APCLPTOT=APCLPTOT+1

 +5        SET ^XTMP("APCLSILI",APCLJ,APCLH,"PATS",DFN)=""

 +6        QUIT

HEADER    ;

 +1        IF 'APCLPG

               GOTO HEAD1

 +2        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCLQ=""

                       QUIT

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET APCLPG=APCLPG+1

 +2        WRITE $PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!

 +3        WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!

 +4        WRITE !,$$CTR("SURVEILLANCE ILI VISIT SEARCH"),!

 +5        WRITE !,$$CTR("DATE RANGE: "_$$FMTE^XLFDT(APCLBD)_"-"_$$FMTE^XLFDT(APCLED),80),!

 +6        WRITE !,$$REPEAT^XLFSTR("-",79)

 +7        QUIT

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

EOP       ;EP - End of page.

 +1        IF $EXTRACT(IOST)'="C"

               QUIT

 +2        IF $DATA(ZTQUEUED)!'(IOT["TRM")!$DATA(IO("S"))

               QUIT

 +3        NEW DIR

 +4        KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 +5        SET DIR(0)="E"

           DO ^DIR

 +6        QUIT

 +7       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 +2       ;----------

STOPD     ;EP

 +1        WRITE !!,"This option is used to set a stop date for sending ILI surveillance"

 +2        WRITE !,"visit data to IHS/CDC.  Currently the stop date is preset for "

 +3        WRITE !,"September 1, 2009."

 +4        WRITE !!,"When the nightly export runs, it will check this date. If the stop "

 +5        WRITE !,"date is less than the export date, no data will be exported."

 +6        WRITE !!,"For example, if you want to have the export of data stop on "

 +7        WRITE !,"August 1, 2009, then enter that date here.  If you want to continue"

 +8        WRITE !,"the export indefinitely, select a date in the future.",!

 +9        SET DA=$ORDER(^APCLCNTL("B","ILI STOP DATE",0))

 +10       IF 'DA

               WRITE !!,"ILI CONTROL FILE ENTRY MISSING.  NOTIFY PROGRAMMER."

               KILL DA

               QUIT

 +11       SET DIE="^APCLCNTL("

           SET DR=".03"

 +12       DO ^DIE

 +13       KILL DIE,DA

 +14       WRITE !!

 +15       DO PAUSE^APCLVL01

 +16       QUIT

PURGE     ;EP - CALLED TO PURGE

 +1        IF '$DATA(ZTQUEUED)

               WRITE !!,"Now cleaning up host files older than 7 DAYS"

 +2        KILL APCLFILE,APCLDIR

 +3        SET APCLDIR=$PIECE($GET(^AUTTSITE(1,1)),"^",2)

 +4        IF APCLDIR=""

               SET APCLDIR=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)

 +5        IF APCLDIR=""

               QUIT

 +6        SET APCLASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)

 +7        SET APCLDT=$$FMADD^XLFDT(DT,-7)

 +8        SET APCLDT=$$DATE^APCLSILI(APCLDT)

 +9        SET APCLFLST=$$LIST^%ZISH(APCLDIR,"FLU_"_APCLASU_"*",.APCLFILE)

 +10       IF '$ORDER(APCLFILE(""))

               QUIT

 +11       SET APCLX=0

FOR

               SET APCLX=$ORDER(APCLFILE(APCLX))

               IF APCLX'=+APCLX

                   QUIT

               Begin DoDot:1

 +12               SET D=$PIECE($PIECE(APCLFILE(APCLX),"."),"_",3)

 +13               IF D<APCLDT

                       SET N=APCLFILE(APCLX)

                       SET APCLM=$$DEL^%ZISH(APCLDIR,N)

               End DoDot:1

PURGEPOP  ;

 +1        KILL APCLFILE

 +2        SET APCLFLST=$$LIST^%ZISH(APCLDIR,"FLUPOP_"_APCLASU_"*",.APCLFILE)

 +3        IF '$ORDER(APCLFILE(""))

               QUIT

 +4        SET APCLX=0

FOR

               SET APCLX=$ORDER(APCLFILE(APCLX))

               IF APCLX'=+APCLX

                   QUIT

               Begin DoDot:1

 +5                SET D=$PIECE($PIECE(APCLFILE(APCLX),"."),"_",3)

 +6                IF D<APCLDT

                       SET N=APCLFILE(APCLX)

                       SET APCLM=$$DEL^%ZISH(APCLDIR,N)

               End DoDot:1

 +7        QUIT

APCLSIL3.m