| 1 | PRCPXREC ;WISC/RFJ-purge receipts ;10 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)_"01",X1=$E(X,1,5)_"15",X2=-395 D C^%DTC S (Y,STOPDATE)=$E(X,1,5)_"01" 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 <*>"
|
|---|
| 11 | DQ ; 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,3,DATE)) Q:'DATE!(DATE'<STOPDATE) D
|
|---|
| 15 | . . W "." S DIK="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",3,",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),"^",17)=NOWDT Q
|
|---|
| 17 | ;
|
|---|
| 18 | OPTION ;;display entry text
|
|---|
| 19 | ;;This option will purge the receipts history for all the items in the
|
|---|
| 20 | ;;inventory point up to the date DATE.
|
|---|
| 21 | ;;
|
|---|
| 22 | ;;The receipts history for and after DATE will NOT be purged.
|
|---|
