PRCFACD ;WISC@ALTOONA/CTB-AUTO PURGE OF CODE SHEETS ;25 May 90/12:17 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S IOP="HOME" D ^%ZIS K IOP W @IOF I '$D(DUZ(0)) S DUZ(0)=""
S PRCFSN=0 F I=1:1 S PRCFSN=$O(^PRC(411,PRCFSN)) Q:PRCFSN=""!(PRCFSN'?.N) K Y D A
OUT K PRCFSN,PRCFDATE,I,J,X,Y,%DT,D0,DA Q
EN1 ;ENTRY POINT TO DELETE ALL CODE SHEETS (BEYOND RETENTION PERIOD) FOR A SINGLE STATION
S PRCF("X")="ASF" D ^PRCFSITE Q:'%
K PRC("FY"),PRC("PARAM"),PRC("QTR")
W !!,"THIS PROGRAM WILL DELETE ALL CODE SHEETS FOR A SINGLE STATION NUMBER WHICH HAVE",!,"A TRANSMISSION DATE EARLIER (OLDER) THAN THE DATE SPECIFIED BY THE USER",!! S %DT="EXA" D ^%DT Q:Y<0 S PRCFSN=PRC("SITE")
S X=Y D DD^%DT W ! S %A="ARE YOU SURE YOU WANT TO KILL ALL CODE SHEETS WITH TRANSMISSION ",%A(1)="DATES BEFORE "_Y_" FOR STATION NUMBER "_PRC("SITE"),%B=""
S %=1 D ^PRCFYN I %'=1 W $C(7)," <NOTHING DELETED>" R X:3 Q
S Y=X D A G OUT
Q
EN2 ;DELETE A SINGLE CODE SHEET
S DIC(0)="AMEQN",DIC("A")="Select Code Sheet to be Deleted: ",DIC=423 D ^DIC K DIC I Y<0 W $C(7)," <NOTHING DELETED>" R X:3 Q
S %A="OK TO DELETE",%B="" S %=2 D ^PRCFYN I %'=1 W $C(7)," <NOTHING DELETED>" R X:3 Q
S DA=+Y D K W " CODE SHEET DELETED",$C(7) R X:2 Q
Q
A ;SELECT CODE SHEETS TO BE DELETED FOR STATION NUMBER PRCFSN
I '$D(Y) S X=$P(^PRC(411,PRCFSN,0),"^",14) S:X="" X=90 S X="T-"_X,%DT="" D ^%DT
S PRCFDATE=Y,D0=0,L=0 F J=1:1 S D0=$O(^PRCF(423,D0)) Q:D0=""!(D0'?.N) I $P(^PRCF(423,D0,0),U,2)=PRCFSN,$D(^PRCF(423,D0,"TRANS")),$P(^("TRANS"),"^",3)<PRCFDATE S DA=D0,L=L+1 D K
W !!,L," CODE SHEETS DELETED FOR STATION ",PRC("SITE") Q
K ;KILL THE CODE SHEET AND CROSS REFERENCES
S DIK="^PRCF(423," D WAIT^PRCFYN,^DIK K DA S PRCFDEL="" Q
K K,X,DA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACD 1794 printed Dec 13, 2024@02:02 Page 2
PRCFACD ;WISC@ALTOONA/CTB-AUTO PURGE OF CODE SHEETS ;25 May 90/12:17 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET IOP="HOME"
DO ^%ZIS
KILL IOP
WRITE @IOF
IF '$DATA(DUZ(0))
SET DUZ(0)=""
+3 SET PRCFSN=0
FOR I=1:1
SET PRCFSN=$ORDER(^PRC(411,PRCFSN))
if PRCFSN=""!(PRCFSN'?.N)
QUIT
KILL Y
DO A
OUT KILL PRCFSN,PRCFDATE,I,J,X,Y,%DT,D0,DA
QUIT
EN1 ;ENTRY POINT TO DELETE ALL CODE SHEETS (BEYOND RETENTION PERIOD) FOR A SINGLE STATION
+1 SET PRCF("X")="ASF"
DO ^PRCFSITE
if '%
QUIT
+2 KILL PRC("FY"),PRC("PARAM"),PRC("QTR")
+3 WRITE !!,"THIS PROGRAM WILL DELETE ALL CODE SHEETS FOR A SINGLE STATION NUMBER WHICH HAVE",!,"A TRANSMISSION DATE EARLIER (OLDER) THAN THE DATE SPECIFIED BY THE USER",!!
SET %DT="EXA"
DO ^%DT
if Y<0
QUIT
SET PRCFSN=PRC("SITE")
+4 SET X=Y
DO DD^%DT
WRITE !
SET %A="ARE YOU SURE YOU WANT TO KILL ALL CODE SHEETS WITH TRANSMISSION "
SET %A(1)="DATES BEFORE "_Y_" FOR STATION NUMBER "_PRC("SITE")
SET %B=""
+5 SET %=1
DO ^PRCFYN
IF %'=1
WRITE $CHAR(7)," <NOTHING DELETED>"
READ X:3
QUIT
+6 SET Y=X
DO A
GOTO OUT
+7 QUIT
EN2 ;DELETE A SINGLE CODE SHEET
+1 SET DIC(0)="AMEQN"
SET DIC("A")="Select Code Sheet to be Deleted: "
SET DIC=423
DO ^DIC
KILL DIC
IF Y<0
WRITE $CHAR(7)," <NOTHING DELETED>"
READ X:3
QUIT
+2 SET %A="OK TO DELETE"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
WRITE $CHAR(7)," <NOTHING DELETED>"
READ X:3
QUIT
+3 SET DA=+Y
DO K
WRITE " CODE SHEET DELETED",$CHAR(7)
READ X:2
QUIT
+4 QUIT
A ;SELECT CODE SHEETS TO BE DELETED FOR STATION NUMBER PRCFSN
+1 IF '$DATA(Y)
SET X=$PIECE(^PRC(411,PRCFSN,0),"^",14)
if X=""
SET X=90
SET X="T-"_X
SET %DT=""
DO ^%DT
+2 SET PRCFDATE=Y
SET D0=0
SET L=0
FOR J=1:1
SET D0=$ORDER(^PRCF(423,D0))
if D0=""!(D0'?.N)
QUIT
IF $PIECE(^PRCF(423,D0,0),U,2)=PRCFSN
IF $DATA(^PRCF(423,D0,"TRANS"))
IF $PIECE(^("TRANS"),"^",3)<PRCFDATE
SET DA=D0
SET L=L+1
DO K
+3 WRITE !!,L," CODE SHEETS DELETED FOR STATION ",PRC("SITE")
QUIT
K ;KILL THE CODE SHEET AND CROSS REFERENCES
+1 SET DIK="^PRCF(423,"
DO WAIT^PRCFYN
DO ^DIK
KILL DA
SET PRCFDEL=""
QUIT
+2 KILL K,X,DA
QUIT
