source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHPURG.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.5 KB
Line 
1VAFHPURG ;ALB/JLU;Purging routine. ; 8/9/04 11:00am
2 ;;5.3;Registration;**91,219,530,604**;Jun 06, 1996
3 ;
4 ;This routine will delete all entries from the ADT/HL7 PIVOT
5 ;(#391.71) file that are older than number of days specified
6 ;in field #391.702 of file #43.
7 ;
8EN ;entry point
9 N DA,DIC,DIQ,DR,VAR1,VARA,DAYS,X1,X2
10 ;find number of days worth of file entries to be retained
11 S VAR1=$O(^DG(43,0))
12 S DIC="^DG(43,",DA=VAR1,DIQ="VARA",DIQ(0)="I",DR="391.702;"
13 D EN^DIQ1
14 ;use 547 days (18 months) unless otherwise specified
15 S DAYS=VARA(43,VAR1,391.702,"I") S:+DAYS=0 DAYS=547
16 D DT^DICRW
17 S X1=DT
18 S X2=-DAYS
19 D C^%DTC
20 S (Y,VAFHEDT)=X
21 D DD^%DT
22 W:'$D(ZTQUEUED) !!,"All ADT/HL7 PIVOT entries older than ",Y," will be deleted!",!
23 D KIL1
24 ;iofo-bay pines;vmp;teh; modification to quit logical to prevent null subscript.
25 F VAFHX=0:0 S VAFHX=$O(^VAT(391.71,"B",VAFHX)) Q:VAFHX>VAFHEDT!(VAFHX="") D DELETE
26 D EXIT
27 ;D CLEAN
28 ;D EXIT
29 Q
30 ;
31DELETE ;this will do that actual deletion.
32 ;
33 N DA,DIK,EVENT,MOVE,OUT
34 S DA=0
35 F S DA=+$O(^VAT(391.71,"B",VAFHX,DA)) Q:('DA) D
36 .;DG*604 - skip if no zero node
37 .I '$D(^VAT(391.71,DA,0)) Q
38 .;don't delete inpatient event records before discharge
39 .S EVENT=+$P(^VAT(391.71,DA,0),U,4)
40 .I EVENT=1 D Q:OUT
41 ..S OUT=0
42 ..S MOVE=$P(^VAT(391.71,DA,0),U,5)
43 ..Q:MOVE'["DGPM"
44 ..I $P($G(^DGPM(+MOVE,0)),U,17)="" S OUT=1
45 .;don't delete if requires transmission
46 .Q:$D(^VAT(391.71,"AXMIT",EVENT,DA))
47 .;delete
48 .S DIK="^VAT(391.71,"
49 .D ^DIK
50 .W:'$D(ZTQUEUED) "."
51 Q
52 ;
53EXIT ;kills variables
54 K VAFHX,VAFHEDT,X,Y
55 Q
56 ;
57KIL1 K X,Y,%DT
58 Q
59 ;
60CLEAN ; delete entries with invalid event pointer, ie doesn't exist
61 ; CLEAN^VAFHPURG may be run directly from programmer mode
62 ;
63 I '$D(ZTQUEUED) W !!,"All ADT/HL7 PIVOT entries with invalid EVENT POINTERS will be deleted",!
64 D DT^DICRW
65 N EVENTVP,GLOBAL,GLOBALR,NODE
66 S VAFHX=0
67 F S VAFHX=$O(^VAT(391.71,VAFHX)) Q:'VAFHX S NODE=$G(^(VAFHX,0)) DO
68 .; if no .01 date/time
69 . I 'NODE D REMOVE Q
70 . S EVENTVP=$P(NODE,"^",5)
71 .; if event pointer has no pointer
72 . I 'EVENTVP D REMOVE Q
73 . S GLOBAL=$P(EVENTVP,";",2)
74 .; if event pointer has no variable
75 . I GLOBAL="" D REMOVE Q
76 .; if variable not distributed
77 . I "DPT(DGPM(SCE("'[GLOBAL D REMOVE Q
78 . S GLOBALR="^"_GLOBAL_+EVENTVP_")"
79 .;
80 . I $D(@GLOBALR) Q
81 .; if no pointed to eentr delete this oney
82 . D REMOVE Q
83 Q
84 ;
85 ;either the pointed to entry doesn't exist or the VP entry is invalid
86 ;so delete it
87REMOVE S DA=VAFHX
88 S DIK="^VAT(391.71,"
89 D ^DIK
90 I '$D(ZTQUEUED) W ","
91 K DIK,DA
92 Q
Note: See TracBrowser for help on using the repository browser.