XDRDFPD.m

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 9

 ;;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

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 9

 +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