DGPTAPP1 ;MTC/ALB - PTF Purge/Archive - Purge Continued ; 21 DEC 1992
;;5.3;Registration;;Aug 13, 1993
;
;
PURGE(TMP) ;-- Purge entry point. This function will loop thru the
; PTF records found in the A/P template pointed to by TMP.
; Starting with the PTF Release file, PTF Close Out file, Census
; Work file and finally the PTF record in file #45.
;
; INPUT : TMP - Entry in PTF A/P History File (Sort Template Pointer)
;
N PTF,REC
S REC=$P($G(^DGP(45.62,+TMP,0)),U,8) Q:'REC
S PTF=0 F S PTF=$O(^DIBT(REC,1,PTF)) Q:'PTF D
. D REL(PTF),CLOSE(PTF),CENSUS(PTF),DELPTF(PTF),UPDATE(PTF)
Q
;
REL(PTF) ;-- This function will delete the entries in the PTF
; Release File (#45.83) Associated with the record PTF.
;
; INPUT : PTF - PTF record to delete
;
N I
G:'$D(^DGP(45.83,"C",PTF)) RELQ
S I=0 F S I=$O(^DGP(45.83,"C",PTF,I)) Q:'I D
. S DA(1)=I,DA=PTF,DIK="^DGP(45.83,"_DA(1)_",""P""," D ^DIK
RELQ K DA,DIK
Q
;
CLOSE(PTF) ;-- This function will delete the entries in the PTF Close
; Out file (#45.84), associated with the record PTF.
;
; INPUT : PTF - PTF record to delete
;
G:'$D(^DGP(45.84,PTF)) CLOSEQ
S DA=PTF,DIK="^DGP(45.84," D ^DIK
CLOSEQ K DA,DIK
Q
;
CENSUS(PTF) ;-- This function will delete the entries in the PTF Close
; Out file (#45.84), associated with the record PTF.
;
; INPUT : PTF - PTF record to delete
;
G:'$D(^DG(45.85,"PTF",PTF)) CENSUSQ
S DA=$O(^DG(45.85,"PTF",PTF,0)),DIK="^DG(45.85," D ^DIK
CENSUSQ K DA,DIK
Q
;
DELPTF(PTF) ;-- This function will delete the entries in the PTF
; file (#45), associated with the record PTF.
;
; INPUT : PTF - PTF record to delete
;
G:'$D(^DGPT(PTF)) DELPTFQ
S DA=PTF,DIK="^DGPT(" D ^DIK
DELPTFQ K DA,DIK
Q
;
UPDATE(PTF) ; This function will update the entry in the Patient Movement
; file (#405) cooresponding to the PTF record. The PTF record entry
; in field 16 will be deleted and the PTF PURGED STATUS field 26
; will be set to 1. This field will be used to prevent re-creation
; of the PTF record from a past admission.
;
S DA=0 F S DA=$O(^DGPM("APTF",PTF,DA)) Q:'DA D
. S DIE="^DGPM(",DR=".16///@;.26////1" D ^DIE
K DA,DIE,DR
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
N FLAG
S FLAG=0
W !,*7,"This option will permently purge data from the Data Base."
W !,"Are you sure that you want to continue ?",!
Q FLAG
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAPP1 2597 printed Sep 23, 2025@20:27:35 Page 2
DGPTAPP1 ;MTC/ALB - PTF Purge/Archive - Purge Continued ; 21 DEC 1992
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
+3 ;
PURGE(TMP) ;-- Purge entry point. This function will loop thru the
+1 ; PTF records found in the A/P template pointed to by TMP.
+2 ; Starting with the PTF Release file, PTF Close Out file, Census
+3 ; Work file and finally the PTF record in file #45.
+4 ;
+5 ; INPUT : TMP - Entry in PTF A/P History File (Sort Template Pointer)
+6 ;
+7 NEW PTF,REC
+8 SET REC=$PIECE($GET(^DGP(45.62,+TMP,0)),U,8)
if 'REC
QUIT
+9 SET PTF=0
FOR
SET PTF=$ORDER(^DIBT(REC,1,PTF))
if 'PTF
QUIT
Begin DoDot:1
+10 DO REL(PTF)
DO CLOSE(PTF)
DO CENSUS(PTF)
DO DELPTF(PTF)
DO UPDATE(PTF)
End DoDot:1
+11 QUIT
+12 ;
REL(PTF) ;-- This function will delete the entries in the PTF
+1 ; Release File (#45.83) Associated with the record PTF.
+2 ;
+3 ; INPUT : PTF - PTF record to delete
+4 ;
+5 NEW I
+6 if '$DATA(^DGP(45.83,"C",PTF))
GOTO RELQ
+7 SET I=0
FOR
SET I=$ORDER(^DGP(45.83,"C",PTF,I))
if 'I
QUIT
Begin DoDot:1
+8 SET DA(1)=I
SET DA=PTF
SET DIK="^DGP(45.83,"_DA(1)_",""P"","
DO ^DIK
End DoDot:1
RELQ KILL DA,DIK
+1 QUIT
+2 ;
CLOSE(PTF) ;-- This function will delete the entries in the PTF Close
+1 ; Out file (#45.84), associated with the record PTF.
+2 ;
+3 ; INPUT : PTF - PTF record to delete
+4 ;
+5 if '$DATA(^DGP(45.84,PTF))
GOTO CLOSEQ
+6 SET DA=PTF
SET DIK="^DGP(45.84,"
DO ^DIK
CLOSEQ KILL DA,DIK
+1 QUIT
+2 ;
CENSUS(PTF) ;-- This function will delete the entries in the PTF Close
+1 ; Out file (#45.84), associated with the record PTF.
+2 ;
+3 ; INPUT : PTF - PTF record to delete
+4 ;
+5 if '$DATA(^DG(45.85,"PTF",PTF))
GOTO CENSUSQ
+6 SET DA=$ORDER(^DG(45.85,"PTF",PTF,0))
SET DIK="^DG(45.85,"
DO ^DIK
CENSUSQ KILL DA,DIK
+1 QUIT
+2 ;
DELPTF(PTF) ;-- This function will delete the entries in the PTF
+1 ; file (#45), associated with the record PTF.
+2 ;
+3 ; INPUT : PTF - PTF record to delete
+4 ;
+5 if '$DATA(^DGPT(PTF))
GOTO DELPTFQ
+6 SET DA=PTF
SET DIK="^DGPT("
DO ^DIK
DELPTFQ KILL DA,DIK
+1 QUIT
+2 ;
UPDATE(PTF) ; This function will update the entry in the Patient Movement
+1 ; file (#405) cooresponding to the PTF record. The PTF record entry
+2 ; in field 16 will be deleted and the PTF PURGED STATUS field 26
+3 ; will be set to 1. This field will be used to prevent re-creation
+4 ; of the PTF record from a past admission.
+5 ;
+6 SET DA=0
FOR
SET DA=$ORDER(^DGPM("APTF",PTF,DA))
if 'DA
QUIT
Begin DoDot:1
+7 SET DIE="^DGPM("
SET DR=".16///@;.26////1"
DO ^DIE
End DoDot:1
+8 KILL DA,DIE,DR
+9 QUIT
+10 ;
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 NEW FLAG
+6 SET FLAG=0
+7 WRITE !,*7,"This option will permently purge data from the Data Base."
+8 WRITE !,"Are you sure that you want to continue ?",!
+9 QUIT FLAG
+10 ;
