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 ---[H[J[2J[HPRCFACPR 2140 printed Oct 16, 2024@18:02:52 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
