DGPTAPP.m

DGPTAPP ;MTC/ALB - PTF Purge Utilities; 10-14-92

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 ;

PUR ;-- entry point from protocol 'DGPT A/P PURGE'

 N DGTMP

 ;

 ;-- get template to purge

 D SEL^VALM2 I '$D(VALMY) G PURQ

 S DGTMP=$O(^TMP("ARCPTF",$J,"AP LIST","REC",+$O(VALMY(0)),0))

 ;--if data has not been archived quit

 I '$P($G(^DGP(45.62,+DGTMP,0)),U,4) W !,*7,">>> Data Must be Archived before Purge..." H 2 G PURQ

 ;--if data has been already purged quit

 I $P($G(^DGP(45.62,+DGTMP,0)),U,7) W !,*7,">>> Data Already Purged..." H 2 G PURQ

 ;

 ;-- perfrom purge

 I $$WARNING D

 . D PURGE^DGPTAPP1(DGTMP)

 . ;-- update history file

 . D ADDPUR(DGTMP)

 ;

PURQ Q

 ;

PUREX ;-- exit point from protocol 'DGPT A/P PURGE'

 D TMPINT^DGPTLMU2

 S VALMBCK="R"

 Q

 ;

ADDPUR(TEMP) ;-- This function will add PURGE date, user and status

 ;

 ;   INPUT : TEMP - IFN of the History File to update

 ;

 I '$D(^DGP(45.62,TEMP,0)) G ADDPURQ

 W !,">>> Adding Purge data to PTF Archive/Purge History entry."

 W !,"    Deleting Archive Data..." H 2

 S DA=TEMP,DIE="^DGP(45.62,",DR=".05////^S X=DUZ;.06///NOW;.07///1;100///@"

 D ^DIE

 K DIE,DR,DA

ADDPURQ Q

 ;

WARNING() ; This function will display a warning to the user before the

 ; purge of the data will occur. A '1' will be returned if the purge

 ; should continue.

 ;  OUTPUT : 1 - DO NOT CONTINUE

 ;           0 - OK

 W !,*7,"This option will permanently purge data from the Data Base."

 S DIR(0)="Y",DIR("A")="Are you sure that you want to continue ",DIR("B")="NO" D ^DIR K DIR

 Q $S(Y:1,1:0)

 ;

DGPTAPP   ;MTC/ALB - PTF Purge Utilities; 10-14-92

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 +2       ;

PUR       ;-- entry point from protocol 'DGPT A/P PURGE'

 +1        NEW DGTMP

 +2       ;

 +3       ;-- get template to purge

 +4        DO SEL^VALM2

           IF '$DATA(VALMY)

               GOTO PURQ

 +5        SET DGTMP=$ORDER(^TMP("ARCPTF",$JOB,"AP LIST","REC",+$ORDER(VALMY(0)),0))

 +6       ;--if data has not been archived quit

 +7        IF '$PIECE($GET(^DGP(45.62,+DGTMP,0)),U,4)

               WRITE !,*7,">>> Data Must be Archived before Purge..."

               HANG 2

               GOTO PURQ

 +8       ;--if data has been already purged quit

 +9        IF $PIECE($GET(^DGP(45.62,+DGTMP,0)),U,7)

               WRITE !,*7,">>> Data Already Purged..."

               HANG 2

               GOTO PURQ

 +10      ;

 +11      ;-- perfrom purge

 +12       IF $$WARNING

               Begin DoDot:1

 +13               DO PURGE^DGPTAPP1(DGTMP)

 +14      ;-- update history file

 +15               DO ADDPUR(DGTMP)

               End DoDot:1

 +16      ;

PURQ       QUIT 

 +1       ;

PUREX     ;-- exit point from protocol 'DGPT A/P PURGE'

 +1        DO TMPINT^DGPTLMU2

 +2        SET VALMBCK="R"

 +3        QUIT 

 +4       ;

ADDPUR(TEMP) ;-- This function will add PURGE date, user and status

 +1       ;

 +2       ;   INPUT : TEMP - IFN of the History File to update

 +3       ;

 +4        IF '$DATA(^DGP(45.62,TEMP,0))

               GOTO ADDPURQ

 +5        WRITE !,">>> Adding Purge data to PTF Archive/Purge History entry."

 +6        WRITE !,"    Deleting Archive Data..."

           HANG 2

 +7        SET DA=TEMP

           SET DIE="^DGP(45.62,"

           SET DR=".05////^S X=DUZ;.06///NOW;.07///1;100///@"

 +8        DO ^DIE

 +9        KILL DIE,DR,DA

ADDPURQ    QUIT 

 +1       ;

WARNING() ; This function will display a warning to the user before the

 +1       ; purge of the data will occur. A '1' will be returned if the purge

 +2       ; should continue.

 +3       ;  OUTPUT : 1 - DO NOT CONTINUE

 +4       ;           0 - OK

 +5        WRITE !,*7,"This option will permanently purge data from the Data Base."

 +6        SET DIR(0)="Y"

           SET DIR("A")="Are you sure that you want to continue "

           SET DIR("B")="NO"

           DO ^DIR

           KILL DIR

 +7        QUIT $SELECT(Y:1,1:0)

 +8       ;