PRCPXTRA.m

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 ---PRCPXTRA   1357     printed  Apr 09, 2024@21:16:19                                                                                                                                                                                                    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.