ASURD02P.m

ASURD02P ; IHS/ITSC/LMH -RPT 2 -YEARLY PURGE TRANS LIST ; 

 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000

 ;This routine formats and prints statistics concerning the Yearly

 ;closeout transaction purge proceedure.  All transactions more than 3

 ;years old will be purged during a yearly closeout.

EN ;EP;PRIMARY ENTRY POINT FOR REPORT 02

 I '$D(IO) D HOME^%ZIS

 I '$D(DUZ(2)) W !,"Report must be run from Kernel option" Q

 I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST

 S ASUK("PTRSEL")=$G(ASUK("PTRSEL")) I ASUK("PTRSEL")]"" G PSER

 S ZTRTN="PSER^ASURD02P",ZTDESC="SAMS RPT 02" D O^ASUUZIS

 I POP S IOP=$I D ^%ZIS Q

 I ASUK(ASUK("PTR"),"Q") Q

PSER ;EP;FOR TASKMAN QUEUE OF PRINT

 I ($D(ASUK("DT"))#10)'=1 D DATE^ASUUDATE

 D U^ASUUZIS

 W @ASUK(ASUK("PTR"),"IOF")

 W !,"REPORT #2 -YEARLY FILE UPDATE",?50,ASUK("DT"),?70,"PAGE :   1",!!!

 F  S ASUX=$O(^XTMP("ASUR","R02",$G(ASUX))) Q:ASUX=""  S ASURX=^XTMP("ASUR","R02",ASUX) X ASURX

 K ASUX

 D PAZ^ASUURHDR W @(IOF)

 Q:ASUK("PTRSEL")']""

 ;D C^ASUUZIS

 Q

ASURD02P  ; IHS/ITSC/LMH -RPT 2 -YEARLY PURGE TRANS LIST ; 

 +1       ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000

 +2       ;This routine formats and prints statistics concerning the Yearly

 +3       ;closeout transaction purge proceedure.  All transactions more than 3

 +4       ;years old will be purged during a yearly closeout.

EN        ;EP;PRIMARY ENTRY POINT FOR REPORT 02

 +1        IF '$DATA(IO)

               DO HOME^%ZIS

 +2        IF '$DATA(DUZ(2))

               WRITE !,"Report must be run from Kernel option"

               QUIT 

 +3        IF '$DATA(ASUL(1,"AR","AP"))

               DO SETAREA^ASULARST

 +4        SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))

           IF ASUK("PTRSEL")]""

               GOTO PSER

 +5        SET ZTRTN="PSER^ASURD02P"

           SET ZTDESC="SAMS RPT 02"

           DO O^ASUUZIS

 +6        IF POP

               SET IOP=$IO

               DO ^%ZIS

               QUIT 

 +7        IF ASUK(ASUK("PTR"),"Q")

               QUIT 

PSER      ;EP;FOR TASKMAN QUEUE OF PRINT

 +1        IF ($DATA(ASUK("DT"))#10)'=1

               DO DATE^ASUUDATE

 +2        DO U^ASUUZIS

 +3        WRITE @ASUK(ASUK("PTR"),"IOF")

 +4        WRITE !,"REPORT #2 -YEARLY FILE UPDATE",?50,ASUK("DT"),?70,"PAGE :   1",!!!

 +5        FOR 

               SET ASUX=$ORDER(^XTMP("ASUR","R02",$GET(ASUX)))

               IF ASUX=""

                   QUIT 

               SET ASURX=^XTMP("ASUR","R02",ASUX)

               XECUTE ASURX

 +6        KILL ASUX

 +7        DO PAZ^ASUURHDR

           WRITE @(IOF)

 +8        IF ASUK("PTRSEL")']""

               QUIT 

 +9       ;D C^ASUUZIS

 +10       QUIT