XDRDPICK ;SF-IRMFO.SEA/JLI - SELECT A PAIR OF POTENTIAL DUPLICATES AND VIEW ;10/10/08 13:38
;;7.3;TOOLKIT;**23,47,113**;Apr 25, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
EN ;
N XDRFL,CMORS1,CMORS2,D0,DA,DIC,DIE,DIR,ICNT,ICNT1,JCNT,LCNT,NCNT,PNCT,TMPGLA,TMPGLB,XDRDA,XDRFILN,XDRGLB,Y,PRIFILE
; D EN^XDRVCHEK
S XDRFL=$$FILE() Q:XDRFL'>0 S PRIFILE=XDRFL,XDRGLB=$P(^DIC(XDRFL,0,"GL"),U,2),XDRFILN=$P(^DIC(XDRFL,0),U)
LOOP ;
W !!!,"At the following prompt select a POTENTIAL DUPLICATE ENTRY. If a selection"
W !,"is not made, you will be given a chance to select from a list if you"
W !,"want to. Otherwise, you will be returned to the menu system."
W !
S Y=$$LOOKUP^XDRDEDT(XDRFL)
S XDRDA=+Y I Y>0 D SHOW G LOOP
S DIR(0)="Y"
S DIR("A")="Do you want to select from a list of potential duplicates"
S DIR("B")="YES"
D ^DIR K DIR Q:Y'>0
S TMPGLB=$NA(^TMP("XDRDPICK",$J)),TMPGLA=$NA(^TMP("XDRDPICA",$J))
K @TMPGLB,@TMPGLA
D ASK
I XDRDA>0 G LOOP
K PCNT
Q
;
GETLIST ;
I XDRGLB="DPT(",$O(^DPT("ACMORS",0))>0 D CMORS Q
N FLG
F ICNT=ICNT:0 S ICNT=$O(^VA(15,ICNT)) Q:ICNT'>0 S X=^(ICNT,0) D Q:'(NCNT#4)&(NCNT>0)&FLG
. S FLG=1 ;This flag is when NCNT is set from previous call and STATUS is not "P" the first time- - so loop will not quit with (NCNT#4)
. I $P(X,U,3)'="P" S:PCNT=NCNT FLG=0 Q
. I $P($P(X,U),";",2)'=XDRGLB Q
. S NCNT=NCNT+1,X1=+$P(X,U),X2=+$P(X,U,2)
. I '($D(@(U_XDRGLB_X1_",0)"))#2)!'($D(@(U_XDRGLB_X2_",0)"))#2) S NCNT=NCNT-1 Q
. S @TMPGLB@(NCNT)=ICNT_U_X1_U_X2
. S @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)")
. S @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)")
Q
;
ASK ;
S NCNT=0,ICNT=0,ICNT1=0,JCNT=0,XDRDA=0,PCNT=0
F D D CHEK Q:XDRDA'=0 Q:JCNT'>0
. D GETLIST
. S PCNT=NCNT
. F JCNT=JCNT:0 S JCNT=$O(@TMPGLB@(JCNT)) Q:JCNT'>0 D Q:'(JCNT#4)
. . W !!!,$J(JCNT,5),". ",@TMPGLB@(JCNT,1)
. . W !,?8,@TMPGLB@(JCNT,2)
I XDRDA>0 S XDRDA=+@TMPGLB@(XDRDA) D SHOW
Q
;
CHEK ;
W !
I JCNT'>0 S DIR(0)="N"
E S DIR(0)="NO",DIR("A",1)="Enter Return to continue listing or"
S DIR("A")="Select the desired entry by number"
S DIR(0)=DIR(0)_"^1:"_NCNT
D ^DIR K DIR
I Y>0 S XDRDA=+Y
I $D(DUOUT)!$D(DTOUT) S XDRDA=-1 K DTOUT,DUOUT
K DIRUT
Q
;
SHOW ;
;L +^VA(15,+XDRDA,0):30 I '$T G BUSY
;I $P(^VA(15,+XDRDA,0),U,3)'="P" L -^VA(15,+XDRDA,0) G BUSY ; NOT AVAILABLE
;N XDRXX S XDRXX(15,(+XDRDA)_",",.03)="X"
;D FILE^DIE("","XDRXX")
;L -^VA(15,+XDRDA,0)
I '$D(XDRGLB) N XDRGLB S XDRGLB=$P($P(^VA(15,XDRDA,0),U),";",2)
I $D(@(XDRGLB_(+^VA(15,XDRDA,0))_",-9)"))!$D(@(XDRGLB_(+$P(^VA(15,XDRDA,0),U,2))_",-9)")) W !,$C(7),"One of these entries has already been merged. Pick another pair.",!! D RESET(XDRDA) Q
S XQAID=""
S X=^VA(15,+XDRDA,0)
S X1=+X,X2=+$P(X,U,2)
I $$COUNT^XDRRMRG2(XDRFL,X1,X2)>1 S X1=X2,X2=+X
S XQADATA=XDRDA_U_X1_";"_X2_U_"PRIMARY"_U_XDRFL
D ^XDRRMRG1
; If Primary verifier has set status to DUPLICATE, set STATUS at top level
; to "X" (VERIFICATION IN PROCESS)
S DA=$$FIND1^DIC(15.02,","_XDRDA_",","X","PRIMARY")
I DA>0 D
. S X=$P(^VA(15,XDRDA,0),U,3)
. I X="N"!(X="V") Q
. S X=^VA(15,XDRDA,2,DA,0)
. I $P(X,U,2)="V" D
. . S DR=".03///X;.1///"_DT_";"
. . S DIE="^VA(15,",DA=XDRDA D ^DIE K DIE,DR
. . D SETUP^XDRRMRG1(XDRDA)
. . D CHEKVER^XDRRMRG1
; If PATIENT, status=VERIFIED, NOT A DUPLICATE, add patients to MPI DO NOT LINK file(new with XT*7.3*113)
I XDRFL=2,$P(^VA(15,XDRDA,0),U,3)="N" D
. ;Quit if routine ^MPIFDNL is not loaded
. S X="MPIFDNL" X ^%ZOSF("TEST") Q:'$T
. S X=^VA(15,XDRDA,0)
. D CALLRPC^MPIFDNL(DUZ,DUZ(2),+X,+$P(X,U,2))
Q
;
BUSY ;
W !!,$C(7),"Record is being processed by someone else.",!!
Q
;
FILE(XDRFLAG) ;
; If XDRFLAG=1, option not available to the PATIENT file (#2) (new with XT*7.3*113)
N X,XDRPT,XDRFLNM
S (X,XDRPT)=0
S XDRFLAG=+$G(XDRFLAG)
I XDRFLAG=1 W !,"* This option is not available for PATIENTS"
S XDRFLNM=""
F I=0:0 S I=$O(^VA(15.1,I)) Q:I'>0 D
. I XDRFLAG=1,I=2 S XDRPT=1 Q
. S X=X+1,X(I)=""
. S XDRFLNM=$P($G(^DIC(I,0)),U)
. Q
I X=0 Q -1
I X=1 Q $O(X(""))
S:'XDRFLAG XDRFLNM="PATIENT"
K DIC S DIC=15.1,DIC(0)="AEQM"
S DIC("A")="Which FILE are the potential duplicates in (e.g., "_XDRFLNM_")? "
S DIC("B")=XDRFLNM
I XDRFLAG=1 S DIC("S")="I Y'=2"
D ^DIC K DIC
Q +Y
;
CMORS ; RETURN DATA RANKED BY CMORS (HIGH VALUES FIRST)
I '$D(^VA(15,"ACMORS")) D SETCMOR
I $G(^VA(15,"ACMORS",0))'>0 D SETCMOR
I $G(^VA(15,"ACMORS",0))>0,$$FMDIFF^XLFDT(DT,^(0))>7 D ASKCMOR
I ICNT1>0 S ICNT=ICNT-1
S LCNT=0
F ICNT=ICNT:0 S ICNT=$O(^VA(15,"ACMORS",ICNT)) Q:ICNT'>0 D Q:('(NCNT#4))&(LCNT>0)
. F ICNT1=+ICNT1:0 S ICNT1=$O(^VA(15,"ACMORS",ICNT,ICNT1)) Q:ICNT1'>0 D Q:('(NCNT#4))&(LCNT>0)
. . S X=$G(^VA(15,ICNT1,0)) Q:X="" Q:$P(X,U,3)'="P" S X1=+X,X2=+$P(X,U,2)
. . I $D(@TMPGLA@(X1,X2)) Q
. . S @TMPGLA@(X1,X2)=""
. . S NCNT=NCNT+1,LCNT=LCNT+1
. . S @TMPGLB@(NCNT)=ICNT1_U_X1_U_X2
. . S CMORS1=$P($G(^DPT(X1,"MPI")),U,6),CMORS2=$P($G(^DPT(X2,"MPI")),U,6)
. . S @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)")_" (CMOR SCORE = "_$S(CMORS1="":"NULL",1:CMORS1)_")"
. . S @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)")_" (CMOR SCORE = "_$S(CMORS2="":"NULL",1:CMORS2)_")"
Q
;
SETCMOR ;
N I,X,X1,X2,SCOR
K ^VA(15,"ACMORS")
F I=0:0 S I=$O(^VA(15,I)) Q:I'>0 S X=^(I,0) D
. I $P(X,U,3)'="P" Q
. I $P($P(X,U),";",2)'="DPT(" Q
. S X1=+X,X2=+$P(X,U,2)
. S SCOR=$P($G(^DPT(X1,"MPI")),U,6) I SCOR'>0 S SCOR=0
. S ^VA(15,"ACMORS",(9999999-SCOR),I)=""
. S SCOR=$P($G(^DPT(X2,"MPI")),U,6) I SCOR'>0 S SCOR=0
. S ^VA(15,"ACMORS",(9999999-SCOR),I)=""
S ^VA(15,"ACMORS",0)=DT
Q
;
ASKCMOR ;
N DIR
S DIR(0)="Y",DIR("A")="The CMOR scores for activity haven't been checked recently. Do you want to update these (It might take a couple of minutes)"
S DIR("B")="YES"
D ^DIR I Y>0 D SETCMOR
Q
;
SET1 ; HANDLES SETTING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES
I X'="P" Q
N XDRXVAL,XDRXVAL1
S XDRXVAL=^VA(15,D0,0)
I $P($P(XDRXVAL,U),";",2)'="DPT(" Q
S XDRXVAL1=$P($G(^DPT(+XDRXVAL,"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
S ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)=""
S XDRXVAL1=$P($G(^DPT(+$P(XDRXVAL,U,2),"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
S ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)=""
Q
;
KILL1 ; HANDLES KILLING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES
I X'="P" Q
N XDRXVAL,XDRXVAL1
S XDRXVAL=^VA(15,D0,0)
I $P($P(XDRXVAL,U),";",2)'="DPT(" Q
S XDRXVAL1=+$P($G(^DPT(+XDRXVAL,"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
K ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)
S XDRXVAL1=+$P($G(^DPT(+$P(XDRXVAL,U,2),"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1
K ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)
Q
;
OTHERS ; CHECKS AND MARKS OTHER PAIRS SO ONLY ONE CAN BE PROCESSED AT A TIME
Q ; NOT USED CURRENTLY
;
; P CLEAR ALL RELATED
;
; X MARK ALL RELATED
;
; V CLEAR TO
;
; O NOTHING
;
; R MARK ALL RELATED
;
; MERGED CLEAR TO REALIGN FROM
I X="O" Q
N OLDDA,OLDX S OLDDA=DA,OLDX=X N DA,X
N XDRENTR,IENVAL,XDRPAIR,DONE,XDR0,STATUS,DIREC
I $D(XDROTHER) Q
N XDROTHER S XDROTHER=1
I OLDX="P"!(OLDX="N") D Q
. F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="O" D
. . ; Have to check on whether the other member of the pair in process as well.
. . S XDRPAIR=$P(^VA(15,IENVAL,0),U) IF XDRPAIR=XDRENTR S XDRPAIR=$P(^(0),U,2)
. . S DONE=0 F IENPAIR=0:0 S IENPAIR=$O(^VA(15,"B",XDRPAIR,IENPAIR)) Q:IENPAIR'>0 I IENPAIR'=IENVAL D Q:DONE
. . . S XDR0=^VA(15,IENPAIR,0)
. . . S STATUS=$P(XDR0,U,3)
. . . I STATUS="X"!(STATUS="R") S DONE=1 Q
. . . I STATUS="V" D Q:DONE
. . . . S DIREC=$P(XDR0,U,4)
. . . . I $P(XDR0,U,DIREC)=XDRPAIR S DONE=1 Q ; IT IS THE 'FROM' ENTRY
. . . . Q
. . . Q
. . D RESET(IENVAL)
. . Q
. Q
I OLDX="X"!(OLDX="R") D Q
. F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="P" D
. . N XDRXX S XDRXX(15,IENVAL_",",.03)="O"
. . D FILE^DIE("","XDRXX")
. Q
I OLDX="V"&$D(XDRDADJX) D Q ; IF MERGED (XDRDADJX IS SET IN XDRDAJD AND IS RUN BY A CROSS-REFERENCE FOR MERGE STATUS SET TO 'MERGED')
. F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) D
. . S DIREC=$P(^VA(15,OLDDA,0),U,4)
. . F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="O" D
. . . ; Have to check on whether the other member of the pair in process as well.
. . . S XDRPAIR=$P(^VA(15,IENVAL,0),U) IF XDRPAIR=XDRENTR S XDRPAIR=$P(^(0),U,2)
. . . S DONE=0 F IENPAIR=0:0 S IENPAIR=$O(^VA(15,"B",XDRPAIR,IENPAIR)) Q:IENPAIR'>0 I IENPAIR'=IENVAL D Q:DONE
. . . . S XDR0=^VA(15,IENPAIR,0)
. . . . S STATUS=$P(XDR0,U,3)
. . . . I STATUS="X"!(STATUS="R") S DONE=1 Q
. . . . I STATUS="V" D Q:DONE
. . . . . S DIREC=$P(XDR0,U,4)
. . . . . I $P(XDR0,U,DIREC)=XDRPAIR S DONE=1 Q ; IT IS THE 'FROM' ENTRY
. . . . . Q
. . . . Q
. . . D RESET(IENVAL) ; RESET TO "P"
. . . Q
. . Q
. Q
Q
;
RESET(DA) ;
N XDRXX,IENS,X
I $P(^VA(15,DA,0),U,5)>1 Q
D NAME^XDRDEDT(DA)
S X=^VA(15,DA,0)
S IENS=DA_","
S XDRXX(15,IENS,.03)="P"
I $P(X,U,4)'="" S XDRXX(15,IENS,.04)="@"
I $P(X,U,5)'="" S XDRXX(15,IENS,.05)="@"
I $P(X,U,7)'="" S XDRXX(15,IENS,.07)="@"
I $P(X,U,8)'="" S XDRXX(15,IENS,.08)="@"
I $P(X,U,10)'="" S XDRXX(15,IENS,.1)="@"
I $P(X,U,13)'="" S XDRXX(15,IENS,.13)="@"
I $P(X,U,14)'="" S XDRXX(15,IENS,.14)="@"
D FILE^DIE("","XDRXX")
S:$D(DUZ) $P(^VA(15,DA,0),U,12)=DUZ
K ^VA(15,DA,2)
K ^VA(15,DA,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDPICK 9800 printed Oct 16, 2024@18:39:46 Page 2
XDRDPICK ;SF-IRMFO.SEA/JLI - SELECT A PAIR OF POTENTIAL DUPLICATES AND VIEW ;10/10/08 13:38
+1 ;;7.3;TOOLKIT;**23,47,113**;Apr 25, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
EN ;
+1 NEW XDRFL,CMORS1,CMORS2,D0,DA,DIC,DIE,DIR,ICNT,ICNT1,JCNT,LCNT,NCNT,PNCT,TMPGLA,TMPGLB,XDRDA,XDRFILN,XDRGLB,Y,PRIFILE
+2 ; D EN^XDRVCHEK
+3 SET XDRFL=$$FILE()
if XDRFL'>0
QUIT
SET PRIFILE=XDRFL
SET XDRGLB=$PIECE(^DIC(XDRFL,0,"GL"),U,2)
SET XDRFILN=$PIECE(^DIC(XDRFL,0),U)
LOOP ;
+1 WRITE !!!,"At the following prompt select a POTENTIAL DUPLICATE ENTRY. If a selection"
+2 WRITE !,"is not made, you will be given a chance to select from a list if you"
+3 WRITE !,"want to. Otherwise, you will be returned to the menu system."
+4 WRITE !
+5 SET Y=$$LOOKUP^XDRDEDT(XDRFL)
+6 SET XDRDA=+Y
IF Y>0
DO SHOW
GOTO LOOP
+7 SET DIR(0)="Y"
+8 SET DIR("A")="Do you want to select from a list of potential duplicates"
+9 SET DIR("B")="YES"
+10 DO ^DIR
KILL DIR
if Y'>0
QUIT
+11 SET TMPGLB=$NAME(^TMP("XDRDPICK",$JOB))
SET TMPGLA=$NAME(^TMP("XDRDPICA",$JOB))
+12 KILL @TMPGLB,@TMPGLA
+13 DO ASK
+14 IF XDRDA>0
GOTO LOOP
+15 KILL PCNT
+16 QUIT
+17 ;
GETLIST ;
+1 IF XDRGLB="DPT("
IF $ORDER(^DPT("ACMORS",0))>0
DO CMORS
QUIT
+2 NEW FLG
+3 FOR ICNT=ICNT:0
SET ICNT=$ORDER(^VA(15,ICNT))
if ICNT'>0
QUIT
SET X=^(ICNT,0)
Begin DoDot:1
+4 ;This flag is when NCNT is set from previous call and STATUS is not "P" the first time- - so loop will not quit with (NCNT#4)
SET FLG=1
+5 IF $PIECE(X,U,3)'="P"
if PCNT=NCNT
SET FLG=0
QUIT
+6 IF $PIECE($PIECE(X,U),";",2)'=XDRGLB
QUIT
+7 SET NCNT=NCNT+1
SET X1=+$PIECE(X,U)
SET X2=+$PIECE(X,U,2)
+8 IF '($DATA(@(U_XDRGLB_X1_",0)"))#2)!'($DATA(@(U_XDRGLB_X2_",0)"))#2)
SET NCNT=NCNT-1
QUIT
+9 SET @TMPGLB@(NCNT)=ICNT_U_X1_U_X2
+10 SET @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)")
+11 SET @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)")
End DoDot:1
if '(NCNT#4)&(NCNT>0)&FLG
QUIT
+12 QUIT
+13 ;
ASK ;
+1 SET NCNT=0
SET ICNT=0
SET ICNT1=0
SET JCNT=0
SET XDRDA=0
SET PCNT=0
+2 FOR
Begin DoDot:1
+3 DO GETLIST
+4 SET PCNT=NCNT
+5 FOR JCNT=JCNT:0
SET JCNT=$ORDER(@TMPGLB@(JCNT))
if JCNT'>0
QUIT
Begin DoDot:2
+6 WRITE !!!,$JUSTIFY(JCNT,5),". ",@TMPGLB@(JCNT,1)
+7 WRITE !,?8,@TMPGLB@(JCNT,2)
End DoDot:2
if '(JCNT#4)
QUIT
End DoDot:1
DO CHEK
if XDRDA'=0
QUIT
if JCNT'>0
QUIT
+8 IF XDRDA>0
SET XDRDA=+@TMPGLB@(XDRDA)
DO SHOW
+9 QUIT
+10 ;
CHEK ;
+1 WRITE !
+2 IF JCNT'>0
SET DIR(0)="N"
+3 IF '$TEST
SET DIR(0)="NO"
SET DIR("A",1)="Enter Return to continue listing or"
+4 SET DIR("A")="Select the desired entry by number"
+5 SET DIR(0)=DIR(0)_"^1:"_NCNT
+6 DO ^DIR
KILL DIR
+7 IF Y>0
SET XDRDA=+Y
+8 IF $DATA(DUOUT)!$DATA(DTOUT)
SET XDRDA=-1
KILL DTOUT,DUOUT
+9 KILL DIRUT
+10 QUIT
+11 ;
SHOW ;
+1 ;L +^VA(15,+XDRDA,0):30 I '$T G BUSY
+2 ;I $P(^VA(15,+XDRDA,0),U,3)'="P" L -^VA(15,+XDRDA,0) G BUSY ; NOT AVAILABLE
+3 ;N XDRXX S XDRXX(15,(+XDRDA)_",",.03)="X"
+4 ;D FILE^DIE("","XDRXX")
+5 ;L -^VA(15,+XDRDA,0)
+6 IF '$DATA(XDRGLB)
NEW XDRGLB
SET XDRGLB=$PIECE($PIECE(^VA(15,XDRDA,0),U),";",2)
+7 IF $DATA(@(XDRGLB_(+^VA(15,XDRDA,0))_",-9)"))!$DATA(@(XDRGLB_(+$PIECE(^VA(15,XDRDA,0),U,2))_",-9)"))
WRITE !,$CHAR(7),"One of these entries has already been merged. Pick another pair.",!!
DO RESET(XDRDA)
QUIT
+8 SET XQAID=""
+9 SET X=^VA(15,+XDRDA,0)
+10 SET X1=+X
SET X2=+$PIECE(X,U,2)
+11 IF $$COUNT^XDRRMRG2(XDRFL,X1,X2)>1
SET X1=X2
SET X2=+X
+12 SET XQADATA=XDRDA_U_X1_";"_X2_U_"PRIMARY"_U_XDRFL
+13 DO ^XDRRMRG1
+14 ; If Primary verifier has set status to DUPLICATE, set STATUS at top level
+15 ; to "X" (VERIFICATION IN PROCESS)
+16 SET DA=$$FIND1^DIC(15.02,","_XDRDA_",","X","PRIMARY")
+17 IF DA>0
Begin DoDot:1
+18 SET X=$PIECE(^VA(15,XDRDA,0),U,3)
+19 IF X="N"!(X="V")
QUIT
+20 SET X=^VA(15,XDRDA,2,DA,0)
+21 IF $PIECE(X,U,2)="V"
Begin DoDot:2
+22 SET DR=".03///X;.1///"_DT_";"
+23 SET DIE="^VA(15,"
SET DA=XDRDA
DO ^DIE
KILL DIE,DR
+24 DO SETUP^XDRRMRG1(XDRDA)
+25 DO CHEKVER^XDRRMRG1
End DoDot:2
End DoDot:1
+26 ; If PATIENT, status=VERIFIED, NOT A DUPLICATE, add patients to MPI DO NOT LINK file(new with XT*7.3*113)
+27 IF XDRFL=2
IF $PIECE(^VA(15,XDRDA,0),U,3)="N"
Begin DoDot:1
+28 ;Quit if routine ^MPIFDNL is not loaded
+29 SET X="MPIFDNL"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+30 SET X=^VA(15,XDRDA,0)
+31 DO CALLRPC^MPIFDNL(DUZ,DUZ(2),+X,+$PIECE(X,U,2))
End DoDot:1
+32 QUIT
+33 ;
BUSY ;
+1 WRITE !!,$CHAR(7),"Record is being processed by someone else.",!!
+2 QUIT
+3 ;
FILE(XDRFLAG) ;
+1 ; If XDRFLAG=1, option not available to the PATIENT file (#2) (new with XT*7.3*113)
+2 NEW X,XDRPT,XDRFLNM
+3 SET (X,XDRPT)=0
+4 SET XDRFLAG=+$GET(XDRFLAG)
+5 IF XDRFLAG=1
WRITE !,"* This option is not available for PATIENTS"
+6 SET XDRFLNM=""
+7 FOR I=0:0
SET I=$ORDER(^VA(15.1,I))
if I'>0
QUIT
Begin DoDot:1
+8 IF XDRFLAG=1
IF I=2
SET XDRPT=1
QUIT
+9 SET X=X+1
SET X(I)=""
+10 SET XDRFLNM=$PIECE($GET(^DIC(I,0)),U)
+11 QUIT
End DoDot:1
+12 IF X=0
QUIT -1
+13 IF X=1
QUIT $ORDER(X(""))
+14 if 'XDRFLAG
SET XDRFLNM="PATIENT"
+15 KILL DIC
SET DIC=15.1
SET DIC(0)="AEQM"
+16 SET DIC("A")="Which FILE are the potential duplicates in (e.g., "_XDRFLNM_")? "
+17 SET DIC("B")=XDRFLNM
+18 IF XDRFLAG=1
SET DIC("S")="I Y'=2"
+19 DO ^DIC
KILL DIC
+20 QUIT +Y
+21 ;
CMORS ; RETURN DATA RANKED BY CMORS (HIGH VALUES FIRST)
+1 IF '$DATA(^VA(15,"ACMORS"))
DO SETCMOR
+2 IF $GET(^VA(15,"ACMORS",0))'>0
DO SETCMOR
+3 IF $GET(^VA(15,"ACMORS",0))>0
IF $$FMDIFF^XLFDT(DT,^(0))>7
DO ASKCMOR
+4 IF ICNT1>0
SET ICNT=ICNT-1
+5 SET LCNT=0
+6 FOR ICNT=ICNT:0
SET ICNT=$ORDER(^VA(15,"ACMORS",ICNT))
if ICNT'>0
QUIT
Begin DoDot:1
+7 FOR ICNT1=+ICNT1:0
SET ICNT1=$ORDER(^VA(15,"ACMORS",ICNT,ICNT1))
if ICNT1'>0
QUIT
Begin DoDot:2
+8 SET X=$GET(^VA(15,ICNT1,0))
if X=""
QUIT
if $PIECE(X,U,3)'="P"
QUIT
SET X1=+X
SET X2=+$PIECE(X,U,2)
+9 IF $DATA(@TMPGLA@(X1,X2))
QUIT
+10 SET @TMPGLA@(X1,X2)=""
+11 SET NCNT=NCNT+1
SET LCNT=LCNT+1
+12 SET @TMPGLB@(NCNT)=ICNT1_U_X1_U_X2
+13 SET CMORS1=$PIECE($GET(^DPT(X1,"MPI")),U,6)
SET CMORS2=$PIECE($GET(^DPT(X2,"MPI")),U,6)
+14 SET @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)")_" (CMOR SCORE = "_$SELECT(CMORS1="":"NULL",1:CMORS1)_")"
+15 SET @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)")_" (CMOR SCORE = "_$SELECT(CMORS2="":"NULL",1:CMORS2)_")"
End DoDot:2
if ('(NCNT#4))&(LCNT>0)
QUIT
End DoDot:1
if ('(NCNT#4))&(LCNT>0)
QUIT
+16 QUIT
+17 ;
SETCMOR ;
+1 NEW I,X,X1,X2,SCOR
+2 KILL ^VA(15,"ACMORS")
+3 FOR I=0:0
SET I=$ORDER(^VA(15,I))
if I'>0
QUIT
SET X=^(I,0)
Begin DoDot:1
+4 IF $PIECE(X,U,3)'="P"
QUIT
+5 IF $PIECE($PIECE(X,U),";",2)'="DPT("
QUIT
+6 SET X1=+X
SET X2=+$PIECE(X,U,2)
+7 SET SCOR=$PIECE($GET(^DPT(X1,"MPI")),U,6)
IF SCOR'>0
SET SCOR=0
+8 SET ^VA(15,"ACMORS",(9999999-SCOR),I)=""
+9 SET SCOR=$PIECE($GET(^DPT(X2,"MPI")),U,6)
IF SCOR'>0
SET SCOR=0
+10 SET ^VA(15,"ACMORS",(9999999-SCOR),I)=""
End DoDot:1
+11 SET ^VA(15,"ACMORS",0)=DT
+12 QUIT
+13 ;
ASKCMOR ;
+1 NEW DIR
+2 SET DIR(0)="Y"
SET DIR("A")="The CMOR scores for activity haven't been checked recently. Do you want to update these (It might take a couple of minutes)"
+3 SET DIR("B")="YES"
+4 DO ^DIR
IF Y>0
DO SETCMOR
+5 QUIT
+6 ;
SET1 ; HANDLES SETTING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES
+1 IF X'="P"
QUIT
+2 NEW XDRXVAL,XDRXVAL1
+3 SET XDRXVAL=^VA(15,D0,0)
+4 IF $PIECE($PIECE(XDRXVAL,U),";",2)'="DPT("
QUIT
+5 SET XDRXVAL1=$PIECE($GET(^DPT(+XDRXVAL,"MPI")),U,6)
IF XDRXVAL1=""
SET XDRXVAL1=-1
+6 SET ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)=""
+7 SET XDRXVAL1=$PIECE($GET(^DPT(+$PIECE(XDRXVAL,U,2),"MPI")),U,6)
IF XDRXVAL1=""
SET XDRXVAL1=-1
+8 SET ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)=""
+9 QUIT
+10 ;
KILL1 ; HANDLES KILLING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES
+1 IF X'="P"
QUIT
+2 NEW XDRXVAL,XDRXVAL1
+3 SET XDRXVAL=^VA(15,D0,0)
+4 IF $PIECE($PIECE(XDRXVAL,U),";",2)'="DPT("
QUIT
+5 SET XDRXVAL1=+$PIECE($GET(^DPT(+XDRXVAL,"MPI")),U,6)
IF XDRXVAL1=""
SET XDRXVAL1=-1
+6 KILL ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)
+7 SET XDRXVAL1=+$PIECE($GET(^DPT(+$PIECE(XDRXVAL,U,2),"MPI")),U,6)
IF XDRXVAL1=""
SET XDRXVAL1=-1
+8 KILL ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)
+9 QUIT
+10 ;
OTHERS ; CHECKS AND MARKS OTHER PAIRS SO ONLY ONE CAN BE PROCESSED AT A TIME
+1 ; NOT USED CURRENTLY
QUIT
+2 ;
+3 ; P CLEAR ALL RELATED
+4 ;
+5 ; X MARK ALL RELATED
+6 ;
+7 ; V CLEAR TO
+8 ;
+9 ; O NOTHING
+10 ;
+11 ; R MARK ALL RELATED
+12 ;
+13 ; MERGED CLEAR TO REALIGN FROM
+14 IF X="O"
QUIT
+15 NEW OLDDA,OLDX
SET OLDDA=DA
SET OLDX=X
NEW DA,X
+16 NEW XDRENTR,IENVAL,XDRPAIR,DONE,XDR0,STATUS,DIREC
+17 IF $DATA(XDROTHER)
QUIT
+18 NEW XDROTHER
SET XDROTHER=1
+19 IF OLDX="P"!(OLDX="N")
Begin DoDot:1
+20 FOR XDRENTR=$PIECE(^VA(15,OLDDA,0),U),$PIECE(^VA(15,OLDDA,0),U,2)
FOR IENVAL=0:0
SET IENVAL=$ORDER(^VA(15,"B",XDRENTR,IENVAL))
if IENVAL'>0
QUIT
IF IENVAL'=OLDDA
IF $PIECE(^VA(15,IENVAL,0),U,3)="O"
Begin DoDot:2
+21 ; Have to check on whether the other member of the pair in process as well.
+22 SET XDRPAIR=$PIECE(^VA(15,IENVAL,0),U)
IF XDRPAIR=XDRENTR
SET XDRPAIR=$PIECE(^(0),U,2)
+23 SET DONE=0
FOR IENPAIR=0:0
SET IENPAIR=$ORDER(^VA(15,"B",XDRPAIR,IENPAIR))
if IENPAIR'>0
QUIT
IF IENPAIR'=IENVAL
Begin DoDot:3
+24 SET XDR0=^VA(15,IENPAIR,0)
+25 SET STATUS=$PIECE(XDR0,U,3)
+26 IF STATUS="X"!(STATUS="R")
SET DONE=1
QUIT
+27 IF STATUS="V"
Begin DoDot:4
+28 SET DIREC=$PIECE(XDR0,U,4)
+29 ; IT IS THE 'FROM' ENTRY
IF $PIECE(XDR0,U,DIREC)=XDRPAIR
SET DONE=1
QUIT
+30 QUIT
End DoDot:4
if DONE
QUIT
+31 QUIT
End DoDot:3
if DONE
QUIT
+32 DO RESET(IENVAL)
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
QUIT
+35 IF OLDX="X"!(OLDX="R")
Begin DoDot:1
+36 FOR XDRENTR=$PIECE(^VA(15,OLDDA,0),U),$PIECE(^VA(15,OLDDA,0),U,2)
FOR IENVAL=0:0
SET IENVAL=$ORDER(^VA(15,"B",XDRENTR,IENVAL))
if IENVAL'>0
QUIT
IF IENVAL'=OLDDA
IF $PIECE(^VA(15,IENVAL,0),U,3)="P"
Begin DoDot:2
+37 NEW XDRXX
SET XDRXX(15,IENVAL_",",.03)="O"
+38 DO FILE^DIE("","XDRXX")
End DoDot:2
+39 QUIT
End DoDot:1
QUIT
+40 ; IF MERGED (XDRDADJX IS SET IN XDRDAJD AND IS RUN BY A CROSS-REFERENCE FOR MERGE STATUS SET TO 'MERGED')
IF OLDX="V"&$DATA(XDRDADJX)
Begin DoDot:1
+41 FOR XDRENTR=$PIECE(^VA(15,OLDDA,0),U),$PIECE(^VA(15,OLDDA,0),U,2)
Begin DoDot:2
+42 SET DIREC=$PIECE(^VA(15,OLDDA,0),U,4)
+43 FOR IENVAL=0:0
SET IENVAL=$ORDER(^VA(15,"B",XDRENTR,IENVAL))
if IENVAL'>0
QUIT
IF IENVAL'=OLDDA
IF $PIECE(^VA(15,IENVAL,0),U,3)="O"
Begin DoDot:3
+44 ; Have to check on whether the other member of the pair in process as well.
+45 SET XDRPAIR=$PIECE(^VA(15,IENVAL,0),U)
IF XDRPAIR=XDRENTR
SET XDRPAIR=$PIECE(^(0),U,2)
+46 SET DONE=0
FOR IENPAIR=0:0
SET IENPAIR=$ORDER(^VA(15,"B",XDRPAIR,IENPAIR))
if IENPAIR'>0
QUIT
IF IENPAIR'=IENVAL
Begin DoDot:4
+47 SET XDR0=^VA(15,IENPAIR,0)
+48 SET STATUS=$PIECE(XDR0,U,3)
+49 IF STATUS="X"!(STATUS="R")
SET DONE=1
QUIT
+50 IF STATUS="V"
Begin DoDot:5
+51 SET DIREC=$PIECE(XDR0,U,4)
+52 ; IT IS THE 'FROM' ENTRY
IF $PIECE(XDR0,U,DIREC)=XDRPAIR
SET DONE=1
QUIT
+53 QUIT
End DoDot:5
if DONE
QUIT
+54 QUIT
End DoDot:4
if DONE
QUIT
+55 ; RESET TO "P"
DO RESET(IENVAL)
+56 QUIT
End DoDot:3
+57 QUIT
End DoDot:2
+58 QUIT
End DoDot:1
QUIT
+59 QUIT
+60 ;
RESET(DA) ;
+1 NEW XDRXX,IENS,X
+2 IF $PIECE(^VA(15,DA,0),U,5)>1
QUIT
+3 DO NAME^XDRDEDT(DA)
+4 SET X=^VA(15,DA,0)
+5 SET IENS=DA_","
+6 SET XDRXX(15,IENS,.03)="P"
+7 IF $PIECE(X,U,4)'=""
SET XDRXX(15,IENS,.04)="@"
+8 IF $PIECE(X,U,5)'=""
SET XDRXX(15,IENS,.05)="@"
+9 IF $PIECE(X,U,7)'=""
SET XDRXX(15,IENS,.07)="@"
+10 IF $PIECE(X,U,8)'=""
SET XDRXX(15,IENS,.08)="@"
+11 IF $PIECE(X,U,10)'=""
SET XDRXX(15,IENS,.1)="@"
+12 IF $PIECE(X,U,13)'=""
SET XDRXX(15,IENS,.13)="@"
+13 IF $PIECE(X,U,14)'=""
SET XDRXX(15,IENS,.14)="@"
+14 DO FILE^DIE("","XDRXX")
+15 if $DATA(DUZ)
SET $PIECE(^VA(15,DA,0),U,12)=DUZ
+16 KILL ^VA(15,DA,2)
+17 KILL ^VA(15,DA,3)
+18 QUIT
