- PRCPXREC ;WISC/RFJ-purge receipts ;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 DA,DATE,DIC,DIK,ITEMDA
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
- . S DATE=0 F S DATE=$O(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATE)) Q:'DATE!(DATE'<STOPDATE) D
- . . W "." S DIK="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",3,",DA(1)=ITEMDA,DA(2)=PRCP("I"),DA=DATE D ^DIK K DIK,DA
- W:'$G(PRCPZTSK) " Finished!" S $P(^PRCP(445,PRCP("I"),0),"^",17)=NOWDT Q
- ;
- OPTION ;;display entry text
- ;;This option will purge the receipts history for all the items in the
- ;;inventory point up to the date DATE.
- ;;
- ;;The receipts history for and after DATE will NOT be purged.
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPXREC 1243 printed Feb 18, 2025@23:43:16 Page 2
- PRCPXREC ;WISC/RFJ-purge receipts ;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 DA,DATE,DIC,DIK,ITEMDA
- +2 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- Begin DoDot:1
- +3 SET DATE=0
- FOR
- SET DATE=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATE))
- if 'DATE!(DATE'<STOPDATE)
- QUIT
- Begin DoDot:2
- +4 WRITE "."
- SET DIK="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",3,"
- SET DA(1)=ITEMDA
- SET DA(2)=PRCP("I")
- SET DA=DATE
- DO ^DIK
- KILL DIK,DA
- End DoDot:2
- End DoDot:1
- +5 if '$GET(PRCPZTSK)
- WRITE " Finished!"
- SET $PIECE(^PRCP(445,PRCP("I"),0),"^",17)=NOWDT
- QUIT
- +6 ;
- OPTION ;;display entry text
- +1 ;;This option will purge the receipts history for all the items in the
- +2 ;;inventory point up to the date DATE.
- +3 ;;
- +4 ;;The receipts history for and after DATE will NOT be purged.