- 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 Apr 23, 2025@18:31:22 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
