XDRMADD ;SF-IRMFO/IHS/OHPRD/JCM,JLI,REM - USER CREATED VERIFIED DUPLICATE PAIR ENTRY ;27 Jul 2010 6:18 PM
;;7.3;TOOLKIT;**23,113,124,125**;Apr 25, 1995;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
N XDRFL,XDRCNTR
S XDRCNTR=0
START ;
N XDRADFLG,XDRNOPT
K DIC
; XT*7.3*113 - Setting of XDRNOPT flag, and checking for XDRFL'=2
; in this routine and in SCORE entry point, prevent option
; from using the duplicate record checking code on the PATIENT file.
; DUPLICATE RECORD entries can be added, but no checking is done.
S (XDRQFLG,XDRADFLG,XDRNOPT)=0
I '$D(XDRFL) D
. S DIC("A")="Add entries from which File: " D FILE^XDRDQUE Q:XDRQFLG ;XT*7.3*124 stop UNDEF if Y=-1
. I XDRFL=2 W "* No potential duplicate threshold % check will be calculated for PATIENTS"
. Q
G:XDRQFLG END
D:XDRFL'=2
. S XDRDTYPE=$P(XDRD(0),U,5)
. Q:XDRDTYPE]""
. ;REM -8/20/96 when XDRDTYPE is null set it to basic.
. S $P(^VA(15.1,XDRFL,0),U,5)="b",XDRDTYPE="b"
. Q
S XDRGL=^DIC(XDRFL,0,"GL")
D:XDRCNTR>0 G:XDRQFLG END
. W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to ADD another pair (Y/N)"
. D ^DIR K DIR S:$D(DIRUT)!('Y) XDRQFLG=1
. Q
S XDRCNTR=XDRCNTR+1
; Skip duplicate record checking for patients
I XDRFL=2 D
. S (XDRDSCOR("MAX"),XDRDSCOR("PDT%"),XDRD("DUPSCORE"),XDRMADD("DUPSCORE%"))=0
. S XDRADFLG=1
I XDRFL'=2 D BYPASS G:XDRQFLG END
D LKUP G:XDRQFLG END
D CHECK G:XDRQFLG<0 START
;
; Added the following line to check the MPI DO NOT LINK file
; (XT*7.3*125)
I XDRDFLG'>0,XDRFL=2 G:'$$DNLCHECK START
;
I XDRFL'=2 D
. D ^XDRDSCOR S:XDRADFLG XDRDSCOR("PDT%")=0 ;REM -8/23/96 to bypass PDT%
. S XDRD("NOADD")="" D ^XDRDUP
. Q
K XDRDTYPE
D SCORE
I XDRFL'=2,XDRMADD("DUPSCORE%")<XDRDSCOR("PDT%") D G START ; JLI 4/11/96
. W !!,$C(7),"This pair of patients has a duplicate percentage of only ",XDRMADD("DUPSCORE%"),"% which"
. W !,"is less than the minimal percentage for potential duplicates (",XDRDSCOR("PDT%"),"%)."
. W !!?30,"Patients not added!!!",!!
S XDRDA=+XDRDFLG I XDRDA'>0 D ADD
G:XDRQFLG START
D SHOW^XDRDPICK ; D MERGE ; CHANGED TO CURRENT VERIF METHOD, NOT MERGE 4/11/96 JLI
G START ; ADDED 4/11/96 JLI
END D EOJ
Q
;
LKUP ;Looks up the records to add.
K XDRCD,XDRCD2
S DIC=XDRGL,DIC(0)="QEAM"
S DIC("S")="I '$D(^VA(15,""AFR"",$P(XDRGL,U,2),Y))"
S DIC("A")="Select "_$P(^DIC(XDRFL,0),U,1)_": "
D ^DIC K DIC,DA
I $D(DIRUT)!(Y=-1) S XDRQFLG=1 G LKUPX
S XDRCD=+Y
LKUP2 S DIC=XDRGL,DIC(0)="QEAM"
S DIC("S")="I '$D(^VA(15,""AFR"",$P(XDRGL,U,2),Y))"
S DIC("A")=" Another "_$P(^DIC(XDRFL,0),U,1)_": "
D ^DIC K DIC,DA
G:$D(DIRUT)!(Y=-1) LKUP
S XDRCD2=+Y
I XDRCD=XDRCD2 W !!,"Please do not try and merge the same patients together.",!! K XDRCD2 G LKUP2
S XDRMADD("REC1")=$S(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
S XDRMADD("REC2")=$S(XDRMADD("REC1")=XDRCD:XDRCD2,1:XDRCD)
S XDRCD=XDRMADD("REC1"),XDRCD2=XDRMADD("REC2")
W !!,"You will be adding the following pair of records to the duplicate record file:",!
W !?5,"RECORD1: ",$P(@(XDRGL_XDRCD_",0)"),U)
W !?5,"RECORD2: ",$P(@(XDRGL_XDRCD2_",0)"),U)
W !! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S XDRQFLG=1 Q
W " Ok, continuing, hold on ...",!
;W !!,"Hit return to continue " R XDRMADD("ANS"):DTIME W " Okay, continuing, hold on ...",!
LKUPX Q
;
CHECK ;
S XDRDFLG=0 F XDRDI="APOT","ANOT","AVDUP" I $D(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD_U_XDRCD2))!($D(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD2_U_XDRCD))) S XDRDFLG=-1 I XDRDI="APOT" D
. I $D(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD_U_XDRCD2)) S XDRDFLG=$O(^(XDRCD_U_XDRCD2,0)) Q
. S XDRDFLG=$O(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD2_U_XDRCD,0))
I XDRDFLG W !!,"They are already entered in Duplicate Record file.",!!
K XDRDI
Q
;
DNLCHECK() ; If patients are being selected for merge, check the MPI to
; determine whether the records are marked as DO NOT LINK and
; therefore should not be added to the DUPLICATE RECORD file.
; Returns 1 if OK.
; Created in XT*7.3*125
Q:XDRFL'=2 1
N X,XDRRES
;
; Quit if routine MPIFDNL or line tag DNLCHK does not exist
S X="MPIFDNL" X ^%ZOSF("TEST") Q:'$T 1
Q:$L($T(DNLCHK^MPIFDNL))=0 1
;
; Call $$DNLCHK^MPIFDNL to perform the check.
; Returns 0 if check passed; Returns -1^error message if not
S XDRRES=$$DNLCHK^MPIFDNL(XDRCD,XDRCD2)
;
; If an error is returned, write the error message to the current
; device and return 0
I $P(XDRRES,U)=-1 D Q 0
. N X,DIWL,DIWR,DIWF
. K ^UTILITY($J,"W")
. S X=$P(XDRRES,U,2,999),DIWL=1,DIWR=IOM-1,DIWF="W"
. W !,$C(7)
. D ^DIWP,^DIWW
Q 1
;
SCORE ;
I XDRFL'=2 D
. S XDRMADD("DUPSCORE%")=$S($G(XDRDSCOR("MAX"))=0:0,1:(XDRD("DUPSCORE")/XDRDSCOR("MAX")))
. S XDRMADD("DUPSCORE%")=$J(XDRMADD("DUPSCORE%"),1,2)
. S XDRMADD("DUPSCORE%")=$S(XDRMADD("DUPSCORE%")<0:0,XDRMADD("DUPSCORE%")<1:$E(XDRMADD("DUPSCORE%"),3,4),1:100)
. Q
S XDRDFR=$S(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
S XDRDTO=$S(XDRDFR=XDRCD:XDRCD2,1:XDRCD)
S XDRMADD("STATUS")="X"
Q
;
ADD ;
;ADD TO DUPLICATE RECORD FILE
S XDRMAINI="MERGE" D ^XDRMAINI ;LAB/OHPRD ADDED THIS
S DIC="^VA(15,",DIC(0)="L",X=XDRDFR_";"_$P(XDRGL,U,2),DLAYGO=15
S XDRMADDX=XDRDTO_";"_$P(XDRGL,U,2)
S DIC("DR")=".02////^S X=XDRMADDX"_";.03////"_XDRMADD("STATUS")
;S DIC("DR")=DIC("DR")_";.04//2" ;REM -10/2/96 this will be asked in XDRRMRG!
S DIC("DR")=DIC("DR")_";.03///P"_";.06////"_DT_";.09////"_DUZ
S DIC("DR")=DIC("DR")_";.15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRMADD("DUPSCORE%")
S:$D(XDRDSCOR("VDT%")) DIC("DR")=DIC("DR")_";.16////"_XDRDSCOR("VDT%")
D
. N I,X1,X2,X3
. S X1=X_U_XDRMADDX,X2=XDRMADDX_U_X
. F I=0:0 S I=$O(^VA(15,"B",X,I)) Q:I'>0 S X3=$P($G(^VA(15,I,0)),U,1,2) I X3=X1!(X3=X2) K X Q
S Y=-1 I $D(X) D FILE^DICN
K DIC,DR,X,DLAYGO
I Y'>0 S XDRQFLG=1 K XDRCD,XDRCD2 G ADDX
S DIE="^VA(15,",(XDRDA,XDRMPDA,DA)=+Y ; ADDED XDRDA TO LIST 4/11/96 JLI
F XDRMORD=0:0 S XDRMORD=$O(XDRDTEST(XDRMORD)) Q:'XDRMORD S DR="2101///"_$P(XDRDTEST(XDRMORD),U,1),DR(2,15.02101)=".02////"_XDRDUP("TEST SCORE",XDRMORD) D ^DIE K DR
ADDX K DIE,DR,DA,XDRMORD,XDRMADDX,XDRDUP("TEST SCORE")
Q
;
MERGE Q ;
S XDRMPAIR=XDRDFR_"^"_XDRDTO,XDRM("NOVERIFY")=""
D EN^XDRMAIN
MERGEX K XDRM
Q
;
BYPASS ;REM -8/20/96 Add record directly into file 15, bypass threshold.
N X,XDRKEY
S (X,XDRKEY)=0 F S X=$O(^VA(200,DUZ,51,"B",X)) Q:X'>0!(XDRKEY) D
.I $$GET1^DIQ(19.1,X,.01)="XDRMGR" S XDRKEY=1 Q
Q:'XDRKEY
S DIR(0)="Y",DIR("A")="Do you want to bypass the potential duplicate threshold % check (Y/N)"
S DIR("??")="^W !!,""This will add the pair of records to the Duplicate Record file without checking the potential duplicate threshold %."""
D ^DIR K DIR S XDRADFLG=Y I $D(DTOUT)!($D(DUOUT)) S XDRQFLG=1 Q
I 'XDRADFLG W !!,*7,"Potential duplicate threshold % will NOT be bypassed!",!
I XDRADFLG D
.W !!,"This will add the pair of records directly into the Duplicate Record file."
.S DIR(0)="YO",DIR("A")="Are you sure you want to continue",DIR("B")="NO"
.D ^DIR K DIR S XDRADFLG=Y W ! I $D(DIRUT) S XDRQFLG=1 Q
.I 'XDRADFLG W *7,!!,"Potential duplicate threshold % will NOT be bypassed!",!
Q
;
EOJ ;
K XDRMADD,XDRMORD,XDRDFR,XDRDTO,X,Y,XDRCD,XDRCD2,XDRD,XDRFL,XDRGL
K XDRFL,XDRMPAIR,XDRMPDA,XDRQFLG,XDRDSCOR,XDRDTEST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMADD 7391 printed Apr 09, 2024@21:41:49 Page 2
XDRMADD ;SF-IRMFO/IHS/OHPRD/JCM,JLI,REM - USER CREATED VERIFIED DUPLICATE PAIR ENTRY ;27 Jul 2010 6:18 PM
+1 ;;7.3;TOOLKIT;**23,113,124,125**;Apr 25, 1995;Build 1
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
+4 NEW XDRFL,XDRCNTR
+5 SET XDRCNTR=0
START ;
+1 NEW XDRADFLG,XDRNOPT
+2 KILL DIC
+3 ; XT*7.3*113 - Setting of XDRNOPT flag, and checking for XDRFL'=2
+4 ; in this routine and in SCORE entry point, prevent option
+5 ; from using the duplicate record checking code on the PATIENT file.
+6 ; DUPLICATE RECORD entries can be added, but no checking is done.
+7 SET (XDRQFLG,XDRADFLG,XDRNOPT)=0
+8 IF '$DATA(XDRFL)
Begin DoDot:1
+9 ;XT*7.3*124 stop UNDEF if Y=-1
SET DIC("A")="Add entries from which File: "
DO FILE^XDRDQUE
if XDRQFLG
QUIT
+10 IF XDRFL=2
WRITE "* No potential duplicate threshold % check will be calculated for PATIENTS"
+11 QUIT
End DoDot:1
+12 if XDRQFLG
GOTO END
+13 if XDRFL'=2
Begin DoDot:1
+14 SET XDRDTYPE=$PIECE(XDRD(0),U,5)
+15 if XDRDTYPE]""
QUIT
+16 ;REM -8/20/96 when XDRDTYPE is null set it to basic.
+17 SET $PIECE(^VA(15.1,XDRFL,0),U,5)="b"
SET XDRDTYPE="b"
+18 QUIT
End DoDot:1
+19 SET XDRGL=^DIC(XDRFL,0,"GL")
+20 if XDRCNTR>0
Begin DoDot:1
+21 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to ADD another pair (Y/N)"
+22 DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
SET XDRQFLG=1
+23 QUIT
End DoDot:1
if XDRQFLG
GOTO END
+24 SET XDRCNTR=XDRCNTR+1
+25 ; Skip duplicate record checking for patients
+26 IF XDRFL=2
Begin DoDot:1
+27 SET (XDRDSCOR("MAX"),XDRDSCOR("PDT%"),XDRD("DUPSCORE"),XDRMADD("DUPSCORE%"))=0
+28 SET XDRADFLG=1
End DoDot:1
+29 IF XDRFL'=2
DO BYPASS
if XDRQFLG
GOTO END
+30 DO LKUP
if XDRQFLG
GOTO END
+31 DO CHECK
if XDRQFLG<0
GOTO START
+32 ;
+33 ; Added the following line to check the MPI DO NOT LINK file
+34 ; (XT*7.3*125)
+35 IF XDRDFLG'>0
IF XDRFL=2
if '$$DNLCHECK
GOTO START
+36 ;
+37 IF XDRFL'=2
Begin DoDot:1
+38 ;REM -8/23/96 to bypass PDT%
DO ^XDRDSCOR
if XDRADFLG
SET XDRDSCOR("PDT%")=0
+39 SET XDRD("NOADD")=""
DO ^XDRDUP
+40 QUIT
End DoDot:1
+41 KILL XDRDTYPE
+42 DO SCORE
+43 ; JLI 4/11/96
IF XDRFL'=2
IF XDRMADD("DUPSCORE%")<XDRDSCOR("PDT%")
Begin DoDot:1
+44 WRITE !!,$CHAR(7),"This pair of patients has a duplicate percentage of only ",XDRMADD("DUPSCORE%"),"% which"
+45 WRITE !,"is less than the minimal percentage for potential duplicates (",XDRDSCOR("PDT%"),"%)."
+46 WRITE !!?30,"Patients not added!!!",!!
End DoDot:1
GOTO START
+47 SET XDRDA=+XDRDFLG
IF XDRDA'>0
DO ADD
+48 if XDRQFLG
GOTO START
+49 ; D MERGE ; CHANGED TO CURRENT VERIF METHOD, NOT MERGE 4/11/96 JLI
DO SHOW^XDRDPICK
+50 ; ADDED 4/11/96 JLI
GOTO START
END DO EOJ
+1 QUIT
+2 ;
LKUP ;Looks up the records to add.
+1 KILL XDRCD,XDRCD2
+2 SET DIC=XDRGL
SET DIC(0)="QEAM"
+3 SET DIC("S")="I '$D(^VA(15,""AFR"",$P(XDRGL,U,2),Y))"
+4 SET DIC("A")="Select "_$PIECE(^DIC(XDRFL,0),U,1)_": "
+5 DO ^DIC
KILL DIC,DA
+6 IF $DATA(DIRUT)!(Y=-1)
SET XDRQFLG=1
GOTO LKUPX
+7 SET XDRCD=+Y
LKUP2 SET DIC=XDRGL
SET DIC(0)="QEAM"
+1 SET DIC("S")="I '$D(^VA(15,""AFR"",$P(XDRGL,U,2),Y))"
+2 SET DIC("A")=" Another "_$PIECE(^DIC(XDRFL,0),U,1)_": "
+3 DO ^DIC
KILL DIC,DA
+4 if $DATA(DIRUT)!(Y=-1)
GOTO LKUP
+5 SET XDRCD2=+Y
+6 IF XDRCD=XDRCD2
WRITE !!,"Please do not try and merge the same patients together.",!!
KILL XDRCD2
GOTO LKUP2
+7 SET XDRMADD("REC1")=$SELECT(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
+8 SET XDRMADD("REC2")=$SELECT(XDRMADD("REC1")=XDRCD:XDRCD2,1:XDRCD)
+9 SET XDRCD=XDRMADD("REC1")
SET XDRCD2=XDRMADD("REC2")
+10 WRITE !!,"You will be adding the following pair of records to the duplicate record file:",!
+11 WRITE !?5,"RECORD1: ",$PIECE(@(XDRGL_XDRCD_",0)"),U)
+12 WRITE !?5,"RECORD2: ",$PIECE(@(XDRGL_XDRCD2_",0)"),U)
+13 WRITE !!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET XDRQFLG=1
QUIT
+14 WRITE " Ok, continuing, hold on ...",!
+15 ;W !!,"Hit return to continue " R XDRMADD("ANS"):DTIME W " Okay, continuing, hold on ...",!
LKUPX QUIT
+1 ;
CHECK ;
+1 SET XDRDFLG=0
FOR XDRDI="APOT","ANOT","AVDUP"
IF $DATA(^VA(15,XDRDI,$PIECE(XDRGL,U,2),XDRCD_U_XDRCD2))!($DATA(^VA(15,XDRDI,$PIECE(XDRGL,U,2),XDRCD2_U_XDRCD)))
SET XDRDFLG=-1
IF XDRDI="APOT"
Begin DoDot:1
+2 IF $DATA(^VA(15,XDRDI,$PIECE(XDRGL,U,2),XDRCD_U_XDRCD2))
SET XDRDFLG=$ORDER(^(XDRCD_U_XDRCD2,0))
QUIT
+3 SET XDRDFLG=$ORDER(^VA(15,XDRDI,$PIECE(XDRGL,U,2),XDRCD2_U_XDRCD,0))
End DoDot:1
+4 IF XDRDFLG
WRITE !!,"They are already entered in Duplicate Record file.",!!
+5 KILL XDRDI
+6 QUIT
+7 ;
DNLCHECK() ; If patients are being selected for merge, check the MPI to
+1 ; determine whether the records are marked as DO NOT LINK and
+2 ; therefore should not be added to the DUPLICATE RECORD file.
+3 ; Returns 1 if OK.
+4 ; Created in XT*7.3*125
+5 if XDRFL'=2
QUIT 1
+6 NEW X,XDRRES
+7 ;
+8 ; Quit if routine MPIFDNL or line tag DNLCHK does not exist
+9 SET X="MPIFDNL"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT 1
+10 if $LENGTH($TEXT(DNLCHK^MPIFDNL))=0
QUIT 1
+11 ;
+12 ; Call $$DNLCHK^MPIFDNL to perform the check.
+13 ; Returns 0 if check passed; Returns -1^error message if not
+14 SET XDRRES=$$DNLCHK^MPIFDNL(XDRCD,XDRCD2)
+15 ;
+16 ; If an error is returned, write the error message to the current
+17 ; device and return 0
+18 IF $PIECE(XDRRES,U)=-1
Begin DoDot:1
+19 NEW X,DIWL,DIWR,DIWF
+20 KILL ^UTILITY($JOB,"W")
+21 SET X=$PIECE(XDRRES,U,2,999)
SET DIWL=1
SET DIWR=IOM-1
SET DIWF="W"
+22 WRITE !,$CHAR(7)
+23 DO ^DIWP
DO ^DIWW
End DoDot:1
QUIT 0
+24 QUIT 1
+25 ;
SCORE ;
+1 IF XDRFL'=2
Begin DoDot:1
+2 SET XDRMADD("DUPSCORE%")=$SELECT($GET(XDRDSCOR("MAX"))=0:0,1:(XDRD("DUPSCORE")/XDRDSCOR("MAX")))
+3 SET XDRMADD("DUPSCORE%")=$JUSTIFY(XDRMADD("DUPSCORE%"),1,2)
+4 SET XDRMADD("DUPSCORE%")=$SELECT(XDRMADD("DUPSCORE%")<0:0,XDRMADD("DUPSCORE%")<1:$EXTRACT(XDRMADD("DUPSCORE%"),3,4),1:100)
+5 QUIT
End DoDot:1
+6 SET XDRDFR=$SELECT(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
+7 SET XDRDTO=$SELECT(XDRDFR=XDRCD:XDRCD2,1:XDRCD)
+8 SET XDRMADD("STATUS")="X"
+9 QUIT
+10 ;
ADD ;
+1 ;ADD TO DUPLICATE RECORD FILE
+2 ;LAB/OHPRD ADDED THIS
SET XDRMAINI="MERGE"
DO ^XDRMAINI
+3 SET DIC="^VA(15,"
SET DIC(0)="L"
SET X=XDRDFR_";"_$PIECE(XDRGL,U,2)
SET DLAYGO=15
+4 SET XDRMADDX=XDRDTO_";"_$PIECE(XDRGL,U,2)
+5 SET DIC("DR")=".02////^S X=XDRMADDX"_";.03////"_XDRMADD("STATUS")
+6 ;S DIC("DR")=DIC("DR")_";.04//2" ;REM -10/2/96 this will be asked in XDRRMRG!
+7 SET DIC("DR")=DIC("DR")_";.03///P"_";.06////"_DT_";.09////"_DUZ
+8 SET DIC("DR")=DIC("DR")_";.15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRMADD("DUPSCORE%")
+9 if $DATA(XDRDSCOR("VDT%"))
SET DIC("DR")=DIC("DR")_";.16////"_XDRDSCOR("VDT%")
+10 Begin DoDot:1
+11 NEW I,X1,X2,X3
+12 SET X1=X_U_XDRMADDX
SET X2=XDRMADDX_U_X
+13 FOR I=0:0
SET I=$ORDER(^VA(15,"B",X,I))
if I'>0
QUIT
SET X3=$PIECE($GET(^VA(15,I,0)),U,1,2)
IF X3=X1!(X3=X2)
KILL X
QUIT
End DoDot:1
+14 SET Y=-1
IF $DATA(X)
DO FILE^DICN
+15 KILL DIC,DR,X,DLAYGO
+16 IF Y'>0
SET XDRQFLG=1
KILL XDRCD,XDRCD2
GOTO ADDX
+17 ; ADDED XDRDA TO LIST 4/11/96 JLI
SET DIE="^VA(15,"
SET (XDRDA,XDRMPDA,DA)=+Y
+18 FOR XDRMORD=0:0
SET XDRMORD=$ORDER(XDRDTEST(XDRMORD))
if 'XDRMORD
QUIT
SET DR="2101///"_$PIECE(XDRDTEST(XDRMORD),U,1)
SET DR(2,15.02101)=".02////"_XDRDUP("TEST SCORE",XDRMORD)
DO ^DIE
KILL DR
ADDX KILL DIE,DR,DA,XDRMORD,XDRMADDX,XDRDUP("TEST SCORE")
+1 QUIT
+2 ;
MERGE ;
QUIT
+1 SET XDRMPAIR=XDRDFR_"^"_XDRDTO
SET XDRM("NOVERIFY")=""
+2 DO EN^XDRMAIN
MERGEX KILL XDRM
+1 QUIT
+2 ;
BYPASS ;REM -8/20/96 Add record directly into file 15, bypass threshold.
+1 NEW X,XDRKEY
+2 SET (X,XDRKEY)=0
FOR
SET X=$ORDER(^VA(200,DUZ,51,"B",X))
if X'>0!(XDRKEY)
QUIT
Begin DoDot:1
+3 IF $$GET1^DIQ(19.1,X,.01)="XDRMGR"
SET XDRKEY=1
QUIT
End DoDot:1
+4 if 'XDRKEY
QUIT
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want to bypass the potential duplicate threshold % check (Y/N)"
+6 SET DIR("??")="^W !!,""This will add the pair of records to the Duplicate Record file without checking the potential duplicate threshold %."""
+7 DO ^DIR
KILL DIR
SET XDRADFLG=Y
IF $DATA(DTOUT)!($DATA(DUOUT))
SET XDRQFLG=1
QUIT
+8 IF 'XDRADFLG
WRITE !!,*7,"Potential duplicate threshold % will NOT be bypassed!",!
+9 IF XDRADFLG
Begin DoDot:1
+10 WRITE !!,"This will add the pair of records directly into the Duplicate Record file."
+11 SET DIR(0)="YO"
SET DIR("A")="Are you sure you want to continue"
SET DIR("B")="NO"
+12 DO ^DIR
KILL DIR
SET XDRADFLG=Y
WRITE !
IF $DATA(DIRUT)
SET XDRQFLG=1
QUIT
+13 IF 'XDRADFLG
WRITE *7,!!,"Potential duplicate threshold % will NOT be bypassed!",!
End DoDot:1
+14 QUIT
+15 ;
EOJ ;
+1 KILL XDRMADD,XDRMORD,XDRDFR,XDRDTO,X,Y,XDRCD,XDRCD2,XDRD,XDRFL,XDRGL
+2 KILL XDRFL,XDRMPAIR,XDRMPDA,XDRQFLG,XDRDSCOR,XDRDTEST
+3 QUIT
