source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACD.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.7 KB
Line 
1PRCFACD ;WISC@ALTOONA/CTB-AUTO PURGE OF CODE SHEETS ;25 May 90/12:17 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 S IOP="HOME" D ^%ZIS K IOP W @IOF I '$D(DUZ(0)) S DUZ(0)=""
5 S PRCFSN=0 F I=1:1 S PRCFSN=$O(^PRC(411,PRCFSN)) Q:PRCFSN=""!(PRCFSN'?.N) K Y D A
6OUT K PRCFSN,PRCFDATE,I,J,X,Y,%DT,D0,DA Q
7EN1 ;ENTRY POINT TO DELETE ALL CODE SHEETS (BEYOND RETENTION PERIOD) FOR A SINGLE STATION
8 S PRCF("X")="ASF" D ^PRCFSITE Q:'%
9 K PRC("FY"),PRC("PARAM"),PRC("QTR")
10 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")
11 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=""
12 S %=1 D ^PRCFYN I %'=1 W $C(7)," <NOTHING DELETED>" R X:3 Q
13 S Y=X D A G OUT
14 Q
15EN2 ;DELETE A SINGLE CODE SHEET
16 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
17 S %A="OK TO DELETE",%B="" S %=2 D ^PRCFYN I %'=1 W $C(7)," <NOTHING DELETED>" R X:3 Q
18 S DA=+Y D K W " CODE SHEET DELETED",$C(7) R X:2 Q
19 Q
20A ;SELECT CODE SHEETS TO BE DELETED FOR STATION NUMBER PRCFSN
21 I '$D(Y) S X=$P(^PRC(411,PRCFSN,0),"^",14) S:X="" X=90 S X="T-"_X,%DT="" D ^%DT
22 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
23 W !!,L," CODE SHEETS DELETED FOR STATION ",PRC("SITE") Q
24K ;KILL THE CODE SHEET AND CROSS REFERENCES
25 S DIK="^PRCF(423," D WAIT^PRCFYN,^DIK K DA S PRCFDEL="" Q
26 K K,X,DA Q
Note: See TracBrowser for help on using the repository browser.