XDRDFPD ;IHS/OHPRD/LAB - find all potential duplicates for an entry in a file ;6/9/08 11:26
;;7.3;TOOLKIT;**113**;Apr 25, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
START ;
INIT ;Initialization
W !,"This option will collect all Potential Duplicates for an entry in a file.",!,"It will then add any pairs found to the Duplicate Record file.",!
D PROCESS
G:XDRQFLG END
D INFORM
END D EOJ
Q
PROCESS ;
K XDRD
; Flag XDRNOPT makes FILE^XDRDQUE not allow selection of PATIENT file - XT*7.3*113
N XDRNOPT S XDRNOPT=1
S XDRQFLG=0,XDRDTYPE="b"
S DIC("A")="Find Potential Duplicates for entry in what file: " D FILE^XDRDQUE
G:XDRQFLG PROCESSX
D SETUP
S XDRGL=^DIC(XDRFL,0,"GL")
I '$D(XDRCD) D LKUP Q:XDRQFLG
W:'$D(ZTQUEUED) !!,"Hold On... This may take a little while...",!
;
D POSDUPS^XDRDMAIN
D:$D(^TMP("XDRD",$J,XDRFL)) CHECK
PROCESSX Q
EOJ ;clean up
K XDRQFLG,XDRD,XDRDSCOR,XDRDTEST,XDRFL,XDRGL,XDRCD,XDRCD2,XDRDCNT,XDRDMAIN,XDRDTYPE,XDRDUP,XDRDFPD
K ^TMP("XDRD",$J)
Q
EN ;Entry Point (caller must pass XDRCD,XDRFL)
I '$D(XDRCD) S XDRERR=15 D ^XDREMSG G ENX
I '$D(XDRFL) S XDRERR=14 D ^XDREMSG G ENX
I '$D(^VA(15.1,XDRFL,0)) S XDRERR=6 D ^XDREMSG G ENX
D PROCESS
ENX ;
K XDRDFPD,XDRDSCOR,XDRD,XDRDTEST,XDRGL,XDRCD2,XDRDCNT,XDRDMAIN,XDRDTYPE,XDRDUP
Q
LKUP ;
S DIC=XDRGL,DIC(0)="AEMQ",DIC("A")="Find Potential Duplicates for "_$P(^DIC(XDRFL,0),U)_": "
D ^DIC K DIC,DA
I Y=-1 S XDRQFLG=1 G LKUPX
S XDRCD=+Y
LKUPX ;
Q
SETUP ;
S XDRD("COLLECTION ROUTINE")=$S($P($P(XDRD(0),U,9),"-",2)]"":$P($P(XDRD(0),U,9),"-")_"^"_$P($P(XDRD(0),U,9),"-",2),1:U_$P(XDRD(0),U,9))
I '$D(XDRD("DMAILGRP")),$D(XDRD(0)),$P(XDRD(0),U,11),$D(^XMB(3.8,$P(XDRD(0),U,11),1,"B")) F XDRI=0:0 S XDRI=$O(^XMB(3.8,$P(XDRD(0),U,11),1,"B",XDRI)) Q:'XDRI S XDRD("DMAILGRP",XDRI)=""
K XDRI
D ^XDRDSCOR ; Sets up Duplicate Test Scores
SETUPX ;
Q
CHECK ;check for duplicates and add to Duplicate record file
F XDRCD2=0:0 S XDRCD2=$O(^TMP("XDRD",$J,XDRFL,XDRCD2)) Q:'XDRCD2!(XDRQFLG) D CHECK^XDRDMAIN
Q
INFORM ;
S XDRDFPD("PAIR")="",%=0 F S XDRDFPD("PAIR")=$O(^VA(15,"APOT",$P(XDRGL,"^",2),XDRDFPD("PAIR"))) Q:XDRDFPD("PAIR")="" D
.I $P(XDRDFPD("PAIR"),U)=XDRCD!($P(XDRDFPD("PAIR"),U,2)=XDRCD) S %=%+1,XDRDFPD("FOUND",%)=XDRDFPD("PAIR")
.Q
I '$D(XDRDFPD("FOUND")) W !!,"NO Potential Duplicates were found for ",$P(^DIC(XDRFL,0),U),": ",$P(@(XDRGL_XDRCD_",0)"),U) Q
W !!,"The following ",$P(^DIC(XDRFL,0),U)," entry(ies) are now in the Duplicate ",!,"Record file as Potential Duplicates to ",!,$P(^DIC(XDRFL,0),U),": ",$P(@(XDRGL_XDRCD_",0)"),U)
S X="" F S X=$O(XDRDFPD("FOUND",X)) Q:X="" D
.W !?20,$S($P(XDRDFPD("FOUND",X),U)=XDRCD:$P(@(XDRGL_$P(XDRDFPD("FOUND",X),U,2)_",0)"),U),1:$P(@(XDRGL_$P(XDRDFPD("FOUND",X),U)_",0)"),U))
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDFPD 2849 printed Oct 16, 2024@18:39:39 Page 2
XDRDFPD ;IHS/OHPRD/LAB - find all potential duplicates for an entry in a file ;6/9/08 11:26
+1 ;;7.3;TOOLKIT;**113**;Apr 25, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
START ;
INIT ;Initialization
+1 WRITE !,"This option will collect all Potential Duplicates for an entry in a file.",!,"It will then add any pairs found to the Duplicate Record file.",!
+2 DO PROCESS
+3 if XDRQFLG
GOTO END
+4 DO INFORM
END DO EOJ
+1 QUIT
PROCESS ;
+1 KILL XDRD
+2 ; Flag XDRNOPT makes FILE^XDRDQUE not allow selection of PATIENT file - XT*7.3*113
+3 NEW XDRNOPT
SET XDRNOPT=1
+4 SET XDRQFLG=0
SET XDRDTYPE="b"
+5 SET DIC("A")="Find Potential Duplicates for entry in what file: "
DO FILE^XDRDQUE
+6 if XDRQFLG
GOTO PROCESSX
+7 DO SETUP
+8 SET XDRGL=^DIC(XDRFL,0,"GL")
+9 IF '$DATA(XDRCD)
DO LKUP
if XDRQFLG
QUIT
+10 if '$DATA(ZTQUEUED)
WRITE !!,"Hold On... This may take a little while...",!
+11 ;
+12 DO POSDUPS^XDRDMAIN
+13 if $DATA(^TMP("XDRD",$JOB,XDRFL))
DO CHECK
PROCESSX QUIT
EOJ ;clean up
+1 KILL XDRQFLG,XDRD,XDRDSCOR,XDRDTEST,XDRFL,XDRGL,XDRCD,XDRCD2,XDRDCNT,XDRDMAIN,XDRDTYPE,XDRDUP,XDRDFPD
+2 KILL ^TMP("XDRD",$JOB)
+3 QUIT
EN ;Entry Point (caller must pass XDRCD,XDRFL)
+1 IF '$DATA(XDRCD)
SET XDRERR=15
DO ^XDREMSG
GOTO ENX
+2 IF '$DATA(XDRFL)
SET XDRERR=14
DO ^XDREMSG
GOTO ENX
+3 IF '$DATA(^VA(15.1,XDRFL,0))
SET XDRERR=6
DO ^XDREMSG
GOTO ENX
+4 DO PROCESS
ENX ;
+1 KILL XDRDFPD,XDRDSCOR,XDRD,XDRDTEST,XDRGL,XDRCD2,XDRDCNT,XDRDMAIN,XDRDTYPE,XDRDUP
+2 QUIT
LKUP ;
+1 SET DIC=XDRGL
SET DIC(0)="AEMQ"
SET DIC("A")="Find Potential Duplicates for "_$PIECE(^DIC(XDRFL,0),U)_": "
+2 DO ^DIC
KILL DIC,DA
+3 IF Y=-1
SET XDRQFLG=1
GOTO LKUPX
+4 SET XDRCD=+Y
LKUPX ;
+1 QUIT
SETUP ;
+1 SET XDRD("COLLECTION ROUTINE")=$SELECT($PIECE($PIECE(XDRD(0),U,9),"-",2)]"":$PIECE($PIECE(XDRD(0),U,9),"-")_"^"_$PIECE($PIECE(XDRD(0),U,9),"-",2),1:U_$PIECE(XDRD(0),U,9))
+2 IF '$DATA(XDRD("DMAILGRP"))
IF $DATA(XDRD(0))
IF $PIECE(XDRD(0),U,11)
IF $DATA(^XMB(3.8,$PIECE(XDRD(0),U,11),1,"B"))
FOR XDRI=0:0
SET XDRI=$ORDER(^XMB(3.8,$PIECE(XDRD(0),U,11),1,"B",XDRI))
if 'XDRI
QUIT
SET XDRD("DMAILGRP",XDRI)=""
+3 KILL XDRI
+4 ; Sets up Duplicate Test Scores
DO ^XDRDSCOR
SETUPX ;
+1 QUIT
CHECK ;check for duplicates and add to Duplicate record file
+1 FOR XDRCD2=0:0
SET XDRCD2=$ORDER(^TMP("XDRD",$JOB,XDRFL,XDRCD2))
if 'XDRCD2!(XDRQFLG)
QUIT
DO CHECK^XDRDMAIN
+2 QUIT
INFORM ;
+1 SET XDRDFPD("PAIR")=""
SET %=0
FOR
SET XDRDFPD("PAIR")=$ORDER(^VA(15,"APOT",$PIECE(XDRGL,"^",2),XDRDFPD("PAIR")))
if XDRDFPD("PAIR")=""
QUIT
Begin DoDot:1
+2 IF $PIECE(XDRDFPD("PAIR"),U)=XDRCD!($PIECE(XDRDFPD("PAIR"),U,2)=XDRCD)
SET %=%+1
SET XDRDFPD("FOUND",%)=XDRDFPD("PAIR")
+3 QUIT
End DoDot:1
+4 IF '$DATA(XDRDFPD("FOUND"))
WRITE !!,"NO Potential Duplicates were found for ",$PIECE(^DIC(XDRFL,0),U),": ",$PIECE(@(XDRGL_XDRCD_",0)"),U)
QUIT
+5 WRITE !!,"The following ",$PIECE(^DIC(XDRFL,0),U)," entry(ies) are now in the Duplicate ",!,"Record file as Potential Duplicates to ",!,$PIECE(^DIC(XDRFL,0),U),": ",$PIECE(@(XDRGL_XDRCD_",0)"),U)
+6 SET X=""
FOR
SET X=$ORDER(XDRDFPD("FOUND",X))
if X=""
QUIT
Begin DoDot:1
+7 WRITE !?20,$SELECT($PIECE(XDRDFPD("FOUND",X),U)=XDRCD:$PIECE(@(XDRGL_$PIECE(XDRDFPD("FOUND",X),U,2)_",0)"),U),1:$PIECE(@(XDRGL_$PIECE(XDRDFPD("FOUND",X),U)_",0)"),U))
+8 QUIT
End DoDot:1
+9 QUIT
