XDRPTN ;SF-IRMFO/IHS/OHPRD/JCM;COMPARES NAMES; ;11/6/97 16:14
;;7.3;TOOLKIT;**23**;Apr 25, 1995
;;
;
; Calls: SOU^DICM1
;
START ;
D INIT
D NAME
I $O(^DPT(XDRCD,.01,0)) D OTHER
END D EOJ
Q
;
EN ; EP - Entry Point for any routines comparing names
;
D INIT1
D COMPARE
D EOJ
Q
;
INIT ;
D EOJ
S XDRDN("MATCH")=$P(XDRDTEST(XDRDTO),U,6)
S XDRDN("NO MATCH")=$P(XDRDTEST(XDRDTO),U,7)
S XDRDN=XDRCD(XDRFL,XDRCD,.01,"I"),XDRDN2=XDRCD2(XDRFL,XDRCD2,.01,"I")
;
INIT1 S XDRDN=$$CHKNAM(XDRDN),XDRDN2=$$CHKNAM(XDRDN2)
S XDRDNL=$P(XDRDN,","),XDRDNF=$P($P(XDRDN,",",2)," "),XDRDNFI=$E(XDRDNF),XDRDNM=$P($P(XDRDN,",",2)," ",2),XDRDNMI=$E(XDRDNM)
;
INIT2 S XDRDNL2=$P(XDRDN2,","),XDRDNF2=$P($P(XDRDN2,",",2)," "),XDRDNFI2=$E(XDRDNF2),XDRDNM2=$P($P(XDRDN2,",",2)," ",2),XDRDNMI2=$E(XDRDNM2)
Q
;
NAME ;
D COMPARE
D:$O(^DPT(XDRCD2,.01,0)) OTHER2
Q
;
OTHER ;
F XDRDNO=0:0 S XDRDNO=$O(^DPT(XDRCD,.01,XDRDNO)) Q:'XDRDNO S XDRDN=$P(^DPT(XDRCD,.01,XDRDNO,0),U,1) S:'$D(XDRDN2) XDRDN2=XDRCD2(XDRFL,XDRCD2,.01,"I") D INIT1,NAME
Q
;
OTHER2 ;
F XDRDNO2=0:0 S XDRDNO2=$O(^DPT(XDRCD2,.01,XDRDNO2)) Q:'XDRDNO2 S XDRDN2=$P(^DPT(XDRCD2,.01,XDRDNO2,0),U,1) D INIT2,COMPARE
Q
;
COMPARE ;
S:'$D(XDRDN("TEST SCORE")) XDRDN("TEST SCORE")=XDRDN("NO MATCH")
I XDRDN=XDRDN2 S XDRDN("TEST SCORE2")=XDRDN("MATCH") G COMPAREX
I XDRDNF=XDRDNF2,XDRDNL=XDRDNL2 S XDRDN("TEST SCORE2")=XDRDN("MATCH")*.8 G COMPAREX
S X=XDRDNL D SOU^DICM1 S XDRDNLS=X S X=XDRDNL2 D SOU^DICM1 S XDRDNL2S=X
S X=XDRDNF D SOU^DICM1 S XDRDNFS=X S X=XDRDNF2 D SOU^DICM1 S XDRDNF2S=X
I XDRDNLS=XDRDNL2S,XDRDNFS=XDRDNF2S S XDRDN("TEST SCORE2")=XDRDN("MATCH")*.6 G COMPAREX
I XDRDNFI=XDRDNFI2,XDRDNL=XDRDNL2 S XDRDN("TEST SCORE2")=XDRDN("MATCH")*.5 G COMPAREX ; CHANGED FROM .6 TO .5 04/15/96 JLI
I XDRDNL=XDRDNL2 S XDRDN("TEST SCORE2")=XDRDN("MATCH")*.4 G COMPAREX
I XDRDNFS=XDRDNF2S S XDRDN("TEST SCORE2")=XDRDN("MATCH")*.2 G COMPAREX
S XDRDN("TEST SCORE2")=XDRDN("NO MATCH")
COMPAREX ;
S:XDRDN("TEST SCORE2")>(XDRDN("TEST SCORE")) XDRDN("TEST SCORE")=XDRDN("TEST SCORE2")
K X,XDRDNLS,XDRDNL2S,XDRDNFS,XDRDNF2S,XDRDN("TEST SCORE2")
Q
;
CHKNAM(NAME) ;
N X,XXX,YYY
S NAME=$$UP^XLFSTR(NAME)
I $E(NAME,1,2)="ZZ" D
. F Q:$E(NAME,1)'="Z" S NAME=$E(NAME,2,$L(NAME)) ;S NAME=$E(NAME,3,$L(NAME)) -- MODIFIED 11/06/97 JLI
S NAME=$$NOSPAC(NAME)
I $E(NAME,$L(NAME))="." S NAME=$E(NAME,1,$L(NAME)-1)
S X=$$NOSPAC($P(NAME,",",2))
I X'="",",JR,SR,II,III,3RD,"[(","_X_",") S NAME=$P(NAME,",")
I NAME'="",NAME'["," D
. I $L(NAME," ")=1 Q
LOOP . S X=$P(NAME," ",$L(NAME," ")),NAME=$P(NAME," ",1,$L(NAME," ")-1)
. I ",JR,SR,II,III,3RD,"[(","_X_",") G LOOP
. I NAME'="" S NAME=X_","_NAME
Q NAME
;
NOSPAC(X) ;
F Q:X="" Q:$E(X)'=" " S X=$E(X,2,$L(X))
Q X
;
EOJ ;
S:$D(XDRDN("TEST SCORE")) XDRD("TEST SCORE")=XDRDN("TEST SCORE")
K XDRDN,XDRDN2,XDRDNF,XDRDNF2,XDRDNL,XDRDNL2,XDRDNM,XDRDNM2
K XDRDNMI,XDRDNMI2,XDRDNFI,XDRDNFI2,XDRDNO,XDRDNO2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRPTN 3005 printed Dec 13, 2024@02:39:46 Page 2
XDRPTN ;SF-IRMFO/IHS/OHPRD/JCM;COMPARES NAMES; ;11/6/97 16:14
+1 ;;7.3;TOOLKIT;**23**;Apr 25, 1995
+2 ;;
+3 ;
+4 ; Calls: SOU^DICM1
+5 ;
START ;
+1 DO INIT
+2 DO NAME
+3 IF $ORDER(^DPT(XDRCD,.01,0))
DO OTHER
END DO EOJ
+1 QUIT
+2 ;
EN ; EP - Entry Point for any routines comparing names
+1 ;
+2 DO INIT1
+3 DO COMPARE
+4 DO EOJ
+5 QUIT
+6 ;
INIT ;
+1 DO EOJ
+2 SET XDRDN("MATCH")=$PIECE(XDRDTEST(XDRDTO),U,6)
+3 SET XDRDN("NO MATCH")=$PIECE(XDRDTEST(XDRDTO),U,7)
+4 SET XDRDN=XDRCD(XDRFL,XDRCD,.01,"I")
SET XDRDN2=XDRCD2(XDRFL,XDRCD2,.01,"I")
+5 ;
INIT1 SET XDRDN=$$CHKNAM(XDRDN)
SET XDRDN2=$$CHKNAM(XDRDN2)
+1 SET XDRDNL=$PIECE(XDRDN,",")
SET XDRDNF=$PIECE($PIECE(XDRDN,",",2)," ")
SET XDRDNFI=$EXTRACT(XDRDNF)
SET XDRDNM=$PIECE($PIECE(XDRDN,",",2)," ",2)
SET XDRDNMI=$EXTRACT(XDRDNM)
+2 ;
INIT2 SET XDRDNL2=$PIECE(XDRDN2,",")
SET XDRDNF2=$PIECE($PIECE(XDRDN2,",",2)," ")
SET XDRDNFI2=$EXTRACT(XDRDNF2)
SET XDRDNM2=$PIECE($PIECE(XDRDN2,",",2)," ",2)
SET XDRDNMI2=$EXTRACT(XDRDNM2)
+1 QUIT
+2 ;
NAME ;
+1 DO COMPARE
+2 if $ORDER(^DPT(XDRCD2,.01,0))
DO OTHER2
+3 QUIT
+4 ;
OTHER ;
+1 FOR XDRDNO=0:0
SET XDRDNO=$ORDER(^DPT(XDRCD,.01,XDRDNO))
if 'XDRDNO
QUIT
SET XDRDN=$PIECE(^DPT(XDRCD,.01,XDRDNO,0),U,1)
if '$DATA(XDRDN2)
SET XDRDN2=XDRCD2(XDRFL,XDRCD2,.01,"I")
DO INIT1
DO NAME
+2 QUIT
+3 ;
OTHER2 ;
+1 FOR XDRDNO2=0:0
SET XDRDNO2=$ORDER(^DPT(XDRCD2,.01,XDRDNO2))
if 'XDRDNO2
QUIT
SET XDRDN2=$PIECE(^DPT(XDRCD2,.01,XDRDNO2,0),U,1)
DO INIT2
DO COMPARE
+2 QUIT
+3 ;
COMPARE ;
+1 if '$DATA(XDRDN("TEST SCORE"))
SET XDRDN("TEST SCORE")=XDRDN("NO MATCH")
+2 IF XDRDN=XDRDN2
SET XDRDN("TEST SCORE2")=XDRDN("MATCH")
GOTO COMPAREX
+3 IF XDRDNF=XDRDNF2
IF XDRDNL=XDRDNL2
SET XDRDN("TEST SCORE2")=XDRDN("MATCH")*.8
GOTO COMPAREX
+4 SET X=XDRDNL
DO SOU^DICM1
SET XDRDNLS=X
SET X=XDRDNL2
DO SOU^DICM1
SET XDRDNL2S=X
+5 SET X=XDRDNF
DO SOU^DICM1
SET XDRDNFS=X
SET X=XDRDNF2
DO SOU^DICM1
SET XDRDNF2S=X
+6 IF XDRDNLS=XDRDNL2S
IF XDRDNFS=XDRDNF2S
SET XDRDN("TEST SCORE2")=XDRDN("MATCH")*.6
GOTO COMPAREX
+7 ; CHANGED FROM .6 TO .5 04/15/96 JLI
IF XDRDNFI=XDRDNFI2
IF XDRDNL=XDRDNL2
SET XDRDN("TEST SCORE2")=XDRDN("MATCH")*.5
GOTO COMPAREX
+8 IF XDRDNL=XDRDNL2
SET XDRDN("TEST SCORE2")=XDRDN("MATCH")*.4
GOTO COMPAREX
+9 IF XDRDNFS=XDRDNF2S
SET XDRDN("TEST SCORE2")=XDRDN("MATCH")*.2
GOTO COMPAREX
+10 SET XDRDN("TEST SCORE2")=XDRDN("NO MATCH")
COMPAREX ;
+1 if XDRDN("TEST SCORE2")>(XDRDN("TEST SCORE"))
SET XDRDN("TEST SCORE")=XDRDN("TEST SCORE2")
+2 KILL X,XDRDNLS,XDRDNL2S,XDRDNFS,XDRDNF2S,XDRDN("TEST SCORE2")
+3 QUIT
+4 ;
CHKNAM(NAME) ;
+1 NEW X,XXX,YYY
+2 SET NAME=$$UP^XLFSTR(NAME)
+3 IF $EXTRACT(NAME,1,2)="ZZ"
Begin DoDot:1
+4 ;S NAME=$E(NAME,3,$L(NAME)) -- MODIFIED 11/06/97 JLI
FOR
if $EXTRACT(NAME,1)'="Z"
QUIT
SET NAME=$EXTRACT(NAME,2,$LENGTH(NAME))
End DoDot:1
+5 SET NAME=$$NOSPAC(NAME)
+6 IF $EXTRACT(NAME,$LENGTH(NAME))="."
SET NAME=$EXTRACT(NAME,1,$LENGTH(NAME)-1)
+7 SET X=$$NOSPAC($PIECE(NAME,",",2))
+8 IF X'=""
IF ",JR,SR,II,III,3RD,"[(","_X_",")
SET NAME=$PIECE(NAME,",")
+9 IF NAME'=""
IF NAME'[","
Begin DoDot:1
+10 IF $LENGTH(NAME," ")=1
QUIT
LOOP SET X=$PIECE(NAME," ",$LENGTH(NAME," "))
SET NAME=$PIECE(NAME," ",1,$LENGTH(NAME," ")-1)
+1 IF ",JR,SR,II,III,3RD,"[(","_X_",")
GOTO LOOP
+2 IF NAME'=""
SET NAME=X_","_NAME
End DoDot:1
+3 QUIT NAME
+4 ;
NOSPAC(X) ;
+1 FOR
if X=""
QUIT
if $EXTRACT(X)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 QUIT X
+3 ;
EOJ ;
+1 if $DATA(XDRDN("TEST SCORE"))
SET XDRD("TEST SCORE")=XDRDN("TEST SCORE")
+2 KILL XDRDN,XDRDN2,XDRDNF,XDRDNF2,XDRDNL,XDRDNL2,XDRDNM,XDRDNM2
+3 KILL XDRDNMI,XDRDNMI2,XDRDNFI,XDRDNFI2,XDRDNO,XDRDNO2
+4 QUIT
