- DGPTAPP ;MTC/ALB - PTF Purge Utilities; 10-14-92
- ;;5.3;Registration;;Aug 13, 1993
- ;
- 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)
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAPP 1571 printed Feb 19, 2025@00:17:43 Page 2
- DGPTAPP ;MTC/ALB - PTF Purge Utilities; 10-14-92
- +1 ;;5.3;Registration;;Aug 13, 1993
- +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 ;
