- 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 Jan 18, 2025@03:03:12 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