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
Q
;
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
Q
;
QUEUE ;
S ZTRTN="DQ^XDRDPRGE",ZTIO="",ZTDESC="Duplicate Record Purge"
F %="XDRFL","XDRGL","XDRDPRGE(" S ZTSAVE(%)=""
D ^%ZTLOAD K ZTSK
S XDRQFLG=1
Q
;
BOTH ;
S XDRDPRGE("XREF")="APOT" D XREF
S XDRDPRGE("XREF")="ANOT" D XREF
Q
;
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")
Q
;
EOJ ;
K XDRFL,XDRGL,XDRDPRGE
S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDPRGE 2108 printed Apr 09, 2024@21:43:28 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
