VAFHPURG ;ALB/JLU;Purging routine. ; 8/9/04 11:00am
;;5.3;Registration;**91,219,530,604,1015**;Jun 06, 1996;Build 21
;
;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
N DA,DIC,DIQ,DR,VAR1,VARA,DAYS,X1,X2
;find number of days worth of file entries to be retained
S VAR1=$O(^DG(43,0))
S DIC="^DG(43,",DA=VAR1,DIQ="VARA",DIQ(0)="I",DR="391.702;"
D EN^DIQ1
;use 547 days (18 months) unless otherwise specified
S DAYS=VARA(43,VAR1,391.702,"I") S:+DAYS=0 DAYS=547
D DT^DICRW
S X1=DT
S X2=-DAYS
D C^%DTC
S (Y,VAFHEDT)=X
D DD^%DT
W:'$D(ZTQUEUED) !!,"All ADT/HL7 PIVOT entries older than ",Y," will be deleted!",!
D KIL1
;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
D EXIT
;D CLEAN
;D EXIT
Q
;
DELETE ;this will do that actual deletion.
;
N DA,DIK,EVENT,MOVE,OUT
S DA=0
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
.S EVENT=+$P(^VAT(391.71,DA,0),U,4)
.I EVENT=1 D Q:OUT
..S OUT=0
..S MOVE=$P(^VAT(391.71,DA,0),U,5)
..Q:MOVE'["DGPM"
..I $P($G(^DGPM(+MOVE,0)),U,17)="" S OUT=1
.;don't delete if requires transmission
.Q:$D(^VAT(391.71,"AXMIT",EVENT,DA))
.;delete
.S DIK="^VAT(391.71,"
.D ^DIK
.W:'$D(ZTQUEUED) "."
Q
;
EXIT ;kills variables
K VAFHX,VAFHEDT,X,Y
Q
;
KIL1 K X,Y,%DT
Q
;
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",!
D DT^DICRW
N EVENTVP,GLOBAL,GLOBALR,NODE
S VAFHX=0
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
Q
;
;either the pointed to entry doesn't exist or the VP entry is invalid
;so delete it
REMOVE S DA=VAFHX
S DIK="^VAT(391.71,"
D ^DIK
I '$D(ZTQUEUED) W ","
K DIK,DA
Q
VAFHPURG ;ALB/JLU;Purging routine. ; 8/9/04 11:00am
+1 ;;5.3;Registration;**91,219,530,604,1015**;Jun 06, 1996;Build 21
+2 ;
+3 ;This routine will delete all entries from the ADT/HL7 PIVOT
+4 ;(#391.71) file that are older than number of days specified
+5 ;in field #391.702 of file #43.
+6 ;
EN ;entry point
+1 NEW DA,DIC,DIQ,DR,VAR1,VARA,DAYS,X1,X2
+2 ;find number of days worth of file entries to be retained
+3 SET VAR1=$ORDER(^DG(43,0))
+4 SET DIC="^DG(43,"
SET DA=VAR1
SET DIQ="VARA"
SET DIQ(0)="I"
SET DR="391.702;"
+5 DO EN^DIQ1
+6 ;use 547 days (18 months) unless otherwise specified
+7 SET DAYS=VARA(43,VAR1,391.702,"I")
IF +DAYS=0
SET DAYS=547
+8 DO DT^DICRW
+9 SET X1=DT
+10 SET X2=-DAYS
+11 DO C^%DTC
+12 SET (Y,VAFHEDT)=X
+13 DO DD^%DT
+14 IF '$DATA(ZTQUEUED)
WRITE !!,"All ADT/HL7 PIVOT entries older than ",Y," will be deleted!",!
+15 DO KIL1
+16 ;iofo-bay pines;vmp;teh; modification to quit logical to prevent null subscript.
+17 FOR VAFHX=0:0
SET VAFHX=$ORDER(^VAT(391.71,"B",VAFHX))
IF VAFHX>VAFHEDT!(VAFHX="")
QUIT
DO DELETE
+18 DO EXIT
+19 ;D CLEAN
+20 ;D EXIT
+21 QUIT
+22 ;
DELETE ;this will do that actual deletion.
+1 ;
+2 NEW DA,DIK,EVENT,MOVE,OUT
+3 SET DA=0
+4 FOR
SET DA=+$ORDER(^VAT(391.71,"B",VAFHX,DA))
IF ('DA)
QUIT
Begin DoDot:1
+5 ;DG*604 - skip if no zero node
+6 IF '$DATA(^VAT(391.71,DA,0))
QUIT
+7 ;don't delete inpatient event records before discharge
+8 SET EVENT=+$PIECE(^VAT(391.71,DA,0),U,4)
+9 IF EVENT=1
Begin DoDot:2
+10 SET OUT=0
+11 SET MOVE=$PIECE(^VAT(391.71,DA,0),U,5)
+12 IF MOVE'["DGPM"
QUIT
+13 IF $PIECE($GET(^DGPM(+MOVE,0)),U,17)=""
SET OUT=1
End DoDot:2
IF OUT
QUIT
+14 ;don't delete if requires transmission
+15 IF $DATA(^VAT(391.71,"AXMIT",EVENT,DA))
QUIT
+16 ;delete
+17 SET DIK="^VAT(391.71,"
+18 DO ^DIK
+19 IF '$DATA(ZTQUEUED)
WRITE "."
End DoDot:1
+20 QUIT
+21 ;
EXIT ;kills variables
+1 KILL VAFHX,VAFHEDT,X,Y
+2 QUIT
+3 ;
KIL1 KILL X,Y,%DT
+1 QUIT
+2 ;
CLEAN ; delete entries with invalid event pointer, ie doesn't exist
+1 ; CLEAN^VAFHPURG may be run directly from programmer mode
+2 ;
+3 IF '$DATA(ZTQUEUED)
WRITE !!,"All ADT/HL7 PIVOT entries with invalid EVENT POINTERS will be deleted",!
+4 DO DT^DICRW
+5 NEW EVENTVP,GLOBAL,GLOBALR,NODE
+6 SET VAFHX=0
+7 FOR
SET VAFHX=$ORDER(^VAT(391.71,VAFHX))
IF 'VAFHX
QUIT
SET NODE=$GET(^(VAFHX,0))
Begin DoDot:1
+8 ; if no .01 date/time
+9 IF 'NODE
DO REMOVE
QUIT
+10 SET EVENTVP=$PIECE(NODE,"^",5)
+11 ; if event pointer has no pointer
+12 IF 'EVENTVP
DO REMOVE
QUIT
+13 SET GLOBAL=$PIECE(EVENTVP,";",2)
+14 ; if event pointer has no variable
+15 IF GLOBAL=""
DO REMOVE
QUIT
+16 ; if variable not distributed
+17 IF "DPT(DGPM(SCE("'[GLOBAL
DO REMOVE
QUIT
+18 SET GLOBALR="^"_GLOBAL_+EVENTVP_")"
+19 ;
+20 IF $DATA(@GLOBALR)
QUIT
+21 ; if no pointed to eentr delete this oney
+22 DO REMOVE
QUIT
End DoDot:1
+23 QUIT
+24 ;
+25 ;either the pointed to entry doesn't exist or the VP entry is invalid
+26 ;so delete it
REMOVE SET DA=VAFHX
+1 SET DIK="^VAT(391.71,"
+2 DO ^DIK
+3 IF '$DATA(ZTQUEUED)
WRITE ","
+4 KILL DIK,DA
+5 QUIT
