source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLKD.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1AUPNLKD ; IHS/CMI/LAB - IHS PATIENT LOOKUP, QUICK DUPE CHECK ;1/29/07 09:05
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
3 ;SEA/AMF-ALB/RMO - CHECK FOR DUPLICATES ON NEW PATIENT ENTRY JUNE 1987
4 ;
5 ; Upon exiting this routine AUPD will be the number of potential
6 ; duplicates found, and the array AUPD(n) will contain those
7 ; potential duplicate where 'n' is the patient's DFN.
8 ;
9START ;
10 D INIT ; Initialization
11 D:$E(DOB,6,7)'="00" DOB ; Check patients with similar DOBs
12 D:SSN'="" SSN ; Check patients with similar SSNs
13 D EOJ
14 Q
15 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
16 ;
17DOB ; CHECK SAME DOB + TRANSPOSED DAY
18 F AUPIN=0:0 S AUPIN=$O(^DPT("ADOB",DOB,AUPIN)) Q:AUPIN="" D DOB1
19 S AUPDOB=DOB,DOB=$E(DOB,1,5)_$E(DOB,7)_$E(DOB,6)
20 F AUPIN=0:0 S AUPIN=$O(^DPT("ADOB",DOB,AUPIN)) Q:AUPIN="" D DOB1
21 S DOB=AUPDOB
22 Q
23 ;
24DOB1 ;
25 W "."
26 Q:$D(^VA(15,"AFR","DPT(",AUPIN)) ; Quit if verified duplicate
27 S AUPV=^DPT(AUPIN,0),AUPV1=$P(AUPV,U,1)
28 Q:$P(AUPV,U,18)="I"
29 Q:$P(AUPV,U,2)'=SEX
30 I AUPV1?.E1P.E S AUPT=AUPV1 D PUNC S AUPV1=AUPT
31 S AUPV1L=$P(AUPV1,",",1),AUPV1F=$P($P(AUPV1,",",2)," ",1),AUPV1M=$P($P(AUPV1,",",2)," ",2)
32 I ($E(AUPNL,1,2)_$E(AUPNF,1,2))=($E(AUPV1L,1,2)_$E(AUPV1F,1,2)) D HIT Q
33 I AUPNF=AUPV1F D HIT Q
34 I AUPNL=AUPV1L,AUPNM=AUPV1F D HIT Q
35 I AUPNL=AUPV1L,AUPV1M=AUPNF D HIT Q
36 I $D(^DPT(AUPIN,.01)) D ALIAS
37 Q:SSN=""
38 S AUPV1=$P(AUPV,U,9)
39 Q:AUPV1=""
40 S AUPF=0 F K=1:1:9 Q:(AUPF>2) I $E(AUPV1,K)'=$E(SSN,K) S AUPF=AUPF+1
41 I AUPF<3 D HIT Q
42 Q
43 ;
44ALIAS ;
45 F AUPAN=0:0 S AUPAF=1,AUPAN=$O(^DPT(AUPIN,.01,AUPAN)) Q:AUPAN'=+AUPAN I $D(^(AUPAN,0)) D ALIAS2 I AUPAF D HIT Q
46 K AUPAN,AUPAF
47 Q
48 ;
49ALIAS2 ;
50 S AUPV1=$P(^(0),U,1)
51 S AUPV1L=$P(AUPV1,",",1),AUPV1F=$P($P(AUPV1,",",2)," ",1),AUPV1M=$P($P(AUPV1,",",2)," ",2)
52 I AUPV1L=AUPNL Q
53 I AUPV1F=AUPNF Q
54 I AUPV1M=AUPNF Q
55 I AUPNF=AUPV1M Q
56 S AUPAF=0
57 Q
58 ;
59 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
60 ;
61SSN ; CHECK SSNS WITH SAME FIRST FIVE DIGITS
62 S AUPSSN=$E(SSN,1,5)_"0000" F AUPSSN=0:0 S AUPSSN=$O(^DPT("SSN",AUPSSN)) Q:AUPSSN=""!($E(AUPSSN,1,5)'=$E(SSN,1,5)) F AUPIN=0:0 S AUPIN=$O(^DPT("SSN",AUPSSN,AUPIN)) Q:AUPIN="" D SSN1
63 Q
64 ;
65SSN1 ;
66 W "."
67 Q:$D(AUPD(AUPIN)) ; Quit if already found
68 Q:$D(^VA(15,"AFR","DPT(",AUPIN)) ; Quit if verified duplicate
69 S AUPV1=^DPT(AUPIN,0)
70 Q:$P(AUPV1,U,2)'=SEX
71 I $P(AUPV1,",",1)=$P(AUPN,",",1)!($E(AUPV1,1,2)_$E($P(AUPV1,",",2),1,2)=($E(AUPN,1,2)_$E($P(AUPN,",",2),1,2))) S AUPD(AUPIN)="",AUPD=AUPD+1 Q
72 S AUPV=$E(SSN,6,9),AUPV1=$E(AUPSSN,6,9)
73 S AUPF=0 F K=1:1:4 Q:(AUPF>2) I $E(AUPV,K)'=$E(AUPV1,K) S AUPF=AUPF+1
74 I AUPF<3 D HIT Q
75 Q
76 ;
77 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
78 ;
79HIT ; POTENTIAL DUPLICATE FOUND
80 Q:$D(AUPD(AUPIN))
81 S AUPD(AUPIN)=""
82 S AUPD=AUPD+1
83 Q
84 ;
85 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
86 ;
87INIT ; INITIALIZATION
88 K AUPD
89 S AUPD=0,AUPN=AUPNM
90 I $P(AUPN,",",1)?.E1P.E S AUPT=$P(AUPN,",",1) D PUNC S AUPN=AUPT_","_$P(AUPN,",",2,99)
91 S AUPNL=$P(AUPN,",",1),AUPNF=$P($P(AUPN,",",2)," ",1),AUPNM=$P($P(AUPN,",",2)," ",2)
92 Q
93 ;
94PUNC ;
95 F I=1:1:$L(AUPT) I $E(AUPT,I)?1P,$E(AUPT,I)'=",",$E(AUPT,I)'=" " S AUPT=$E(AUPT,1,I-1)_$E(AUPT,I+1,99)
96 Q
97 ;
98 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
99 ;
100EOJ ;
101 K AUPAF,AUPAN,AUPDOB,AUPF,AUPIN,AUPN,AUPNF,AUPNL,AUPNM,AUPSSN,AUPT,AUPV,AUPV1,AUPV1F,AUPV1L,AUPV1M
102 Q
Note: See TracBrowser for help on using the repository browser.