DPTDUP ;SEA/AMF-ALB/RMO - CHECK FOR DUPLICATES ON NEW PATIENT ENTRY ; 22 JUN 87 1:00 pm
;;5.3;Patient File;**50**;Aug 13, 1993
; after statistics test, take out all reference to DPTKD,DPTKS
CHK ;
K DPTD S DPTD=0,DPTN=DPTNM I $P(DPTN,",",1)?.E1P.E S DPTT=$P(DPTN,",",1) D PUNC S DPTN=DPTT_","_$P(DPTN,",",2,99)
D:$E(DOB,6,7)'="00" DOB D SSN
G KL
;
DOB ;
S DPTIN=0 F I=0:0 S DPTIN=$O(^DPT("ADOB",DOB,DPTIN)) Q:DPTIN']"" D DOB1 S DPTKD=DPTKD+1
Q
DOB1 ;
I '$D(ZTQUEUED) W "."
S DPTV=^DPT(DPTIN,0),DPTV1=$P(DPTV,U,1)
I DPTV1?.E1P.E S DPTT=DPTV1 D PUNC S DPTV1=DPTT
; proceed no furthur if this is a verified from duplicate already
I $E($P(DPTN,",",1),1,2)_$E($P(DPTN,",",2),1,2)=($E($P(DPTV1,",",1),1,2)_$E($P(DPTV1,",",2),1,2)) S DPTD(DPTIN)="",DPTD=DPTD+1 Q
S DPTV1=$P(DPTV,U,9)
S DPTF=0 F K=1:1:9 Q:(DPTF>2) I $E(DPTV1,K)'=$E(SSN,K) S DPTF=DPTF+1
I DPTF<3 S DPTD(DPTIN)="",DPTD=DPTD+1
Q
SSN ;
S DPTSSN=$E(SSN,1,5)_"0000" F K=1:1 S DPTSSN=$O(^DPT("SSN",DPTSSN)) Q:DPTSSN']""!($E(DPTSSN,1,5)'=$E(SSN,1,5)) S DPTIN=0 F I=1:1 S DPTIN=$O(^DPT("SSN",DPTSSN,DPTIN)) Q:DPTIN']"" D SSN1 S DPTKS=DPTKS+1
Q
SSN1 ;
I '$D(ZTQUEUED) W "."
Q:$D(DPTD(DPTIN))
S DPTV1=^DPT(DPTIN,0) I $P(DPTV1,",",1)=$P(DPTN,",",1)!($E(DPTV1,1,2)_$E($P(DPTV1,",",2),1,2)=($E(DPTN,1,2)_$E($P(DPTN,",",2),1,2))) S DPTD(DPTIN)="",DPTD=DPTD+1 Q
S DPTV=$E(SSN,6,9),DPTV1=$E(DPTSSN,6,9)
S DPTF=0 F K=1:1:4 Q:(DPTF>2) I $E(DPTV,K)'=$E(DPTV1,K) S DPTF=DPTF+1
I DPTF<3 S DPTD(DPTIN)="",DPTD=DPTD+1
Q
PUNC ;
F I=1:1:$L(DPTT) I $E(DPTT,I)?1P,$E(DPTT,I)'="," S DPTT=$E(DPTT,1,I-1)_$E(DPTT,I+1,99)
Q
KL ;
K DPTIN,DPTV,DPTV1,DPTF,DPTSSN,DPTT,DPTN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDPTDUP 1672 printed Oct 16, 2024@19:01:23 Page 2
DPTDUP ;SEA/AMF-ALB/RMO - CHECK FOR DUPLICATES ON NEW PATIENT ENTRY ; 22 JUN 87 1:00 pm
+1 ;;5.3;Patient File;**50**;Aug 13, 1993
+2 ; after statistics test, take out all reference to DPTKD,DPTKS
CHK ;
+1 KILL DPTD
SET DPTD=0
SET DPTN=DPTNM
IF $PIECE(DPTN,",",1)?.E1P.E
SET DPTT=$PIECE(DPTN,",",1)
DO PUNC
SET DPTN=DPTT_","_$PIECE(DPTN,",",2,99)
+2 if $EXTRACT(DOB,6,7)'="00"
DO DOB
DO SSN
+3 GOTO KL
+4 ;
DOB ;
+1 SET DPTIN=0
FOR I=0:0
SET DPTIN=$ORDER(^DPT("ADOB",DOB,DPTIN))
if DPTIN']""
QUIT
DO DOB1
SET DPTKD=DPTKD+1
+2 QUIT
DOB1 ;
+1 IF '$DATA(ZTQUEUED)
WRITE "."
+2 SET DPTV=^DPT(DPTIN,0)
SET DPTV1=$PIECE(DPTV,U,1)
+3 IF DPTV1?.E1P.E
SET DPTT=DPTV1
DO PUNC
SET DPTV1=DPTT
+4 ; proceed no furthur if this is a verified from duplicate already
+5 IF $EXTRACT($PIECE(DPTN,",",1),1,2)_$EXTRACT($PIECE(DPTN,",",2),1,2)=($EXTRACT($PIECE(DPTV1,",",1),1,2)_$EXTRACT($PIECE(DPTV1,",",2),1,2))
SET DPTD(DPTIN)=""
SET DPTD=DPTD+1
QUIT
+6 SET DPTV1=$PIECE(DPTV,U,9)
+7 SET DPTF=0
FOR K=1:1:9
if (DPTF>2)
QUIT
IF $EXTRACT(DPTV1,K)'=$EXTRACT(SSN,K)
SET DPTF=DPTF+1
+8 IF DPTF<3
SET DPTD(DPTIN)=""
SET DPTD=DPTD+1
+9 QUIT
SSN ;
+1 SET DPTSSN=$EXTRACT(SSN,1,5)_"0000"
FOR K=1:1
SET DPTSSN=$ORDER(^DPT("SSN",DPTSSN))
if DPTSSN']""!($EXTRACT(DPTSSN,1,5)'=$EXTRACT(SSN,1,5))
QUIT
SET DPTIN=0
FOR I=1:1
SET DPTIN=$ORDER(^DPT("SSN",DPTSSN,DPTIN))
if DPTIN']""
QUIT
DO SSN1
SET DPTKS=DPTKS+1
+2 QUIT
SSN1 ;
+1 IF '$DATA(ZTQUEUED)
WRITE "."
+2 if $DATA(DPTD(DPTIN))
QUIT
+3 SET DPTV1=^DPT(DPTIN,0)
IF $PIECE(DPTV1,",",1)=$PIECE(DPTN,",",1)!($EXTRACT(DPTV1,1,2)_$EXTRACT($PIECE(DPTV1,",",2),1,2)=($EXTRACT(DPTN,1,2)_$EXTRACT($PIECE(DPTN,",",2),1,2)))
SET DPTD(DPTIN)=""
SET DPTD=DPTD+1
QUIT
+4 SET DPTV=$EXTRACT(SSN,6,9)
SET DPTV1=$EXTRACT(DPTSSN,6,9)
+5 SET DPTF=0
FOR K=1:1:4
if (DPTF>2)
QUIT
IF $EXTRACT(DPTV,K)'=$EXTRACT(DPTV1,K)
SET DPTF=DPTF+1
+6 IF DPTF<3
SET DPTD(DPTIN)=""
SET DPTD=DPTD+1
+7 QUIT
PUNC ;
+1 FOR I=1:1:$LENGTH(DPTT)
IF $EXTRACT(DPTT,I)?1P
IF $EXTRACT(DPTT,I)'=","
SET DPTT=$EXTRACT(DPTT,1,I-1)_$EXTRACT(DPTT,I+1,99)
+2 QUIT
KL ;
+1 KILL DPTIN,DPTV,DPTV1,DPTF,DPTSSN,DPTT,DPTN
+2 QUIT
