AUPNLKD.m

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