source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPXUSE.m@ 1078

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

initial load of WorldVistAEHR

File size: 1.2 KB
Line 
1PRCPXUSE ;WISC/RFJ-purge usage/distribution totals back 13 months ;08 Feb 92
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 N %,%H,%I,DATE,NOWDT,STOPDATE,X,Y
6 D NOW^%DTC S NOWDT=$E(X,1,5)_"00",X1=$E(X,1,5)_"15",X2=-395 D C^%DTC S (Y,STOPDATE)=$E(X,1,5)_"00" D DD^%DT S DATE=Y
7 W ! F %=1:1 S X=$P($T(OPTION+%),";",3,99) Q:X="" S:X["DATE" X=$P(X,"DATE")_DATE_$P(X,"DATE",2) W !,X
8 W ! S XP="ARE YOU SURE",XH="ENTER 'YES' TO START THE PURGE, 'NO' OR '^' TO EXIT."
9 I $$YN^PRCPUYN(2)'=1 Q
10 W !!,"<*> please wait <*>"
11DQ ; automatic purge starts here
12 N DA,DATE,DIC,DIK,ITEMDA
13 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
14 . S DATE=0 F S DATE=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE)) Q:'DATE!(DATE'<$E(STOPDATE,1,5)) D
15 . . W "." S DIK="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",2,",DA(1)=ITEMDA,DA(2)=PRCP("I"),DA=DATE D ^DIK K DIK,DA
16 W:'$G(PRCPZTSK) " Finished!" S $P(^PRCP(445,PRCP("I"),0),"^",14)=NOWDT Q
17 ;
18OPTION ;;display entry text
19 ;;This option will purge the monthly usage and distribution totals for
20 ;;all the items in the inventory point up to the date DATE.
21 ;;
22 ;;The monthly usage and distribution totals for DATE and after
23 ;;DATE will NOT be purged.
Note: See TracBrowser for help on using the repository browser.