- 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 ---[H[J[2J[HXDRRMRG1 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