PRCPXREC.m

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 ---PRCPXREC   1243     printed  Apr 09, 2024@21:12                                                                                                                                                                                                       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.