| 1 | VAFHPURG ;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 | ;
|
|---|
| 8 | EN ;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 | ;
|
|---|
| 31 | DELETE ;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 | ;
|
|---|
| 53 | EXIT ;kills variables
|
|---|
| 54 | K VAFHX,VAFHEDT,X,Y
|
|---|
| 55 | Q
|
|---|
| 56 | ;
|
|---|
| 57 | KIL1 K X,Y,%DT
|
|---|
| 58 | Q
|
|---|
| 59 | ;
|
|---|
| 60 | CLEAN ; 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
|
|---|
| 87 | REMOVE S DA=VAFHX
|
|---|
| 88 | S DIK="^VAT(391.71,"
|
|---|
| 89 | D ^DIK
|
|---|
| 90 | I '$D(ZTQUEUED) W ","
|
|---|
| 91 | K DIK,DA
|
|---|
| 92 | Q
|
|---|
