AUPNLKD ; IHS/CMI/LAB - IHS PATIENT LOOKUP, QUICK DUPE CHECK ;
;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
;SEA/AMF-ALB/RMO - CHECK FOR DUPLICATES ON NEW PATIENT ENTRY JUNE 1987
;
; Upon exiting this routine AUPD will be the number of potential
; duplicates found, and the array AUPD(n) will contain those
; potential duplicate where 'n' is the patient's DFN.
;
START ;
D INIT ; Initialization
D:$E(DOB,6,7)'="00" DOB ; Check patients with similar DOBs
D:SSN'="" SSN ; Check patients with similar SSNs
D EOJ
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
DOB ; CHECK SAME DOB + TRANSPOSED DAY
F AUPIN=0:0 S AUPIN=$O(^DPT("ADOB",DOB,AUPIN)) Q:AUPIN="" D DOB1
S AUPDOB=DOB,DOB=$E(DOB,1,5)_$E(DOB,7)_$E(DOB,6)
F AUPIN=0:0 S AUPIN=$O(^DPT("ADOB",DOB,AUPIN)) Q:AUPIN="" D DOB1
S DOB=AUPDOB
Q
;
DOB1 ;
W "."
Q:$D(^VA(15,"AFR","DPT(",AUPIN)) ; Quit if verified duplicate
S AUPV=^DPT(AUPIN,0),AUPV1=$P(AUPV,U,1)
Q:$P(AUPV,U,18)="I"
Q:$P(AUPV,U,2)'=SEX
I AUPV1?.E1P.E S AUPT=AUPV1 D PUNC S AUPV1=AUPT
S AUPV1L=$P(AUPV1,",",1),AUPV1F=$P($P(AUPV1,",",2)," ",1),AUPV1M=$P($P(AUPV1,",",2)," ",2)
I ($E(AUPNL,1,2)_$E(AUPNF,1,2))=($E(AUPV1L,1,2)_$E(AUPV1F,1,2)) D HIT Q
I AUPNF=AUPV1F D HIT Q
I AUPNL=AUPV1L,AUPNM=AUPV1F D HIT Q
I AUPNL=AUPV1L,AUPV1M=AUPNF D HIT Q
I $D(^DPT(AUPIN,.01)) D ALIAS
Q:SSN=""
S AUPV1=$P(AUPV,U,9)
Q:AUPV1=""
S AUPF=0 F K=1:1:9 Q:(AUPF>2) I $E(AUPV1,K)'=$E(SSN,K) S AUPF=AUPF+1
I AUPF<3 D HIT Q
Q
;
ALIAS ;
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
K AUPAN,AUPAF
Q
;
ALIAS2 ;
S AUPV1=$P(^(0),U,1)
S AUPV1L=$P(AUPV1,",",1),AUPV1F=$P($P(AUPV1,",",2)," ",1),AUPV1M=$P($P(AUPV1,",",2)," ",2)
I AUPV1L=AUPNL Q
I AUPV1F=AUPNF Q
I AUPV1M=AUPNF Q
I AUPNF=AUPV1M Q
S AUPAF=0
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
SSN ; CHECK SSNS WITH SAME FIRST FIVE DIGITS
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
Q
;
SSN1 ;
W "."
Q:$D(AUPD(AUPIN)) ; Quit if already found
Q:$D(^VA(15,"AFR","DPT(",AUPIN)) ; Quit if verified duplicate
S AUPV1=^DPT(AUPIN,0)
Q:$P(AUPV1,U,2)'=SEX
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
S AUPV=$E(SSN,6,9),AUPV1=$E(AUPSSN,6,9)
S AUPF=0 F K=1:1:4 Q:(AUPF>2) I $E(AUPV,K)'=$E(AUPV1,K) S AUPF=AUPF+1
I AUPF<3 D HIT Q
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
HIT ; POTENTIAL DUPLICATE FOUND
Q:$D(AUPD(AUPIN))
S AUPD(AUPIN)=""
S AUPD=AUPD+1
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
INIT ; INITIALIZATION
K AUPD
S AUPD=0,AUPN=AUPNM
I $P(AUPN,",",1)?.E1P.E S AUPT=$P(AUPN,",",1) D PUNC S AUPN=AUPT_","_$P(AUPN,",",2,99)
S AUPNL=$P(AUPN,",",1),AUPNF=$P($P(AUPN,",",2)," ",1),AUPNM=$P($P(AUPN,",",2)," ",2)
Q
;
PUNC ;
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)
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
EOJ ;
K AUPAF,AUPAN,AUPDOB,AUPF,AUPIN,AUPN,AUPNF,AUPNL,AUPNM,AUPSSN,AUPT,AUPV,AUPV1,AUPV1F,AUPV1L,AUPV1M
Q
AUPNLKD ; IHS/CMI/LAB - IHS PATIENT LOOKUP, QUICK DUPE CHECK ;
+1 ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
+2 ;SEA/AMF-ALB/RMO - CHECK FOR DUPLICATES ON NEW PATIENT ENTRY JUNE 1987
+3 ;
+4 ; Upon exiting this routine AUPD will be the number of potential
+5 ; duplicates found, and the array AUPD(n) will contain those
+6 ; potential duplicate where 'n' is the patient's DFN.
+7 ;
START ;
+1 ; Initialization
DO INIT
+2 ; Check patients with similar DOBs
IF $EXTRACT(DOB,6,7)'="00"
DO DOB
+3 ; Check patients with similar SSNs
IF SSN'=""
DO SSN
+4 DO EOJ
+5 QUIT
+6 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+7 ;
DOB ; CHECK SAME DOB + TRANSPOSED DAY
+1 FOR AUPIN=0:0
SET AUPIN=$ORDER(^DPT("ADOB",DOB,AUPIN))
IF AUPIN=""
QUIT
DO DOB1
+2 SET AUPDOB=DOB
SET DOB=$EXTRACT(DOB,1,5)_$EXTRACT(DOB,7)_$EXTRACT(DOB,6)
+3 FOR AUPIN=0:0
SET AUPIN=$ORDER(^DPT("ADOB",DOB,AUPIN))
IF AUPIN=""
QUIT
DO DOB1
+4 SET DOB=AUPDOB
+5 QUIT
+6 ;
DOB1 ;
+1 WRITE "."
+2 ; Quit if verified duplicate
IF $DATA(^VA(15,"AFR","DPT(",AUPIN))
QUIT
+3 SET AUPV=^DPT(AUPIN,0)
SET AUPV1=$PIECE(AUPV,U,1)
+4 IF $PIECE(AUPV,U,18)="I"
QUIT
+5 IF $PIECE(AUPV,U,2)'=SEX
QUIT
+6 IF AUPV1?.E1P.E
SET AUPT=AUPV1
DO PUNC
SET AUPV1=AUPT
+7 SET AUPV1L=$PIECE(AUPV1,",",1)
SET AUPV1F=$PIECE($PIECE(AUPV1,",",2)," ",1)
SET AUPV1M=$PIECE($PIECE(AUPV1,",",2)," ",2)
+8 IF ($EXTRACT(AUPNL,1,2)_$EXTRACT(AUPNF,1,2))=($EXTRACT(AUPV1L,1,2)_$EXTRACT(AUPV1F,1,2))
DO HIT
QUIT
+9 IF AUPNF=AUPV1F
DO HIT
QUIT
+10 IF AUPNL=AUPV1L
IF AUPNM=AUPV1F
DO HIT
QUIT
+11 IF AUPNL=AUPV1L
IF AUPV1M=AUPNF
DO HIT
QUIT
+12 IF $DATA(^DPT(AUPIN,.01))
DO ALIAS
+13 IF SSN=""
QUIT
+14 SET AUPV1=$PIECE(AUPV,U,9)
+15 IF AUPV1=""
QUIT
+16 SET AUPF=0
FOR K=1:1:9
IF (AUPF>2)
QUIT
IF $EXTRACT(AUPV1,K)'=$EXTRACT(SSN,K)
SET AUPF=AUPF+1
+17 IF AUPF<3
DO HIT
QUIT
+18 QUIT
+19 ;
ALIAS ;
+1 FOR AUPAN=0:0
SET AUPAF=1
SET AUPAN=$ORDER(^DPT(AUPIN,.01,AUPAN))
IF AUPAN'=+AUPAN
QUIT
IF $DATA(^(AUPAN,0))
DO ALIAS2
IF AUPAF
DO HIT
QUIT
+2 KILL AUPAN,AUPAF
+3 QUIT
+4 ;
ALIAS2 ;
+1 SET AUPV1=$PIECE(^(0),U,1)
+2 SET AUPV1L=$PIECE(AUPV1,",",1)
SET AUPV1F=$PIECE($PIECE(AUPV1,",",2)," ",1)
SET AUPV1M=$PIECE($PIECE(AUPV1,",",2)," ",2)
+3 IF AUPV1L=AUPNL
QUIT
+4 IF AUPV1F=AUPNF
QUIT
+5 IF AUPV1M=AUPNF
QUIT
+6 IF AUPNF=AUPV1M
QUIT
+7 SET AUPAF=0
+8 QUIT
+9 ;
+10 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+11 ;
SSN ; CHECK SSNS WITH SAME FIRST FIVE DIGITS
+1 SET AUPSSN=$EXTRACT(SSN,1,5)_"0000"
FOR AUPSSN=0:0
SET AUPSSN=$ORDER(^DPT("SSN",AUPSSN))
IF AUPSSN=""!($EXTRACT(AUPSSN,1,5)'=$EXTRACT(SSN,1,5))
QUIT
FOR AUPIN=0:0
SET AUPIN=$ORDER(^DPT("SSN",AUPSSN,AUPIN))
IF AUPIN=""
QUIT
DO SSN1
+2 QUIT
+3 ;
SSN1 ;
+1 WRITE "."
+2 ; Quit if already found
IF $DATA(AUPD(AUPIN))
QUIT
+3 ; Quit if verified duplicate
IF $DATA(^VA(15,"AFR","DPT(",AUPIN))
QUIT
+4 SET AUPV1=^DPT(AUPIN,0)
+5 IF $PIECE(AUPV1,U,2)'=SEX
QUIT
+6 IF $PIECE(AUPV1,",",1)=$PIECE(AUPN,",",1)!($EXTRACT(AUPV1,1,2)_$EXTRACT($PIECE(AUPV1,",",2),1,2)=($EXTRACT(AUPN,1,2)_$EXTRACT($PIECE(AUPN,",",2),1,2)))
SET AUPD(AUPIN)=""
SET AUPD=AUPD+1
QUIT
+7 SET AUPV=$EXTRACT(SSN,6,9)
SET AUPV1=$EXTRACT(AUPSSN,6,9)
+8 SET AUPF=0
FOR K=1:1:4
IF (AUPF>2)
QUIT
IF $EXTRACT(AUPV,K)'=$EXTRACT(AUPV1,K)
SET AUPF=AUPF+1
+9 IF AUPF<3
DO HIT
QUIT
+10 QUIT
+11 ;
+12 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+13 ;
HIT ; POTENTIAL DUPLICATE FOUND
+1 IF $DATA(AUPD(AUPIN))
QUIT
+2 SET AUPD(AUPIN)=""
+3 SET AUPD=AUPD+1
+4 QUIT
+5 ;
+6 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+7 ;
INIT ; INITIALIZATION
+1 KILL AUPD
+2 SET AUPD=0
SET AUPN=AUPNM
+3 IF $PIECE(AUPN,",",1)?.E1P.E
SET AUPT=$PIECE(AUPN,",",1)
DO PUNC
SET AUPN=AUPT_","_$PIECE(AUPN,",",2,99)
+4 SET AUPNL=$PIECE(AUPN,",",1)
SET AUPNF=$PIECE($PIECE(AUPN,",",2)," ",1)
SET AUPNM=$PIECE($PIECE(AUPN,",",2)," ",2)
+5 QUIT
+6 ;
PUNC ;
+1 FOR I=1:1:$LENGTH(AUPT)
IF $EXTRACT(AUPT,I)?1P
IF $EXTRACT(AUPT,I)'=","
IF $EXTRACT(AUPT,I)'=" "
SET AUPT=$EXTRACT(AUPT,1,I-1)_$EXTRACT(AUPT,I+1,99)
+2 QUIT
+3 ;
+4 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+5 ;
EOJ ;
+1 KILL AUPAF,AUPAN,AUPDOB,AUPF,AUPIN,AUPN,AUPNF,AUPNL,AUPNM,AUPSSN,AUPT,AUPV,AUPV1,AUPV1F,AUPV1L,AUPV1M
+2 QUIT
