VAFHPURG ;ALB/JLU;Purging routine. ; 8/9/04 11:00am
;;5.3;Registration;**91,219,530,604**;Jun 06, 1996
;This routine will delete all entries from the ADT/HL7 PIVOT
;(#391.71) file that are older than number of days specified
;in field #391.702 of file #43.
EN ;entry point
;find number of days worth of file entries to be retained
;use 547 days (18 months) unless otherwise specified
S DAYS=VARA(43,VAR1,391.702,"I") S:+DAYS=0 DAYS=547
W:'$D(ZTQUEUED) !!,"All ADT/HL7 PIVOT entries older than ",Y," will be deleted!",!
;iofo-bay pines;vmp;teh; modification to quit logical to prevent null subscript.
F VAFHX=0:0 S VAFHX=$O(^VAT(391.71,"B",VAFHX)) Q:VAFHX>VAFHEDT!(VAFHX="") D DELETE
DELETE ;this will do that actual deletion.
F S DA=+$O(^VAT(391.71,"B",VAFHX,DA)) Q:('DA) D
.;DG*604 - skip if no zero node
.I '$D(^VAT(391.71,DA,0)) Q
.;don't delete inpatient event records before discharge
.I EVENT=1 D Q:OUT
..I $P($G(^DGPM(+MOVE,0)),U,17)="" S OUT=1
.;don't delete if requires transmission
EXIT ;kills variables
KIL1 K X,Y,%DT
CLEAN ; delete entries with invalid event pointer, ie doesn't exist
; CLEAN^VAFHPURG may be run directly from programmer mode
I '$D(ZTQUEUED) W !!,"All ADT/HL7 PIVOT entries with invalid EVENT POINTERS will be deleted",!
F S VAFHX=$O(^VAT(391.71,VAFHX)) Q:'VAFHX S NODE=$G(^(VAFHX,0)) DO
.; if no .01 date/time
. I 'NODE D REMOVE Q
. S EVENTVP=$P(NODE,"^",5)
.; if event pointer has no pointer
. I 'EVENTVP D REMOVE Q
. S GLOBAL=$P(EVENTVP,";",2)
.; if event pointer has no variable
. I GLOBAL="" D REMOVE Q
.; if variable not distributed
. I "DPT(DGPM(SCE("'[GLOBAL D REMOVE Q
. S GLOBALR="^"_GLOBAL_+EVENTVP_")"
. I $D(@GLOBALR) Q
.; if no pointed to eentr delete this oney
. D REMOVE Q
;either the pointed to entry doesn't exist or the VP entry is invalid
;so delete it
REMOVE S DA=VAFHX
I '$D(ZTQUEUED) W ","