PRCPXALL ;WISC/RFJ-purge all automatically by TaskManager ; 2/19/07 1:19pm
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
DQ ; TaskManager comes here to start the automatic purge of
; inventory points.
N %,%H,%I,INVPT,NOWDT,PRCP,PRCPZTSK,STOPDATE,TYPE,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"
S PRCPZTSK=1
S INVPT=0 F S INVPT=$O(^PRCP(445,INVPT)) Q:'INVPT I $P($G(^(INVPT,0)),"^",21)="Y" S TYPE=$P(^(0),"^",3) I TYPE'="" D
. S PRCP("I")=INVPT
. ; distribution history (file 446)
. I TYPE'="S" D DQ^PRCPXDIS
. ; receipts
. D DQ^PRCPXREC
. ; transaction register
. D DQ^PRCPXTRA
. ; usage/distribution totals
. D DQ^PRCPXUSE
. ; on-demand item audits (PRC*5.1*98)
. I TYPE'="W" D DQ^PRCPXODI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPXALL 907 printed Oct 16, 2024@18:17:35 Page 2
PRCPXALL ;WISC/RFJ-purge all automatically by TaskManager ; 2/19/07 1:19pm
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
DQ ; TaskManager comes here to start the automatic purge of
+1 ; inventory points.
+2 NEW %,%H,%I,INVPT,NOWDT,PRCP,PRCPZTSK,STOPDATE,TYPE,X,Y
+3 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"
+4 SET PRCPZTSK=1
+5 SET INVPT=0
FOR
SET INVPT=$ORDER(^PRCP(445,INVPT))
if 'INVPT
QUIT
IF $PIECE($GET(^(INVPT,0)),"^",21)="Y"
SET TYPE=$PIECE(^(0),"^",3)
IF TYPE'=""
Begin DoDot:1
+6 SET PRCP("I")=INVPT
+7 ; distribution history (file 446)
+8 IF TYPE'="S"
DO DQ^PRCPXDIS
+9 ; receipts
+10 DO DQ^PRCPXREC
+11 ; transaction register
+12 DO DQ^PRCPXTRA
+13 ; usage/distribution totals
+14 DO DQ^PRCPXUSE
+15 ; on-demand item audits (PRC*5.1*98)
+16 IF TYPE'="W"
DO DQ^PRCPXODI
End DoDot:1
+17 QUIT
