PRCFACPR.m

PRCFACPR ;WISC@ALTOONA/CTB-PURGE CODE SHEETS SYSTEM ;11-27-92/08:17

V ;;5.1;IFCAP;**116,193**;Oct 20, 2000;Build 9

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 ;PRC*5.1*193 Added universal date control query to process

 ;

 S PRCFASYS="FEE^FEN^RR^IRS^CLI^ISM^PRC"

EN I $D(ZTQUEUED) G SCHEDULE

A S U="^" F I=1:1 Q:$P($T(A+I),";",3)=""  W !,$P($T(A+I),";",3,99)

 ;;This routine will delete LOG Code Sheets from the Code Sheet file

 ;;and Batch and Transmission records from the LOG Transmission Record File.

 ;;It will delete all reference to these code sheets, batches and transmission

 ;;records, except references maintained in the Code Sheet History section of

 ;;the Purchase Order file.  Deletion is base on the transmission date of

 ;;the code sheet and date created for batch and transmission records.

 ;;

 S PRCF("X")="AS" D ^PRCFSITE G:'% OUT

 ;

DT ;SELECT FISCAL YEAR      PRC*5.1*193

 S PRCGOUT=$$PURGEDT^PRCGPUTL("",7)

 I PRCGPGDT'>0!PRCGOUT G OUT

 S Y=PRCGPGDT,PRCFA("KDATE")=Y,X1=Y

 ;

 D NOW^PRCFQ S X2=X S Y=X D D^PRCFQ S Y1=Y S Y=X1,X=X1 D D^PRCFQ S PRCFA("DATE")=Y

 W ! S %A="I will now delete all LOG code sheets and associated records which were"

 S %A(1)="transmitted before "_Y_" for station "_PRC("SITE")_".",%A(2)="OK to continue",%B="" S %=1 D ^PRCFYN G:%'=1 OUT

 W $C(7) S %A="ARE YOU SURE",%B="With a response of 'YES', I will begin deleting the code sheets and transmission records NOW." S %=2 D ^PRCFYN G:%'=1 OUT

 D NOW^PRCFQ S PRCFA("QTIME")=%X

 S PRCFQ("FORCEQ")="",PRCFA("QION")=ION,ZTSAVE("PRCFASYS")="",ZTDESC="PURGE CODE SHEET AND TRANSMISSION RECORDS",ZTRTN="DQ^PRCFACPS",ZTSAVE("PRCFA*")="",ZTSAVE("PRC*")="" D ^PRCFQ

OUT K %,%DT,%H,%I,D,DA,DIC,DIK,I,J,JX,K,PRCFA,TRANS,X,X1,X2,X3,Y,Y1,Z,ZERO,PRCGOUT,PRCGPGDT Q

SCHEDULE ;ENTRY POINT AS SCHEDULED OPTION

 S PRCFA("QTIME")="Recurring",PRCFA("QION")="N/A"

 S PRC("SITE")=0 F I=1:1 S PRC("SITE")=$O(^PRC(411,PRC("SITE"))) Q:'PRC("SITE")  I $D(^(PRC("SITE"),0)) S X=$P(^(0),"^",14) I X D C,DQ^PRCFACPS

 Q

C S X2=-(X) D NOW^PRCFQ S X1=X D C^%DTC S Y1=Y,(Y,PRCFA("KDATE"))=X D D^PRCFQ S PRCFA("DATE")=Y Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFACPR   2140     printed  Mar 13, 2025@21:06:54                                                                                                                                                                                                    Page 2

PRCFACPR  ;WISC@ALTOONA/CTB-PURGE CODE SHEETS SYSTEM ;11-27-92/08:17

V         ;;5.1;IFCAP;**116,193**;Oct 20, 2000;Build 9

 +1       ;Per VA Directive 6402, this routine should not be modified.

 +2       ;

 +3       ;PRC*5.1*193 Added universal date control query to process

 +4       ;

 +5        SET PRCFASYS="FEE^FEN^RR^IRS^CLI^ISM^PRC"

EN         IF $DATA(ZTQUEUED)

               GOTO SCHEDULE

A          SET U="^"

           FOR I=1:1

               if $PIECE($TEXT(A+I),";",3)=""

                   QUIT 

               WRITE !,$PIECE($TEXT(A+I),";",3,99)

 +1       ;;This routine will delete LOG Code Sheets from the Code Sheet file

 +2       ;;and Batch and Transmission records from the LOG Transmission Record File.

 +3       ;;It will delete all reference to these code sheets, batches and transmission

 +4       ;;records, except references maintained in the Code Sheet History section of

 +5       ;;the Purchase Order file.  Deletion is base on the transmission date of

 +6       ;;the code sheet and date created for batch and transmission records.

 +7       ;;

 +8        SET PRCF("X")="AS"

           DO ^PRCFSITE

           if '%

               GOTO OUT

 +9       ;

DT        ;SELECT FISCAL YEAR      PRC*5.1*193

 +1        SET PRCGOUT=$$PURGEDT^PRCGPUTL("",7)

 +2        IF PRCGPGDT'>0!PRCGOUT

               GOTO OUT

 +3        SET Y=PRCGPGDT

           SET PRCFA("KDATE")=Y

           SET X1=Y

 +4       ;

 +5        DO NOW^PRCFQ

           SET X2=X

           SET Y=X

           DO D^PRCFQ

           SET Y1=Y

           SET Y=X1

           SET X=X1

           DO D^PRCFQ

           SET PRCFA("DATE")=Y

 +6        WRITE !

           SET %A="I will now delete all LOG code sheets and associated records which were"

 +7        SET %A(1)="transmitted before "_Y_" for station "_PRC("SITE")_"."

           SET %A(2)="OK to continue"

           SET %B=""

           SET %=1

           DO ^PRCFYN

           if %'=1

               GOTO OUT

 +8        WRITE $CHAR(7)

           SET %A="ARE YOU SURE"

           SET %B="With a response of 'YES', I will begin deleting the code sheets and transmission records NOW."

           SET %=2

           DO ^PRCFYN

           if %'=1

               GOTO OUT

 +9        DO NOW^PRCFQ

           SET PRCFA("QTIME")=%X

 +10       SET PRCFQ("FORCEQ")=""

           SET PRCFA("QION")=ION

           SET ZTSAVE("PRCFASYS")=""

           SET ZTDESC="PURGE CODE SHEET AND TRANSMISSION RECORDS"

           SET ZTRTN="DQ^PRCFACPS"

           SET ZTSAVE("PRCFA*")=""

           SET ZTSAVE("PRC*")=""

           DO ^PRCFQ

OUT        KILL %,%DT,%H,%I,D,DA,DIC,DIK,I,J,JX,K,PRCFA,TRANS,X,X1,X2,X3,Y,Y1,Z,ZERO,PRCGOUT,PRCGPGDT

           QUIT 

SCHEDULE  ;ENTRY POINT AS SCHEDULED OPTION

 +1        SET PRCFA("QTIME")="Recurring"

           SET PRCFA("QION")="N/A"

 +2        SET PRC("SITE")=0

           FOR I=1:1

               SET PRC("SITE")=$ORDER(^PRC(411,PRC("SITE")))

               if 'PRC("SITE")

                   QUIT 

               IF $DATA(^(PRC("SITE"),0))

                   SET X=$PIECE(^(0),"^",14)

                   IF X

                       DO C

                       DO DQ^PRCFACPS

 +3        QUIT 

C          SET X2=-(X)

           DO NOW^PRCFQ

           SET X1=X

           DO C^%DTC

           SET Y1=Y

           SET (Y,PRCFA("KDATE"))=X

           DO D^PRCFQ

           SET PRCFA("DATE")=Y

           QUIT