Routine: XDRDPRGE

XDRDPRGE ;SF-IRMFO/IHS/OHPRD/JCM - PURGE DUPLICATE RECORD FILE; ;8/28/08  18:20

 ;;7.3;TOOLKIT;**23,42,113**;Apr 25, 1995;Build 5

 ;;Per VHA Directive 2004-038, this routine should not be modified.

;;

START ;

 D INIT G:XDRQFLG END

 D ASK G:XDRQFLG END

DQ ; Entry point for Tasked job

 I XDRDPRGE("CHOICE")="BOTH" D BOTH I 1

 E  D XREF

END D EOJ

INIT ;

 S XDRQFLG=0

 D FILE

 G:XDRQFLG INITX

 S XDRGL=^DIC(XDRFL,0,"GL")

INITX Q

FILE ;

 W !,"* This option is not available for PATIENTS" ; (new with XT*7.3*113)

 S DIC("S")="I Y'=2"

 S DIC(0)="QEAZ"

 S DIC("A")="Select File to Be Checked to purge: "

 S DIC="^VA(15.1," D ^DIC K DIC,X

 I Y=-1 S XDRQFLG=1 G FILEX

 S XDRFL=$P(Y(0),U) K Y

FILEX Q

ASK ;

 S DIR(0)="S^1:POTENTIAL DUPLICATES PURGE;2:VERIFIED NOT DUPLICATES PURGE;3:ALL RECORDS EXCEPT VERIFIED DUPLICATES PURGE"

 S DIR("A")="Choice "

 S DIR("?",1)="Enter a 1 if you wish to purge only the potential non-verified duplicates"

 S DIR("?",2)="Enter a 2 if you wish to purge only Verified Non-Duplicates"

 S DIR("?",3)="Enter a 3 if you wish to purge everything except verifed duplicates"

 D ^DIR K DIR

 I $D(DIRUT) S XDRQFLG=1 G ASKX

 S (XDRDPRGE("XREF"),XDRDPRGE("CHOICE"))=$S(Y=1:"APOT",Y=2:"ANOT",1:"BOTH") K Y

 S DIR(0)="Y"

 S DIR("A")="Do you wish to Queue this purging (Y/N)"

 D ^DIR K DIR

 I $D(DIRUT) S XDRQFLG=1 G ASKX

 I Y D QUEUE

ASKX K Y

QUEUE ;

 S ZTRTN="DQ^XDRDPRGE",ZTIO="",ZTDESC="Duplicate Record Purge"

 F %="XDRFL","XDRGL","XDRDPRGE(" S ZTSAVE(%)=""

 D ^%ZTLOAD K ZTSK

 S XDRQFLG=1

BOTH ;

 S XDRDPRGE("XREF")="APOT" D XREF

 S XDRDPRGE("XREF")="ANOT" D XREF

XREF ;

 G:'$D(^VA(15,XDRDPRGE("XREF"))) XREFX

 S XDRDPRGE("GL")="^VA(15,"_""""_XDRDPRGE("XREF")_""""_","_""""_$P(XDRGL,U,2)_""""_","

 S XDRDPRGE("RCDS")=0,DIK="^VA(15," F XDRDI1=0:0 S XDRDPRGE("RCDS")=$O(@(XDRDPRGE("GL")_"XDRDPRGE(""RCDS""))")) Q:XDRDPRGE("RCDS")=""  S DA=$O(@(XDRDPRGE("GL")_"XDRDPRGE(""RCDS""),0)")) D ^DIK

XREFX K XDRDI1,DIK,DA,XDRDPRGE("GL")

EOJ ;

 K XDRFL,XDRGL,XDRDPRGE

 S:$D(ZTQUEUED) ZTREQ="@"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDPRGE   2108     printed  Apr 23, 2025@18:53:43                                                                                                                                                                                                    Page 2

XDRDPRGE  ;SF-IRMFO/IHS/OHPRD/JCM - PURGE DUPLICATE RECORD FILE; ;8/28/08  18:20

 +1       ;;7.3;TOOLKIT;**23,42,113**;Apr 25, 1995;Build 5

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;;

START     ;

 +1        DO INIT

           if XDRQFLG

               GOTO END

 +2        DO ASK

           if XDRQFLG

               GOTO END

DQ        ; Entry point for Tasked job

 +1        IF XDRDPRGE("CHOICE")="BOTH"

               DO BOTH

               IF 1

 +2       IF '$TEST

               DO XREF

END        DO EOJ

 +1        QUIT

 +2       ;

INIT      ;

 +1        SET XDRQFLG=0

 +2        DO FILE

 +3        if XDRQFLG

               GOTO INITX

 +4        SET XDRGL=^DIC(XDRFL,0,"GL")

INITX      QUIT

 +1       ;

FILE      ;

 +1       ; (new with XT*7.3*113)

           WRITE !,"* This option is not available for PATIENTS"

 +2        SET DIC("S")="I Y'=2"

 +3        SET DIC(0)="QEAZ"

 +4        SET DIC("A")="Select File to Be Checked to purge: "

 +5        SET DIC="^VA(15.1,"

           DO ^DIC

           KILL DIC,X

 +6        IF Y=-1

               SET XDRQFLG=1

               GOTO FILEX

 +7        SET XDRFL=$PIECE(Y(0),U)

           KILL Y

FILEX      QUIT

 +1       ;

ASK       ;

 +1        SET DIR(0)="S^1:POTENTIAL DUPLICATES PURGE;2:VERIFIED NOT DUPLICATES PURGE;3:ALL RECORDS EXCEPT VERIFIED DUPLICATES PURGE"

 +2        SET DIR("A")="Choice "

 +3        SET DIR("?",1)="Enter a 1 if you wish to purge only the potential non-verified duplicates"

 +4        SET DIR("?",2)="Enter a 2 if you wish to purge only Verified Non-Duplicates"

 +5        SET DIR("?",3)="Enter a 3 if you wish to purge everything except verifed duplicates"

 +6        DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               SET XDRQFLG=1

               GOTO ASKX

 +8        SET (XDRDPRGE("XREF"),XDRDPRGE("CHOICE"))=$SELECT(Y=1:"APOT",Y=2:"ANOT",1:"BOTH")

           KILL Y

 +9        SET DIR(0)="Y"

 +10       SET DIR("A")="Do you wish to Queue this purging (Y/N)"

 +11       DO ^DIR

           KILL DIR

 +12       IF $DATA(DIRUT)

               SET XDRQFLG=1

               GOTO ASKX

 +13       IF Y

               DO QUEUE

ASKX       KILL Y

 +1        QUIT

 +2       ;

QUEUE     ;

 +1        SET ZTRTN="DQ^XDRDPRGE"

           SET ZTIO=""

           SET ZTDESC="Duplicate Record Purge"

 +2        FOR %="XDRFL","XDRGL","XDRDPRGE("

               SET ZTSAVE(%)=""

 +3        DO ^%ZTLOAD

           KILL ZTSK

 +4        SET XDRQFLG=1

 +5        QUIT

 +6       ;

BOTH      ;

 +1        SET XDRDPRGE("XREF")="APOT"

           DO XREF

 +2        SET XDRDPRGE("XREF")="ANOT"

           DO XREF

 +3        QUIT

 +4       ;

XREF      ;

 +1        if '$DATA(^VA(15,XDRDPRGE("XREF")))

               GOTO XREFX

 +2        SET XDRDPRGE("GL")="^VA(15,"_""""_XDRDPRGE("XREF")_""""_","_""""_$PIECE(XDRGL,U,2)_""""_","

 +3        SET XDRDPRGE("RCDS")=0

           SET DIK="^VA(15,"

           FOR XDRDI1=0:0

               SET XDRDPRGE("RCDS")=$ORDER(@(XDRDPRGE("GL")_"XDRDPRGE(""RCDS""))"))

               if XDRDPRGE("RCDS")=""

                   QUIT

               SET DA=$ORDER(@(XDRDPRGE("GL")_"XDRDPRGE(""RCDS""),0)"))

               DO ^DIK

XREFX      KILL XDRDI1,DIK,DA,XDRDPRGE("GL")

 +1        QUIT

 +2       ;

EOJ       ;

 +1        KILL XDRFL,XDRGL,XDRDPRGE

 +2        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        QUIT

XDRDPRGE.m