Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPXTRA

PRCPXTRA.m

Go to the documentation of this file.
  1. PRCPXTRA ;WISC/RFJ-purge transaction register ;10 Feb 92
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. N %,%H,%I,DATE,NOWDT,STOPDATE,X,Y
  1. 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
  1. 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
  1. W ! S XP="ARE YOU SURE",XH="ENTER 'YES' TO START THE PURGE, 'NO' OR '^' TO EXIT."
  1. I $$YN^PRCPUYN(2)'=1 Q
  1. W !!,"<*> please wait <*>"
  1. DQ ; automatic purge starts here
  1. N D,DA,DIC,DIK,ITEMDA,TRANDA
  1. S TRANDA=0 F S TRANDA=$O(^PRCP(445.2,"B",PRCP("I"),TRANDA)) Q:'TRANDA S D=$P($G(^PRCP(445.2,TRANDA,0)),"^",17) I D<STOPDATE D
  1. . W "." S DIK="^PRCP(445.2,",DA=TRANDA D ^DIK K DIK,DA
  1. S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA)) Q:'ITEMDA S D=0 F S D=$O(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D)) Q:'D I D<$E(STOPDATE,1,5) K ^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D)
  1. W:'$G(PRCPZTSK) " Finished!" S $P(^PRCP(445,PRCP("I"),0),"^",18)=NOWDT Q
  1. ;
  1. OPTION ;;display entry text
  1. ;;This option will purge the register of all transactions that affect the
  1. ;;inventory point up to date DATE.
  1. ;;
  1. ;;The transaction register for and after DATE will NOT be purged.