DPTDCAN.m

DPTDCAN ; IHS/TUCSON/JCM - GETS POSSIBLE DUPLICATE CANDIDATES ; [ 09/10/2001  8:24 AM ]

 ;;1.0;PATIENT MERGE;;FEB 02, 1994

 ;

 ; Calls: EN^DIQ1

 ;

START ;

 K ^TMP("XDRD",$J,XDRFL),DPTDCAN

 ;

 ;

 ;---> BEGIN CHANGES 9/9/2001.

 ;---> Quit if patient does not exist. ;Mike Remillard, 9/9/2001

 ;---> Next line $D added.

 Q:'$D(^DPT(XDRCD,0))

 ;---> END CHANGES 9/9/2001.

 ;

 ;

 Q:$P(^DPT(XDRCD,0),U,19)

 D VALUE

 D NAME

 D SSN

 D DOB

END D EOJ

 Q

 ;

VALUE ;

 S DIC=2,DA=XDRCD,DIQ(0)="I",DIQ="DPTDCAN",DR=".01;.03;.09"

 D EN^DIQ1 K DIC,DA,DR,DIQ

 Q

 ;

NAME ;

 I XDRFL=2 Q:'$D(^DPT(XDRCD,0))  ;IHS/ANMC/LJF 9/10/01 to prevent undef when entry doesn't exist

 G:DPTDCAN(XDRFL,XDRCD,.01,"I")']"" NAMEX

 S DPTDCAN("NAME")=DPTDCAN(XDRFL,XDRCD,.01,"I")

 S DPTDCAN("LNAME&FI")=$P(DPTDCAN("NAME"),",",1)_","_$E($P(DPTDCAN("NAME"),",",2),1)_"AAA"

 S DPTDCAN("BNAME")=DPTDCAN("LNAME&FI")

 F I=0:0 S DPTDCAN("BNAME")=$O(^DPT("B",DPTDCAN("BNAME"))) Q:DPTDCAN("BNAME")=""!(($P(DPTDCAN("NAME"),",",1)_","_$E($P(DPTDCAN("NAME"),",",2),1))'=($P(DPTDCAN("BNAME"),",",1)_","_$E($P(DPTDCAN("BNAME"),",",2),1)))  D

 . S DPTDCAN("BNAMEDFN")=0 F  S DPTDCAN("BNAMEDFN")=$O(^DPT("B",DPTDCAN("BNAME"),DPTDCAN("BNAMEDFN"))) Q:DPTDCAN("BNAMEDFN")=""  S:DPTDCAN("BNAMEDFN")'=XDRCD ^TMP("XDRD",$J,XDRFL,DPTDCAN("BNAMEDFN"))=""

 . Q

NAMEX Q

 ;

SSN ;Get patients with same last four digits of ssn

 G:DPTDCAN(XDRFL,XDRCD,.09,"I")']"" SSNX

 S DPTDCAN("SSN")=DPTDCAN(XDRFL,XDRCD,.09,"I")

 S DPTDCAN("L4SSN")=$E(DPTDCAN("SSN"),6,9)

 S DPTDCAN("BL4SSN")=XDRCD

 F %=0:0 S DPTDCAN("BL4SSN")=$O(^DPT("BS",DPTDCAN("L4SSN"),DPTDCAN("BL4SSN"))) Q:'DPTDCAN("BL4SSN")  S ^TMP("XDRD",$J,XDRFL,DPTDCAN("BL4SSN"))=""

 ;

 ; Check SSNS with same first five digits

 ; Commented out the following line, is not specific enough for IHS

 ; but would be useful for the VA

 ;

 ;S DPTDCAN("F5SSN")=$E(DPTDCAN("SSN"),1,5)_"0000",DPTDCAN("5SSN")=DPTDCAN("F5SSN") D  

 . F %=0:0 S DPTDCAN("5SSN")=$O(^DPT("SSN",DPTDCAN("5SSN"))) Q:DPTDCAN("5SSN")'=+DPTDCAN("5SSN")!($E(DPTDCAN("5SSN"),1,5)'=$E(DPTDCAN("SSN"),1,5))  S ^TMP("DPTDCAN",$J,XDRFL,$O(^DPT("SSN",DPTDCAN("5SSN"),"")))=""

 . Q

SSNX Q

 ;

DOB ;Get patients with same date of birth

 G:DPTDCAN(XDRFL,XDRCD,.03,"I")']"" DOBX

 S DPTDCAN("DOB")=DPTDCAN(XDRFL,XDRCD,.03,"I")

 S DPTDCAN("BDOB")=XDRCD

 F %=0:0 S DPTDCAN("BDOB")=$O(^DPT("ADOB",DPTDCAN("DOB"),DPTDCAN("BDOB"))) Q:'DPTDCAN("BDOB")  S ^TMP("XDRD",$J,XDRFL,DPTDCAN("BDOB"))=""

 ;

 ;Transpose day of birth and get patients with same date of birth

 ;

 S DPTDCAN("TDOB")=$E(DPTDCAN("DOB"),1,5)_$E(DPTDCAN("DOB"),7)_$E(DPTDCAN("DOB"),6)

 S DPTDCAN("BDOB")=XDRCD

 F %=0:0 S DPTDCAN("BDOB")=$O(^DPT("ADOB",DPTDCAN("TDOB"),DPTDCAN("BDOB"))) Q:'DPTDCAN("BDOB")  S ^TMP("XDRD",$J,XDRFL,DPTDCAN("BDOB"))=""

DOBX Q

 ;

EOJ ;

 K DPTDCAN,%

 Q

DPTDCAN   ; IHS/TUCSON/JCM - GETS POSSIBLE DUPLICATE CANDIDATES ; [ 09/10/2001  8:24 AM ]

 +1       ;;1.0;PATIENT MERGE;;FEB 02, 1994

 +2       ;

 +3       ; Calls: EN^DIQ1

 +4       ;

START     ;

 +1        KILL ^TMP("XDRD",$JOB,XDRFL),DPTDCAN

 +2       ;

 +3       ;

 +4       ;---> BEGIN CHANGES 9/9/2001.

 +5       ;---> Quit if patient does not exist. ;Mike Remillard, 9/9/2001

 +6       ;---> Next line $D added.

 +7        IF '$DATA(^DPT(XDRCD,0))

               QUIT 

 +8       ;---> END CHANGES 9/9/2001.

 +9       ;

 +10      ;

 +11       IF $PIECE(^DPT(XDRCD,0),U,19)

               QUIT 

 +12       DO VALUE

 +13       DO NAME

 +14       DO SSN

 +15       DO DOB

END        DO EOJ

 +1        QUIT 

 +2       ;

VALUE     ;

 +1        SET DIC=2

           SET DA=XDRCD

           SET DIQ(0)="I"

           SET DIQ="DPTDCAN"

           SET DR=".01;.03;.09"

 +2        DO EN^DIQ1

           KILL DIC,DA,DR,DIQ

 +3        QUIT 

 +4       ;

NAME      ;

 +1       ;IHS/ANMC/LJF 9/10/01 to prevent undef when entry doesn't exist

           IF XDRFL=2

               IF '$DATA(^DPT(XDRCD,0))

                   QUIT 

 +2        IF DPTDCAN(XDRFL,XDRCD,.01,"I")']""

               GOTO NAMEX

 +3        SET DPTDCAN("NAME")=DPTDCAN(XDRFL,XDRCD,.01,"I")

 +4        SET DPTDCAN("LNAME&FI")=$PIECE(DPTDCAN("NAME"),",",1)_","_$EXTRACT($PIECE(DPTDCAN("NAME"),",",2),1)_"AAA"

 +5        SET DPTDCAN("BNAME")=DPTDCAN("LNAME&FI")

 +6        FOR I=0:0

               SET DPTDCAN("BNAME")=$ORDER(^DPT("B",DPTDCAN("BNAME")))

               IF DPTDCAN("BNAME")=""!(($PIECE(DPTDCAN("NAME"),",",1)_","_$EXTRACT($PIECE(DPTDCAN("NAME"),",",2),1))'=($PIECE(DPTDCAN("BNAME"),",",1)_","_$EXTRACT($PIECE(DPTDCAN("BNAME"),",",2),1)))

                   QUIT 

               Begin DoDot:1

 +7                SET DPTDCAN("BNAMEDFN")=0

                   FOR 

                       SET DPTDCAN("BNAMEDFN")=$ORDER(^DPT("B",DPTDCAN("BNAME"),DPTDCAN("BNAMEDFN")))

                       IF DPTDCAN("BNAMEDFN")=""

                           QUIT 

                       IF DPTDCAN("BNAMEDFN")'=XDRCD

                           SET ^TMP("XDRD",$JOB,XDRFL,DPTDCAN("BNAMEDFN"))=""

 +8                QUIT 

               End DoDot:1

NAMEX      QUIT 

 +1       ;

SSN       ;Get patients with same last four digits of ssn

 +1        IF DPTDCAN(XDRFL,XDRCD,.09,"I")']""

               GOTO SSNX

 +2        SET DPTDCAN("SSN")=DPTDCAN(XDRFL,XDRCD,.09,"I")

 +3        SET DPTDCAN("L4SSN")=$EXTRACT(DPTDCAN("SSN"),6,9)

 +4        SET DPTDCAN("BL4SSN")=XDRCD

 +5        FOR %=0:0

               SET DPTDCAN("BL4SSN")=$ORDER(^DPT("BS",DPTDCAN("L4SSN"),DPTDCAN("BL4SSN")))

               IF 'DPTDCAN("BL4SSN")

                   QUIT 

               SET ^TMP("XDRD",$JOB,XDRFL,DPTDCAN("BL4SSN"))=""

 +6       ;

 +7       ; Check SSNS with same first five digits

 +8       ; Commented out the following line, is not specific enough for IHS

 +9       ; but would be useful for the VA

 +10      ;

 +11      ;S DPTDCAN("F5SSN")=$E(DPTDCAN("SSN"),1,5)_"0000",DPTDCAN("5SSN")=DPTDCAN("F5SSN") D  

 +12 

*** ERROR ***

 +13 

*** ERROR ***

SSNX       QUIT 

 +1       ;

DOB       ;Get patients with same date of birth

 +1        IF DPTDCAN(XDRFL,XDRCD,.03,"I")']""

               GOTO DOBX

 +2        SET DPTDCAN("DOB")=DPTDCAN(XDRFL,XDRCD,.03,"I")

 +3        SET DPTDCAN("BDOB")=XDRCD

 +4        FOR %=0:0

               SET DPTDCAN("BDOB")=$ORDER(^DPT("ADOB",DPTDCAN("DOB"),DPTDCAN("BDOB")))

               IF 'DPTDCAN("BDOB")

                   QUIT 

               SET ^TMP("XDRD",$JOB,XDRFL,DPTDCAN("BDOB"))=""

 +5       ;

 +6       ;Transpose day of birth and get patients with same date of birth

 +7       ;

 +8        SET DPTDCAN("TDOB")=$EXTRACT(DPTDCAN("DOB"),1,5)_$EXTRACT(DPTDCAN("DOB"),7)_$EXTRACT(DPTDCAN("DOB"),6)

 +9        SET DPTDCAN("BDOB")=XDRCD

 +10       FOR %=0:0

               SET DPTDCAN("BDOB")=$ORDER(^DPT("ADOB",DPTDCAN("TDOB"),DPTDCAN("BDOB")))

               IF 'DPTDCAN("BDOB")

                   QUIT 

               SET ^TMP("XDRD",$JOB,XDRFL,DPTDCAN("BDOB"))=""

DOBX       QUIT 

 +1       ;

EOJ       ;

 +1        KILL DPTDCAN,%

 +2        QUIT