PRCPXDIS.m

PRCPXDIS ;WISC/RFJ-purge distribution usage history                 ;12 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,DISTDA

 S DISTDA=0 F  S DISTDA=$O(^PRCP(446,"AD",PRCP("I"),DISTDA)) Q:'DISTDA  S D=$P($G(^PRCP(446,DISTDA,0)),"^",2) I $E(D,1,5)<$E(STOPDATE,1,5) D

 .   W "." S DIK="^PRCP(446,",DA=DISTDA D ^DIK K DIK,DA

 W:'$G(PRCPZTSK) "  Finished!" S $P(^PRCP(445,PRCP("I"),0),"^",19)=NOWDT Q

 ;

OPTION ;;display entry text

 ;;This option will purge the distribution history for the inventory point

 ;;up to date DATE.

 ;; 

 ;;The distribution history for and after DATE will NOT be purged.

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCPXDIS   1143     printed  Mar 13, 2025@21:21:40                                                                                                                                                                                                    Page 2

PRCPXDIS  ;WISC/RFJ-purge distribution usage history                 ;12 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,DISTDA

 +2        SET DISTDA=0

           FOR 

               SET DISTDA=$ORDER(^PRCP(446,"AD",PRCP("I"),DISTDA))

               if 'DISTDA

                   QUIT 

               SET D=$PIECE($GET(^PRCP(446,DISTDA,0)),"^",2)

               IF $EXTRACT(D,1,5)<$EXTRACT(STOPDATE,1,5)

                   Begin DoDot:1

 +3                    WRITE "."

                       SET DIK="^PRCP(446,"

                       SET DA=DISTDA

                       DO ^DIK

                       KILL DIK,DA

                   End DoDot:1

 +4        if '$GET(PRCPZTSK)

               WRITE "  Finished!"

           SET $PIECE(^PRCP(445,PRCP("I"),0),"^",19)=NOWDT

           QUIT 

 +5       ;

OPTION    ;;display entry text

 +1       ;;This option will purge the distribution history for the inventory point

 +2       ;;up to date DATE.

 +3       ;; 

 +4       ;;The distribution history for and after DATE will NOT be purged.