VAFHPURG.m

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

 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---VAFHPURG   2623     printed  Feb 19, 2025@00:29:50                                                                                                                                                                                                    Page 2

VAFHPURG  ;ALB/JLU;Purging routine. ; 8/9/04 11:00am

 +1       ;;5.3;Registration;**91,219,530,604**;Jun 06, 1996

 +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