source: FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRPTCAN.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1XDRPTCAN ;SF-IRMFO/IHS/OHPRD/JCM/JLI ;5/30/97 10:28
2 ;;7.3;TOOLKIT;**23**;Apr 25, 1995
3 ;;
4 ;
5 ; Calls: EN^DIQ1
6 ;
7START ;
8 K ^TMP("XDRD",$J,XDRFL),XDRDCAN
9 Q:$P(^DPT(XDRCD,0),U,19)
10 D VALUE
11 I $E(XDRDCAN(2,XDRCD,.09,"I"),1,5)="00000" Q
12 D NAME
13 D SSN
14 D DOB
15END D EOJ
16 Q
17 ;
18VALUE ;
19 S DA=XDRCD K XDRCD S XDRCD=DA
20 N XDRI F XDRI=0:0 S XDRI=$O(XDRDSCOR("DR",XDRI)) Q:XDRI'>0 D
21 . S DIC=XDRI,DA=XDRCD,DIQ(0)="I",DIQ="XDRDCAN",DR=XDRDSCOR("DR",XDRI)
22 . D EN^DIQ1 K DIC,DR,DIQ
23 . M XDRCD=XDRDCAN K DA
24 Q
25 ;
26NAME ;
27 G:XDRDCAN(XDRFL,XDRCD,.01,"I")']"" NAMEX
28 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)
29 S XDRDCAN("NAME")=XDRDCAN(XDRFL,XDRCD,.01,"I")
30 S XDRDCAN("LNAME&FI")=$P(XDRDCAN("NAME"),",",1)_","_$E($P(XDRDCAN("NAME"),",",2),1)_"AAA"
31 S XDRDCAN("BNAME")=XDRDCAN("LNAME&FI")
32 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
33 . S XDRDCAN("FIND")=XDRCD
34 . F S XDRDCAN("FIND")=$O(^DPT("B",XDRDCAN("BNAME"),XDRDCAN("FIND"))) Q:XDRDCAN("FIND")'>0 S ^TMP("XDRD",$J,XDRFL,XDRDCAN("FIND"))=""
35 . ;S:$O(^DPT("B",XDRDCAN("BNAME"),""))'=XDRCD ^TMP("XDRD",$J,XDRFL,$O(^DPT("B",XDRDCAN("BNAME"),"")))=""
36 . Q
37NAMEX Q
38 ;
39SSN ;Get patients with same last four digits of ssn
40 I XDRDCAN(XDRFL,XDRCD,.09,"I")']"" S ^XTMP("XDRERR","BADSSN",XDRCD)="" G SSNX
41 I XDRDCAN(XDRFL,XDRCD,.09,"I")'?9N.E S ^XTMP("XDRERR","BADSSN",XDRCD)="" G SSNX
42 S XDRDCAN("SSN")=XDRDCAN(XDRFL,XDRCD,.09,"I")
43 S XDRDCAN("L4SSN")=$E(XDRDCAN("SSN"),6,9)
44 S XDRDCAN("BL4SSN")=XDRCD
45 F %=0:0 S XDRDCAN("BL4SSN")=$O(^DPT("BS",XDRDCAN("L4SSN"),XDRDCAN("BL4SSN"))) Q:'XDRDCAN("BL4SSN") S ^TMP("XDRD",$J,XDRFL,XDRDCAN("BL4SSN"))=""
46 ;
47 ; Check SSNS with same first five digits
48 ; Commented out the following line, is not specific enough for IHS
49 ; but would be useful for the VA
50 ;
51 ;S XDRDCAN("F5SSN")=$E(XDRDCAN("SSN"),1,5)_"0000",XDRDCAN("5SSN")=XDRDCAN("F5SSN") D
52 ;. 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"),"")))=""
53 ;. Q
54SSNX Q
55 ;
56DOB ;Get patients with same date of birth
57 G:XDRDCAN(XDRFL,XDRCD,.03,"I")']"" DOBX
58 S XDRDCAN("DOB")=XDRDCAN(XDRFL,XDRCD,.03,"I")
59 S XDRDCAN("BDOB")=XDRCD
60 F %=0:0 S XDRDCAN("BDOB")=$O(^DPT("ADOB",XDRDCAN("DOB"),XDRDCAN("BDOB"))) Q:'XDRDCAN("BDOB") S ^TMP("XDRD",$J,XDRFL,XDRDCAN("BDOB"))=""
61 ;
62 ;Transpose day of birth and get patients with same date of birth
63 ;
64 S XDRDCAN("TDOB")=$E(XDRDCAN("DOB"),1,5)_$E(XDRDCAN("DOB"),7)_$E(XDRDCAN("DOB"),6)
65 S XDRDCAN("BDOB")=XDRCD
66 F %=0:0 S XDRDCAN("BDOB")=$O(^DPT("ADOB",XDRDCAN("TDOB"),XDRDCAN("BDOB"))) Q:'XDRDCAN("BDOB") S ^TMP("XDRD",$J,XDRFL,XDRDCAN("BDOB"))=""
67DOBX Q
68 ;
69EOJ ;
70 K XDRDCAN,%
71 Q
Note: See TracBrowser for help on using the repository browser.