XDRRMRG1.m

XDRRMRG1 ;SF-IRMFO.SEA/JLI - DUP VERIFICATION FOR ANCILLARY SERVICES ;10/21/2010

 ;;7.3;TOOLKIT;**23,29,46,47,49,126**;Apr 25, 1995;Build 2

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

 ;

EN ;

 I '$D(XQADATA) Q

 N OVERWRIT,XDRDA,DFNFR,DFNTO,DFNFRX,DFNTOX,REVIEW,XDRGL,PRIFILE ; MODIFIED 03/28/00

 S REVIEW=0

 S XDRGL=$P($P($G(^VA(15,+XQADATA,0)),U),";",2) Q:XDRGL=""  S XDRGL=U_XDRGL S PRIFILE=+$P(@(XDRGL_"0)"),U,2) ; MODIFIED 03/28/00

 S XDRDA=$P(XQADATA,U)

 S DFNFR=$P(XQADATA,U,2)

 S (DFNTOX,DFNTO)=$P(DFNFR,";",2)

 S (DFNFRX,DFNFR)=$P(DFNFR,";")

 S PACKAGE=$P(XQADATA,U,3)

 S SUBFILES=$P(XQADATA,U,5)

 S SUBNAMES=$P(XQADATA,U,6)

 S XDRFILE=$P(XQADATA,U,4)

 S FILEDIC=^DIC(XDRFILE,0,"GL")_"DFN)"

 I XDRGL="^DPT(" D

 . S DFN=DFNFR D ^VADPT M DFNFR=VADM K VA,VADM

 . S DFN=DFNTO D ^VADPT M DFNTO=VADM K VA,VADM

 I XDRFILE=63 D

 . S DFNFR=$G(^DPT(DFNFR,"LR"))

 . S DFNTO=$G(^DPT(DFNTO,"LR"))

 I DFNFR'>0!(DFNTO'>0) W !,$C(7),"NO DATA TO REVIEW....",!! Q

LDATE F XDRI=1,2 S DFN=$S(XDRI=1:DFNFR,1:DFNTO) S DFNNAM=$S(XDRI=1:"DFNFR",1:"DFNTO") D

 . S I=5 F  S I=$O(@DFNNAM@(I)) Q:I=""  K @DFNNAM@(I)

 . F ISUBS=1:1 S SUBSCR=$P(SUBFILES,";",ISUBS) Q:SUBSCR=""  D

 . . S XX=$G(^DD(XDRFILE,SUBSCR,0))

 . . I $P(XX,U,2)'["D" Q

 . . I $P($P(XX,U,4),";",2)'=0 Q

 . . S SUBSCR=$P($P(XX,U,4),";")

 . . N XDAT1 S XDAT1=0

 . . I DFN>0 F I=0:0 S I=$O(@FILEDIC@(SUBSCR,I)) Q:I'>0  D

 . . . S X=$P($G(@FILEDIC@(SUBSCR,I,0)),U)

 . . . I X<DT,X>XDAT1 S XDAT1=X

 . . S LASTNAM="LAST "_$P(SUBNAMES,";",ISUBS)

 . . S @DFNNAM@(LASTNAM)=""

 . . I XDAT1>0 S @DFNNAM@(LASTNAM)=$$FMTE^XLFDT(XDAT1\1)

 . I @DFNNAM'="",'$D(@FILEDIC) S @DFNNAM=""

 D SHOW

 S:XDRFILE'=63 DFNFR=DFNFRX,DFNTO=DFNTOX ;REM - LAB is handled differently

 I IOST'["C-" Q

 D CHK

 Q

 ;

SHOW ;

 N NAMIEN1,NAMIEN2

 S N1=$$COUNT^XDRRMRG2(XDRFILE,DFNFRX,DFNTOX)

 W @IOF I N1>0,PACKAGE="PRIMARY" W !,"         RECORD"_N1_" contains fewer data elements, usually this would indicate",!,"                 that this record would be merged INTO the other."

 ;S LABEL(1)="NAME",LABEL(2)="SSN",LABEL(3)="BIRTH DATE"

 ;S LABEL(4)="AGE",LABEL(5)="SEX",LABEL("LASTDAT")="LAST DATE"

 W !!,"Determine if these entries ARE or ARE NOT duplicates."

 W !

 ;REM - Modified next three lines to include IENs by patient name.

 I XDRFILE=63 S NAMIEN1=$$LABIEN^XDRRMRG2(XDRFILE,DFNFR),NAMIEN2=$$LABIEN^XDRRMRG2(XDRFILE,DFNTO)

 ;W !,?20,$S(PACKAGE="PRIMARY":"RECORD1 [#"_DFNFR_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_DFNFR_"]")

 ;W ?45,$S(PACKAGE="PRIMARY":"RECORD2 [#"_DFNTO_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_DFNTO_"]")

 ;S I="" F  S I=$O(DFNFR(I)) Q:I=""  D

 ;. I DFNFR(I)=""&(DFNTO(I)="") Q

 ;. S DFNFR(I)=$S($P(DFNFR(I),U,2)'="":$P(DFNFR(I),U,2),1:$P(DFNFR(I),U))

 ;. S DFNTO(I)=$S($P(DFNTO(I),U,2)'="":$P(DFNTO(I),U,2),1:$P(DFNTO(I),U))

 ;. W !,$S($D(LABEL(I)):LABEL(I),1:I),?20,$E(DFNFR(I),1,20),?45,$E(DFNTO(I),1,20)

 ;. I I=1!(I=5) W !

 ;I DFNFR=""!(DFNTO="") D

 ;. I DFNFR=""&(DFNTO="") W !!,"There is NO DATA in the "_PACKAGE_" file for either entry." Q

 ;. I DFNFR="" W !!,"There is NO DATA in the "_PACKAGE_" file for (",DFNFRX,")  ",DFNFR(1),"   ",DFNFR(2)

 ;. I DFNTO="" W !!,"There is NO DATA in the "_PACKAGE_" file for (",DFNTOX,")  ",DFNTO(1),"   ",DFNTO(2)

 ;S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)

 ;I DFNFR=""!(DFNTO="") Q

 ;S DIT(1)=DFNFR,DIT(2)=DFNTO,IOP=IO(0),DFF=XDRFILE,DIC=XDRFILE

 D SHOW^XDRDSHOW(XDRFILE,DFNFR,DFNTO,.OVERWRIT,REVIEW) ;D EN^DITC K IOP

 Q

 ;

CHK ;

 N DIR

CHK1 K DIR

 S DIR(0)="S^V:VERIFIED DUPLICATE;N:VERIFIED, NOT A DUPLICATE;U:UNABLE TO DETERMINE;H:HEALTH SUMMARY;R:REVIEW DATA AGAIN;S:SELECT/REVIEW OVERWRITES",DIR("A")="Select Action",DIR("B")="HEALTH SUMMARY"

 D ^DIR K DIR S XDRY=Y I $D(DIRUT) K XQAKILL Q

 I XDRY="R" S REVIEW=0 D SHOW G CHK1

 I XDRY="S" S REVIEW=1 D SHOW G CHK1

 I XDRY'="H" D  Q

 . K XQAKILL

 . I XDRY'="^" D

 . . S XQAKILL=$S(XDRY'="U":0,1:1)

 . . S XDRDIR=""

 . . I XDRY="V" D VERWARN ;p126-REM

 . . I XDRY="V",PACKAGE="PRIMARY" D

 . . . S DIR=0 F DFN=DFNFRX,DFNTOX I $D(@FILEDIC) S DIR=DIR+1

 . . . I DIR'>1 K DIR Q  ; DON'T NEED TO SELECT DIRECTION UNLESS DATA IN BOTH ENTRIES

 . . . S DIR("B")=$$COUNT^XDRRMRG2(XDRFILE,DFNFRX,DFNTOX)

 . . . S DIR("B")=$S(DIR("B")'>1:"RECORD1 INTO RECORD2",1:"RECORD2 INTO RECORD1")

 . . . I DIR("B")=0 K DIR("B")

 . . . S DIR(0)="S^1:RECORD1 INTO RECORD2;2:RECORD2 INTO RECORD1"

 . . . W !!!,?20,"RECORD1 [#"_DFNFR_"]",?45,"RECORD2 [#"_DFNTO_"]"

 . . . W !,?20,DFNFR(1),?45,DFNTO(1)

 . . . S DIR("A")="Which record (1 or 2) should be MERGED INTO the other record"

 . . . D ^DIR K DIR I Y>0 S XDRDIR=+Y

 . . . I $D(DIRUT) S XDRY="^" W !!!,$C(7),"VERIFICATION ABORTED!",! Q

 . . . I DFNFRX'=+^VA(15,XDRDA,0) S XDRDIR=$S(XDRDIR'>0:2,XDRDIR=1:2,1:1)

 . . N XDRFDA,XDRDA1

 . . S XDRDA1=$$FIND1^DIC(15.02,","_XDRDA_",","X",PACKAGE)

 . . S XDRDA1=$S(XDRDA1>0:XDRDA1_",",1:"+1,")_XDRDA_","

 . . S XDRFDA(15.02,XDRDA1,.01)=PACKAGE

 . . S XDRFDA(15.02,XDRDA1,.02)=XDRY

 . . S XDRFDA(15.02,XDRDA1,.03)=DUZ

 . . S XDRFDA(15.02,XDRDA1,.04)=$$NOW^XLFDT()

 . . I XDRDIR'="" S XDRFDA(15.02,XDRDA1,.05)=XDRDIR

 . . D UPDATE^DIE("S","XDRFDA")

 . . ;

 . . I $D(OVERWRIT)!(XDRDIR=2&(PACKAGE'="PRIMARY")) D

 . . . N I

 . . . S XDRDA1=$$FIND1^DIC(15.03,","_XDRDA_",","X",XDRFILE)

 . . . I XDRDA1'>0 D

 . . . . S XDRDA1="+1,"_XDRDA_","

 . . . . K XDRFDA,XDRDAX

 . . . . S XDRDAX(1)=XDRFILE

 . . . . S XDRFDA(15.03,XDRDA1,.01)=XDRFILE

 . . . . I XDRDIR=2,PACKAGE'="PRIMARY" D

 . . . . . S XDRFDA(15.03,XDRDA1,.02)=2

 . . . . D UPDATE^DIE("S","XDRFDA","XDRDAX")

 . . . . S XDRDA1=XDRDAX(1)

 . . . S XDRDA1="+1,"_XDRDA1_","_XDRDA_","

 . . . F I=0:0 S I=$O(OVERWRIT(I)) Q:I'>0  D

 . . . . K XDRFDA,XDRDAX

 . . . . S XDRDAX(1)=I

 . . . . S XDRFDA(15.031,XDRDA1,.01)=I

 . . . . D UPDATE^DIE("S","XDRFDA","XDRDAX")

 . I XDRY="V" D

 . . D CHEKVER

 . I XDRY="N" D

 . . S XDRAID=$G(XQAID) N XQAID,I

 . . F I=0:0 S I=$O(^VA(15.1,PRIFILE,2,I)) Q:I'>0  D  ; MODIFIED 03/28/00

 . . . S XQAID=$P(XDRAID,",",1,2)_","_I

 . . . S XQAKILL=0

 . . . D DELETEA^XQALERT

 . . N XDRFDA

 . . S XDRFDA(15,XDRDA_",",.03)="N"

 . . S XDRFDA(15,XDRDA_",",.07)=$$NOW^XLFDT()

 . . S XDRFDA(15,XDRDA_",",.11)=DUZ

 . . D UPDATE^DIE("S","XDRFDA")

 S ABORT=0 D ASK^XDRRMRG2(.QLIST,.ABORT) ;REM -Reset ABORT to 0

 ;

 ;For health summary, user has the option of using the Browser to view 

 ;both records or use may select any other device for each record.

 ;

 I '$G(ABORT) D PRINT2^XDRRMRG2

 D HOME^%ZIS

 G CHK1

 Q

 ;

CHEKVER ;

 N R

 S XVER=1

 F I=0:0 S I=$O(^VA(15.1,PRIFILE,2,I)) Q:I'>0  D  Q:'XVER  ; MODIFIED 03/28/00

 . S X1=+$P(^VA(15.1,PRIFILE,2,I,0),U,2) ; MODIFIED 03/28/00

 . S XN=$P(^VA(15.1,PRIFILE,2,I,0),U) ; MODIFIED 03/28/00

 . I X1>0 D

 . . F R=1,5,6,7,0 I $O(^XMB(3.8,X1,R,0))>0 Q  ;REM -changed I to R in FOR loop 

 . . I R'>0 S X1=0

 . I X1'>0,$O(^VA(15.1,PRIFILE,2,I,1,0))'>0 Q  ; MODIFIED 03/28/00

 . S X1=$$FIND1^DIC(15.02,","_XDRDA_",","X",XN)

 . S XVER=$S(X1'>0:0,$P(^VA(15,XDRDA,2,X1,0),U,2)="V":1,$P(^(0),U,2)="D":1,1:0)

 I XVER D FINALVER^XDRVCHEK(XDRDA)

 Q

 ;

SETUP(XDRDA) ;

 N XDRGRPN,XDRSSN,XDRFILE

 S X=^VA(15,XDRDA,0)

 I $P($G(^VA(15,XDRDA,2,1,0)),U,5)=2 S DFNTO=+X,DFNFR=+$P(X,U,2)

 E  S DFNFR=+X,DFNTO=+$P(X,U,2)

 S XDRFILE=$P($P(X,U),";",2),XDRFILE=+$P(@(U_XDRFILE_"0)"),U,2)

 F XDRAID=0:0 S XDRAID=$O(^VA(15.1,PRIFILE,2,XDRAID)) Q:XDRAID'>0  D  ; MODIFIED 03/28/00

 . S XDRNODE=^VA(15.1,PRIFILE,2,XDRAID,0) ; MODIFIED 03/28/00

 . S XDRNOD2=$G(^VA(15.1,PRIFILE,2,XDRAID,2)) ; MODIFIED 03/28/00

 . S XDRNAME=$P(XDRNODE,U)

 . S XDRGRP=$P(XDRNODE,U,2)

 . S:XDRGRP>0 XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01) ;REM -8/2/96 Get the name of mail group

 . S XDRGRP=$S(XDRGRP>0:"G."_XDRGRPN,1:"")

 . S XDRFILE=$P(XDRNODE,U,3) D  Q:'$D(XDRNODE)

 . . N XDRDIC,XDRFR,XDRTO

 . . S XDRDIC=^DIC(XDRFILE,0,"GL")

 . . S XDRFR=$S(XDRFILE'=63:DFNFR,1:$G(^DPT(DFNFR,"LR")))

 . . S XDRTO=$S(XDRFILE'=63:DFNTO,1:$G(^DPT(DFNTO,"LR")))

 . . I XDRFR'>0!(XDRTO'>0) K XDRNODE

 . . I $D(XDRNODE),'$D(@(XDRDIC_XDRFR_",0)"))!'$D(@(XDRDIC_XDRTO_",0)")) K XDRNODE

 . . I '$D(XDRNODE) D

 . . . N XDRARR I $$FIND1^DIC(15.02,","_XDRDA_",","X",XDRNAME)>0 Q

 . . . S XDRARR(15.02,"+1,"_XDRDA_",",.01)=XDRNAME

 . . . S XDRARR(15.02,"+1,"_XDRDA_",",.02)="D"

 . . . D UPDATE^DIE("","XDRARR")

 . S XQADATA=XDRDA_U_DFNFR_";"_DFNTO_U_XDRNAME_U_XDRFILE_U_$P(XDRNOD2,U)_U_$P(XDRNOD2,U,2)

 . ;S R(1)=XDRDA_U_DFNFR_";"_DFNTO_U_XDRNAME_U_XDRFILE_U_$P(XDRNOD2,U)_U_$P(XDRNOD2,U,2)

 . D SETARY^XDRRMRG0 S XMTEXT="R("

 . S:XDRGRP'="" XMY(XDRGRP)=""

 . F I=0:0 S I=$O(^VA(15.1,PRIFILE,2,XDRAID,1,I)) Q:I'>0  S X=^(I,0) D

 . . S XQA(X)=""

 . D SEND^XDRRMRG0 K R

 Q

VERWARN ;Warning message when ready to Verified Dupicates; p126-REM

 W !!,"*** WARNING!!!  You have verified these two records are the SAME"

 W !,"patient.  Once these records are merged, there is no automated way to"

 W !,"""un-do"" the merge.  If you are not certain these are the same patient,"

 W !,"edit the status back to 'Potential Duplicate, Unverified' and repeat the"

 W !,"verification process.  For additional assistance, please log a NOIS/Remedy"

 W !,"ticket. ***"

 W !!

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XDRRMRG1   9285     printed  Feb 19, 2025@00:06:18                                                                                                                                                                                                    Page 2

XDRRMRG1  ;SF-IRMFO.SEA/JLI - DUP VERIFICATION FOR ANCILLARY SERVICES ;10/21/2010

 +1       ;;7.3;TOOLKIT;**23,29,46,47,49,126**;Apr 25, 1995;Build 2

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

 +3       ;

EN        ;

 +1        IF '$DATA(XQADATA)

               QUIT 

 +2       ; MODIFIED 03/28/00

           NEW OVERWRIT,XDRDA,DFNFR,DFNTO,DFNFRX,DFNTOX,REVIEW,XDRGL,PRIFILE

 +3        SET REVIEW=0

 +4       ; MODIFIED 03/28/00

           SET XDRGL=$PIECE($PIECE($GET(^VA(15,+XQADATA,0)),U),";",2)

           if XDRGL=""

               QUIT 

           SET XDRGL=U_XDRGL

           SET PRIFILE=+$PIECE(@(XDRGL_"0)"),U,2)

 +5        SET XDRDA=$PIECE(XQADATA,U)

 +6        SET DFNFR=$PIECE(XQADATA,U,2)

 +7        SET (DFNTOX,DFNTO)=$PIECE(DFNFR,";",2)

 +8        SET (DFNFRX,DFNFR)=$PIECE(DFNFR,";")

 +9        SET PACKAGE=$PIECE(XQADATA,U,3)

 +10       SET SUBFILES=$PIECE(XQADATA,U,5)

 +11       SET SUBNAMES=$PIECE(XQADATA,U,6)

 +12       SET XDRFILE=$PIECE(XQADATA,U,4)

 +13       SET FILEDIC=^DIC(XDRFILE,0,"GL")_"DFN)"

 +14       IF XDRGL="^DPT("

               Begin DoDot:1

 +15               SET DFN=DFNFR

                   DO ^VADPT

                   MERGE DFNFR=VADM

                   KILL VA,VADM

 +16               SET DFN=DFNTO

                   DO ^VADPT

                   MERGE DFNTO=VADM

                   KILL VA,VADM

               End DoDot:1

 +17       IF XDRFILE=63

               Begin DoDot:1

 +18               SET DFNFR=$GET(^DPT(DFNFR,"LR"))

 +19               SET DFNTO=$GET(^DPT(DFNTO,"LR"))

               End DoDot:1

 +20       IF DFNFR'>0!(DFNTO'>0)

               WRITE !,$CHAR(7),"NO DATA TO REVIEW....",!!

               QUIT 

LDATE      FOR XDRI=1,2

               SET DFN=$SELECT(XDRI=1:DFNFR,1:DFNTO)

               SET DFNNAM=$SELECT(XDRI=1:"DFNFR",1:"DFNTO")

               Begin DoDot:1

 +1                SET I=5

                   FOR 

                       SET I=$ORDER(@DFNNAM@(I))

                       if I=""

                           QUIT 

                       KILL @DFNNAM@(I)

 +2                FOR ISUBS=1:1

                       SET SUBSCR=$PIECE(SUBFILES,";",ISUBS)

                       if SUBSCR=""

                           QUIT 

                       Begin DoDot:2

 +3                        SET XX=$GET(^DD(XDRFILE,SUBSCR,0))

 +4                        IF $PIECE(XX,U,2)'["D"

                               QUIT 

 +5                        IF $PIECE($PIECE(XX,U,4),";",2)'=0

                               QUIT 

 +6                        SET SUBSCR=$PIECE($PIECE(XX,U,4),";")

 +7                        NEW XDAT1

                           SET XDAT1=0

 +8                        IF DFN>0

                               FOR I=0:0

                                   SET I=$ORDER(@FILEDIC@(SUBSCR,I))

                                   if I'>0

                                       QUIT 

                                   Begin DoDot:3

 +9                                    SET X=$PIECE($GET(@FILEDIC@(SUBSCR,I,0)),U)

 +10                                   IF X<DT

                                           IF X>XDAT1

                                               SET XDAT1=X

                                   End DoDot:3

 +11                       SET LASTNAM="LAST "_$PIECE(SUBNAMES,";",ISUBS)

 +12                       SET @DFNNAM@(LASTNAM)=""

 +13                       IF XDAT1>0

                               SET @DFNNAM@(LASTNAM)=$$FMTE^XLFDT(XDAT1\1)

                       End DoDot:2

 +14               IF @DFNNAM'=""

                       IF '$DATA(@FILEDIC)

                           SET @DFNNAM=""

               End DoDot:1

 +15       DO SHOW

 +16      ;REM - LAB is handled differently

           if XDRFILE'=63

               SET DFNFR=DFNFRX

               SET DFNTO=DFNTOX

 +17       IF IOST'["C-"

               QUIT 

 +18       DO CHK

 +19       QUIT 

 +20      ;

SHOW      ;

 +1        NEW NAMIEN1,NAMIEN2

 +2        SET N1=$$COUNT^XDRRMRG2(XDRFILE,DFNFRX,DFNTOX)

 +3        WRITE @IOF

           IF N1>0

               IF PACKAGE="PRIMARY"

                   WRITE !,"         RECORD"_N1_" contains fewer data elements, usually this would indicate",!,"                 that this record would be merged INTO the other."

 +4       ;S LABEL(1)="NAME",LABEL(2)="SSN",LABEL(3)="BIRTH DATE"

 +5       ;S LABEL(4)="AGE",LABEL(5)="SEX",LABEL("LASTDAT")="LAST DATE"

 +6        WRITE !!,"Determine if these entries ARE or ARE NOT duplicates."

 +7        WRITE !

 +8       ;REM - Modified next three lines to include IENs by patient name.

 +9        IF XDRFILE=63

               SET NAMIEN1=$$LABIEN^XDRRMRG2(XDRFILE,DFNFR)

               SET NAMIEN2=$$LABIEN^XDRRMRG2(XDRFILE,DFNTO)

 +10      ;W !,?20,$S(PACKAGE="PRIMARY":"RECORD1 [#"_DFNFR_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_DFNFR_"]")

 +11      ;W ?45,$S(PACKAGE="PRIMARY":"RECORD2 [#"_DFNTO_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_DFNTO_"]")

 +12      ;S I="" F  S I=$O(DFNFR(I)) Q:I=""  D

 +13      ;. I DFNFR(I)=""&(DFNTO(I)="") Q

 +14      ;. S DFNFR(I)=$S($P(DFNFR(I),U,2)'="":$P(DFNFR(I),U,2),1:$P(DFNFR(I),U))

 +15      ;. S DFNTO(I)=$S($P(DFNTO(I),U,2)'="":$P(DFNTO(I),U,2),1:$P(DFNTO(I),U))

 +16      ;. W !,$S($D(LABEL(I)):LABEL(I),1:I),?20,$E(DFNFR(I),1,20),?45,$E(DFNTO(I),1,20)

 +17      ;. I I=1!(I=5) W !

 +18      ;I DFNFR=""!(DFNTO="") D

 +19      ;. I DFNFR=""&(DFNTO="") W !!,"There is NO DATA in the "_PACKAGE_" file for either entry." Q

 +20      ;. I DFNFR="" W !!,"There is NO DATA in the "_PACKAGE_" file for (",DFNFRX,")  ",DFNFR(1),"   ",DFNFR(2)

 +21      ;. I DFNTO="" W !!,"There is NO DATA in the "_PACKAGE_" file for (",DFNTOX,")  ",DFNTO(1),"   ",DFNTO(2)

 +22      ;S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)

 +23      ;I DFNFR=""!(DFNTO="") Q

 +24      ;S DIT(1)=DFNFR,DIT(2)=DFNTO,IOP=IO(0),DFF=XDRFILE,DIC=XDRFILE

 +25      ;D EN^DITC K IOP

           DO SHOW^XDRDSHOW(XDRFILE,DFNFR,DFNTO,.OVERWRIT,REVIEW)

 +26       QUIT 

 +27      ;

CHK       ;

 +1        NEW DIR

CHK1       KILL DIR

 +1        SET DIR(0)="S^V:VERIFIED DUPLICATE;N:VERIFIED, NOT A DUPLICATE;U:UNABLE TO DETERMINE;H:HEALTH SUMMARY;R:REVIEW DATA AGAIN;S:SELECT/REVIEW OVERWRITES"

           SET DIR("A")="Select Action"

           SET DIR("B")="HEALTH SUMMARY"

 +2        DO ^DIR

           KILL DIR

           SET XDRY=Y

           IF $DATA(DIRUT)

               KILL XQAKILL

               QUIT 

 +3        IF XDRY="R"

               SET REVIEW=0

               DO SHOW

               GOTO CHK1

 +4        IF XDRY="S"

               SET REVIEW=1

               DO SHOW

               GOTO CHK1

 +5        IF XDRY'="H"

               Begin DoDot:1

 +6                KILL XQAKILL

 +7                IF XDRY'="^"

                       Begin DoDot:2

 +8                        SET XQAKILL=$SELECT(XDRY'="U":0,1:1)

 +9                        SET XDRDIR=""

 +10      ;p126-REM

                           IF XDRY="V"

                               DO VERWARN

 +11                       IF XDRY="V"

                               IF PACKAGE="PRIMARY"

                                   Begin DoDot:3

 +12                                   SET DIR=0

                                       FOR DFN=DFNFRX,DFNTOX

                                           IF $DATA(@FILEDIC)

                                               SET DIR=DIR+1

 +13      ; DON'T NEED TO SELECT DIRECTION UNLESS DATA IN BOTH ENTRIES

                                       IF DIR'>1

                                           KILL DIR

                                           QUIT 

 +14                                   SET DIR("B")=$$COUNT^XDRRMRG2(XDRFILE,DFNFRX,DFNTOX)

 +15                                   SET DIR("B")=$SELECT(DIR("B")'>1:"RECORD1 INTO RECORD2",1:"RECORD2 INTO RECORD1")

 +16                                   IF DIR("B")=0

                                           KILL DIR("B")

 +17                                   SET DIR(0)="S^1:RECORD1 INTO RECORD2;2:RECORD2 INTO RECORD1"

 +18                                   WRITE !!!,?20,"RECORD1 [#"_DFNFR_"]",?45,"RECORD2 [#"_DFNTO_"]"

 +19                                   WRITE !,?20,DFNFR(1),?45,DFNTO(1)

 +20                                   SET DIR("A")="Which record (1 or 2) should be MERGED INTO the other record"

 +21                                   DO ^DIR

                                       KILL DIR

                                       IF Y>0

                                           SET XDRDIR=+Y

 +22                                   IF $DATA(DIRUT)

                                           SET XDRY="^"

                                           WRITE !!!,$CHAR(7),"VERIFICATION ABORTED!",!

                                           QUIT 

 +23                                   IF DFNFRX'=+^VA(15,XDRDA,0)

                                           SET XDRDIR=$SELECT(XDRDIR'>0:2,XDRDIR=1:2,1:1)

                                   End DoDot:3

 +24                       NEW XDRFDA,XDRDA1

 +25                       SET XDRDA1=$$FIND1^DIC(15.02,","_XDRDA_",","X",PACKAGE)

 +26                       SET XDRDA1=$SELECT(XDRDA1>0:XDRDA1_",",1:"+1,")_XDRDA_","

 +27                       SET XDRFDA(15.02,XDRDA1,.01)=PACKAGE

 +28                       SET XDRFDA(15.02,XDRDA1,.02)=XDRY

 +29                       SET XDRFDA(15.02,XDRDA1,.03)=DUZ

 +30                       SET XDRFDA(15.02,XDRDA1,.04)=$$NOW^XLFDT()

 +31                       IF XDRDIR'=""

                               SET XDRFDA(15.02,XDRDA1,.05)=XDRDIR

 +32                       DO UPDATE^DIE("S","XDRFDA")

 +33      ;

 +34                       IF $DATA(OVERWRIT)!(XDRDIR=2&(PACKAGE'="PRIMARY"))

                               Begin DoDot:3

 +35                               NEW I

 +36                               SET XDRDA1=$$FIND1^DIC(15.03,","_XDRDA_",","X",XDRFILE)

 +37                               IF XDRDA1'>0

                                       Begin DoDot:4

 +38                                       SET XDRDA1="+1,"_XDRDA_","

 +39                                       KILL XDRFDA,XDRDAX

 +40                                       SET XDRDAX(1)=XDRFILE

 +41                                       SET XDRFDA(15.03,XDRDA1,.01)=XDRFILE

 +42                                       IF XDRDIR=2

                                               IF PACKAGE'="PRIMARY"

                                                   Begin DoDot:5

 +43                                                   SET XDRFDA(15.03,XDRDA1,.02)=2

                                                   End DoDot:5

 +44                                       DO UPDATE^DIE("S","XDRFDA","XDRDAX")

 +45                                       SET XDRDA1=XDRDAX(1)

                                       End DoDot:4

 +46                               SET XDRDA1="+1,"_XDRDA1_","_XDRDA_","

 +47                               FOR I=0:0

                                       SET I=$ORDER(OVERWRIT(I))

                                       if I'>0

                                           QUIT 

                                       Begin DoDot:4

 +48                                       KILL XDRFDA,XDRDAX

 +49                                       SET XDRDAX(1)=I

 +50                                       SET XDRFDA(15.031,XDRDA1,.01)=I

 +51                                       DO UPDATE^DIE("S","XDRFDA","XDRDAX")

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

 +52               IF XDRY="V"

                       Begin DoDot:2

 +53                       DO CHEKVER

                       End DoDot:2

 +54               IF XDRY="N"

                       Begin DoDot:2

 +55                       SET XDRAID=$GET(XQAID)

                           NEW XQAID,I

 +56      ; MODIFIED 03/28/00

                           FOR I=0:0

                               SET I=$ORDER(^VA(15.1,PRIFILE,2,I))

                               if I'>0

                                   QUIT 

                               Begin DoDot:3

 +57                               SET XQAID=$PIECE(XDRAID,",",1,2)_","_I

 +58                               SET XQAKILL=0

 +59                               DO DELETEA^XQALERT

                               End DoDot:3

 +60                       NEW XDRFDA

 +61                       SET XDRFDA(15,XDRDA_",",.03)="N"

 +62                       SET XDRFDA(15,XDRDA_",",.07)=$$NOW^XLFDT()

 +63                       SET XDRFDA(15,XDRDA_",",.11)=DUZ

 +64                       DO UPDATE^DIE("S","XDRFDA")

                       End DoDot:2

               End DoDot:1

               QUIT 

 +65      ;REM -Reset ABORT to 0

           SET ABORT=0

           DO ASK^XDRRMRG2(.QLIST,.ABORT)

 +66      ;

 +67      ;For health summary, user has the option of using the Browser to view 

 +68      ;both records or use may select any other device for each record.

 +69      ;

 +70       IF '$GET(ABORT)

               DO PRINT2^XDRRMRG2

 +71       DO HOME^%ZIS

 +72       GOTO CHK1

 +73       QUIT 

 +74      ;

CHEKVER   ;

 +1        NEW R

 +2        SET XVER=1

 +3       ; MODIFIED 03/28/00

           FOR I=0:0

               SET I=$ORDER(^VA(15.1,PRIFILE,2,I))

               if I'>0

                   QUIT 

               Begin DoDot:1

 +4       ; MODIFIED 03/28/00

                   SET X1=+$PIECE(^VA(15.1,PRIFILE,2,I,0),U,2)

 +5       ; MODIFIED 03/28/00

                   SET XN=$PIECE(^VA(15.1,PRIFILE,2,I,0),U)

 +6                IF X1>0

                       Begin DoDot:2

 +7       ;REM -changed I to R in FOR loop 

                           FOR R=1,5,6,7,0

                               IF $ORDER(^XMB(3.8,X1,R,0))>0

                                   QUIT 

 +8                        IF R'>0

                               SET X1=0

                       End DoDot:2

 +9       ; MODIFIED 03/28/00

                   IF X1'>0

                       IF $ORDER(^VA(15.1,PRIFILE,2,I,1,0))'>0

                           QUIT 

 +10               SET X1=$$FIND1^DIC(15.02,","_XDRDA_",","X",XN)

 +11               SET XVER=$SELECT(X1'>0:0,$PIECE(^VA(15,XDRDA,2,X1,0),U,2)="V":1,$PIECE(^(0),U,2)="D":1,1:0)

               End DoDot:1

               if 'XVER

                   QUIT 

 +12       IF XVER

               DO FINALVER^XDRVCHEK(XDRDA)

 +13       QUIT 

 +14      ;

SETUP(XDRDA) ;

 +1        NEW XDRGRPN,XDRSSN,XDRFILE

 +2        SET X=^VA(15,XDRDA,0)

 +3        IF $PIECE($GET(^VA(15,XDRDA,2,1,0)),U,5)=2

               SET DFNTO=+X

               SET DFNFR=+$PIECE(X,U,2)

 +4       IF '$TEST

               SET DFNFR=+X

               SET DFNTO=+$PIECE(X,U,2)

 +5        SET XDRFILE=$PIECE($PIECE(X,U),";",2)

           SET XDRFILE=+$PIECE(@(U_XDRFILE_"0)"),U,2)

 +6       ; MODIFIED 03/28/00

           FOR XDRAID=0:0

               SET XDRAID=$ORDER(^VA(15.1,PRIFILE,2,XDRAID))

               if XDRAID'>0

                   QUIT 

               Begin DoDot:1

 +7       ; MODIFIED 03/28/00

                   SET XDRNODE=^VA(15.1,PRIFILE,2,XDRAID,0)

 +8       ; MODIFIED 03/28/00

                   SET XDRNOD2=$GET(^VA(15.1,PRIFILE,2,XDRAID,2))

 +9                SET XDRNAME=$PIECE(XDRNODE,U)

 +10               SET XDRGRP=$PIECE(XDRNODE,U,2)

 +11      ;REM -8/2/96 Get the name of mail group

                   if XDRGRP>0

                       SET XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01)

 +12               SET XDRGRP=$SELECT(XDRGRP>0:"G."_XDRGRPN,1:"")

 +13               SET XDRFILE=$PIECE(XDRNODE,U,3)

                   Begin DoDot:2

 +14                   NEW XDRDIC,XDRFR,XDRTO

 +15                   SET XDRDIC=^DIC(XDRFILE,0,"GL")

 +16                   SET XDRFR=$SELECT(XDRFILE'=63:DFNFR,1:$GET(^DPT(DFNFR,"LR")))

 +17                   SET XDRTO=$SELECT(XDRFILE'=63:DFNTO,1:$GET(^DPT(DFNTO,"LR")))

 +18                   IF XDRFR'>0!(XDRTO'>0)

                           KILL XDRNODE

 +19                   IF $DATA(XDRNODE)

                           IF '$DATA(@(XDRDIC_XDRFR_",0)"))!'$DATA(@(XDRDIC_XDRTO_",0)"))

                               KILL XDRNODE

 +20                   IF '$DATA(XDRNODE)

                           Begin DoDot:3

 +21                           NEW XDRARR

                               IF $$FIND1^DIC(15.02,","_XDRDA_",","X",XDRNAME)>0

                                   QUIT 

 +22                           SET XDRARR(15.02,"+1,"_XDRDA_",",.01)=XDRNAME

 +23                           SET XDRARR(15.02,"+1,"_XDRDA_",",.02)="D"

 +24                           DO UPDATE^DIE("","XDRARR")

                           End DoDot:3

                   End DoDot:2

                   if '$DATA(XDRNODE)

                       QUIT 

 +25               SET XQADATA=XDRDA_U_DFNFR_";"_DFNTO_U_XDRNAME_U_XDRFILE_U_$PIECE(XDRNOD2,U)_U_$PIECE(XDRNOD2,U,2)

 +26      ;S R(1)=XDRDA_U_DFNFR_";"_DFNTO_U_XDRNAME_U_XDRFILE_U_$P(XDRNOD2,U)_U_$P(XDRNOD2,U,2)

 +27               DO SETARY^XDRRMRG0

                   SET XMTEXT="R("

 +28               if XDRGRP'=""

                       SET XMY(XDRGRP)=""

 +29               FOR I=0:0

                       SET I=$ORDER(^VA(15.1,PRIFILE,2,XDRAID,1,I))

                       if I'>0

                           QUIT 

                       SET X=^(I,0)

                       Begin DoDot:2

 +30                       SET XQA(X)=""

                       End DoDot:2

 +31               DO SEND^XDRRMRG0

                   KILL R

               End DoDot:1

 +32       QUIT 

VERWARN   ;Warning message when ready to Verified Dupicates; p126-REM

 +1        WRITE !!,"*** WARNING!!!  You have verified these two records are the SAME"

 +2        WRITE !,"patient.  Once these records are merged, there is no automated way to"

 +3        WRITE !,"""un-do"" the merge.  If you are not certain these are the same patient,"

 +4        WRITE !,"edit the status back to 'Potential Duplicate, Unverified' and repeat the"

 +5        WRITE !,"verification process.  For additional assistance, please log a NOIS/Remedy"

 +6        WRITE !,"ticket. ***"

 +7        WRITE !!

 +8        QUIT