PRCPXTRA ;WISC/RFJ-purge transaction register ;10 Feb 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N %,%H,%I,DATE,NOWDT,STOPDATE,X,Y
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
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
W ! S XP="ARE YOU SURE",XH="ENTER 'YES' TO START THE PURGE, 'NO' OR '^' TO EXIT."
I $$YN^PRCPUYN(2)'=1 Q
W !!,"<*> please wait <*>"
DQ ; automatic purge starts here
N D,DA,DIC,DIK,ITEMDA,TRANDA
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
. W "." S DIK="^PRCP(445.2,",DA=TRANDA D ^DIK K DIK,DA
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)
W:'$G(PRCPZTSK) " Finished!" S $P(^PRCP(445,PRCP("I"),0),"^",18)=NOWDT Q
;
OPTION ;;display entry text
;;This option will purge the register of all transactions that affect the
;;inventory point up to date DATE.
;;
;;The transaction register for and after DATE will NOT be purged.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPXTRA 1357 printed Oct 16, 2024@18:17:39 Page 2
PRCPXTRA ;WISC/RFJ-purge transaction register ;10 Feb 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW %,%H,%I,DATE,NOWDT,STOPDATE,X,Y
+5 DO NOW^%DTC
SET NOWDT=$EXTRACT(X,1,5)_"01"
SET X1=$EXTRACT(X,1,5)_"15"
SET X2=-395
DO C^%DTC
SET (Y,STOPDATE)=$EXTRACT(X,1,5)_"01"
DO DD^%DT
SET DATE=Y
+6 WRITE !
FOR %=1:1
SET X=$PIECE($TEXT(OPTION+%),";",3,99)
if X=""
QUIT
if X["DATE"
SET X=$PIECE(X,"DATE")_DATE_$PIECE(X,"DATE",2)
WRITE !,X
+7 WRITE !
SET XP="ARE YOU SURE"
SET XH="ENTER 'YES' TO START THE PURGE, 'NO' OR '^' TO EXIT."
+8 IF $$YN^PRCPUYN(2)'=1
QUIT
+9 WRITE !!,"<*> please wait <*>"
DQ ; automatic purge starts here
+1 NEW D,DA,DIC,DIK,ITEMDA,TRANDA
+2 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^PRCP(445.2,"B",PRCP("I"),TRANDA))
if 'TRANDA
QUIT
SET D=$PIECE($GET(^PRCP(445.2,TRANDA,0)),"^",17)
IF D<STOPDATE
Begin DoDot:1
+3 WRITE "."
SET DIK="^PRCP(445.2,"
SET DA=TRANDA
DO ^DIK
KILL DIK,DA
End DoDot:1
+4 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA))
if 'ITEMDA
QUIT
SET D=0
FOR
SET D=$ORDER(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D))
if 'D
QUIT
IF D<$EXTRACT(STOPDATE,1,5)
KILL ^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D)
+5 if '$GET(PRCPZTSK)
WRITE " Finished!"
SET $PIECE(^PRCP(445,PRCP("I"),0),"^",18)=NOWDT
QUIT
+6 ;
OPTION ;;display entry text
+1 ;;This option will purge the register of all transactions that affect the
+2 ;;inventory point up to date DATE.
+3 ;;
+4 ;;The transaction register for and after DATE will NOT be purged.
