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
Q
;
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
Q
;
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,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRPTCAN 3116 printed Dec 13, 2024@02:39:41 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
