- 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 Feb 19, 2025@00:26:53 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