Routine: XDRPTCAN

XDRPTCAN ;SF-IRMFO/IHS/OHPRD/JCM/JLI ;5/30/97  10:28

 ;;7.3;TOOLKIT;**23**;Apr 25, 1995

;;

 ; Calls: EN^DIQ1

START ;

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

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

 D VALUE

 I $E(XDRDCAN(2,XDRCD,.09,"I"),1,5)="00000" Q

 D NAME

 D SSN

 D DOB

END D EOJ

VALUE ;

 S DA=XDRCD K XDRCD S XDRCD=DA

 N XDRI F XDRI=0:0 S XDRI=$O(XDRDSCOR("DR",XDRI)) Q:XDRI'>0  D

 . S DIC=XDRI,DA=XDRCD,DIQ(0)="I",DIQ="XDRDCAN",DR=XDRDSCOR("DR",XDRI)

 . D EN^DIQ1 K DIC,DR,DIQ

 . M XDRCD=XDRDCAN K DA

NAME ;

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

 F  Q:XDRDCAN(XDRFL,XDRCD,.01,"I")'["MERGING INTO"  S XDRDCAN(XDRFL,XDRCD,.01,"I")=$P(XDRDCAN(XDRFL,XDRCD,.01,"I"),"(",2,99),XDRDCAN(XDRFL,XDRCD,.01,"I")=$E(XDRDCAN(XDRFL,XDRCD,.01,"I"),1,$L(XDRDCAN(XDRFL,XDRCD,.01,"I"))-1)

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

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

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

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

 . S XDRDCAN("FIND")=XDRCD

 . F  S XDRDCAN("FIND")=$O(^DPT("B",XDRDCAN("BNAME"),XDRDCAN("FIND"))) Q:XDRDCAN("FIND")'>0  S ^TMP("XDRD",$J,XDRFL,XDRDCAN("FIND"))=""

 . ;S:$O(^DPT("B",XDRDCAN("BNAME"),""))'=XDRCD ^TMP("XDRD",$J,XDRFL,$O(^DPT("B",XDRDCAN("BNAME"),"")))=""

. Q

NAMEX Q

SSN ;Get patients with same last four digits of ssn

 I XDRDCAN(XDRFL,XDRCD,.09,"I")']"" S ^XTMP("XDRERR","BADSSN",XDRCD)="" G SSNX

 I XDRDCAN(XDRFL,XDRCD,.09,"I")'?9N.E S ^XTMP("XDRERR","BADSSN",XDRCD)="" G SSNX

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

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

 S XDRDCAN("BL4SSN")=XDRCD

 F %=0:0 S XDRDCAN("BL4SSN")=$O(^DPT("BS",XDRDCAN("L4SSN"),XDRDCAN("BL4SSN"))) Q:'XDRDCAN("BL4SSN")  S ^TMP("XDRD",$J,XDRFL,XDRDCAN("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 XDRDCAN("F5SSN")=$E(XDRDCAN("SSN"),1,5)_"0000",XDRDCAN("5SSN")=XDRDCAN("F5SSN") D

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

 ;. Q

SSNX Q

DOB ;Get patients with same date of birth

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

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

 S XDRDCAN("BDOB")=XDRCD

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

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

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

 S XDRDCAN("BDOB")=XDRCD

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

DOBX Q

EOJ ;

 K XDRDCAN,%

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRPTCAN   3116     printed  Feb 19, 2025@00:06:08                                                                                                                                                                                                    Page 2

XDRPTCAN  ;SF-IRMFO/IHS/OHPRD/JCM/JLI ;5/30/97  10:28

 +1       ;;7.3;TOOLKIT;**23**;Apr 25, 1995

 +2       ;;

 +3       ;

 +4       ; Calls: EN^DIQ1

 +5       ;

START     ;

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

 +2        if $PIECE(^DPT(XDRCD,0),U,19)

               QUIT

 +3        DO VALUE

 +4        IF $EXTRACT(XDRDCAN(2,XDRCD,.09,"I"),1,5)="00000"

               QUIT

 +5        DO NAME

 +6        DO SSN

 +7        DO DOB

END        DO EOJ

 +1        QUIT

 +2       ;

VALUE     ;

 +1        SET DA=XDRCD

           KILL XDRCD

           SET XDRCD=DA

 +2        NEW XDRI

           FOR XDRI=0:0

               SET XDRI=$ORDER(XDRDSCOR("DR",XDRI))

               if XDRI'>0

                   QUIT

               Begin DoDot:1

 +3                SET DIC=XDRI

                   SET DA=XDRCD

                   SET DIQ(0)="I"

                   SET DIQ="XDRDCAN"

                   SET DR=XDRDSCOR("DR",XDRI)

 +4                DO EN^DIQ1

                   KILL DIC,DR,DIQ

 +5                MERGE XDRCD=XDRDCAN

                   KILL DA

               End DoDot:1

 +6        QUIT

 +7       ;

NAME      ;

 +1        if XDRDCAN(XDRFL,XDRCD,.01,"I")']""

               GOTO NAMEX

 +2        FOR

               if XDRDCAN(XDRFL,XDRCD,.01,"I")'["MERGING INTO"

                   QUIT

               SET XDRDCAN(XDRFL,XDRCD,.01,"I")=$PIECE(XDRDCAN(XDRFL,XDRCD,.01,"I"),"(",2,99)

               SET XDRDCAN(XDRFL,XDRCD,.01,"I")=$EXTRACT(XDRDCAN(XDRFL,XDRCD,.01,"I"),1,$LENGTH(XDRDCAN(XDRFL,XDRCD,.01,"I"))-1)

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

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

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

 +6        FOR I=0:0

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

               if XDRDCAN("BNAME")=""!(($PIECE(XDRDCAN("NAME"),",",1)_","_$EXTRACT($PIECE(XDRDCAN("NAME"),",",2),1))'=($PIECE(XDRDCAN("BNAME"),",",1)_","_$EXTRACT($PIECE(XDRDCAN("BNAME"),",",2),1)))

                   QUIT

               Begin DoDot:1

 +7                SET XDRDCAN("FIND")=XDRCD

 +8                FOR

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

                       if XDRDCAN("FIND")'>0

                           QUIT

                       SET ^TMP("XDRD",$JOB,XDRFL,XDRDCAN("FIND"))=""

 +9       ;S:$O(^DPT("B",XDRDCAN("BNAME"),""))'=XDRCD ^TMP("XDRD",$J,XDRFL,$O(^DPT("B",XDRDCAN("BNAME"),"")))=""

 +10               QUIT

               End DoDot:1

NAMEX      QUIT

 +1       ;

SSN       ;Get patients with same last four digits of ssn

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

               SET ^XTMP("XDRERR","BADSSN",XDRCD)=""

               GOTO SSNX

 +2        IF XDRDCAN(XDRFL,XDRCD,.09,"I")'?9N.E

               SET ^XTMP("XDRERR","BADSSN",XDRCD)=""

               GOTO SSNX

 +3        SET XDRDCAN("SSN")=XDRDCAN(XDRFL,XDRCD,.09,"I")

 +4        SET XDRDCAN("L4SSN")=$EXTRACT(XDRDCAN("SSN"),6,9)

 +5        SET XDRDCAN("BL4SSN")=XDRCD

 +6        FOR %=0:0

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

               if 'XDRDCAN("BL4SSN")

                   QUIT

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

 +7       ;

 +8       ; Check SSNS with same first five digits

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

 +10      ; but would be useful for the VA

 +11      ;

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

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

 +14      ;. Q

SSNX       QUIT

 +1       ;

DOB       ;Get patients with same date of birth

 +1        if XDRDCAN(XDRFL,XDRCD,.03,"I")']""

               GOTO DOBX

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

 +3        SET XDRDCAN("BDOB")=XDRCD

 +4        FOR %=0:0

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

               if 'XDRDCAN("BDOB")

                   QUIT

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

 +5       ;

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

 +7       ;

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

 +9        SET XDRDCAN("BDOB")=XDRCD

 +10       FOR %=0:0

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

               if 'XDRDCAN("BDOB")

                   QUIT

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

DOBX       QUIT

 +1       ;

EOJ       ;

 +1        KILL XDRDCAN,%

 +2        QUIT

XDRPTCAN.m