XDRPTCLN ;SF-IRMFO/IHS/OHPRD/JCM;COMPARES CLAIM NUMBERS; ;4/18/97 11:04
;;7.3;TOOLKIT;**23**;Apr 25, 1995
;;
START ;
D INIT
EN ; EP - Entry point for comparing dates
D COMPARE
END D EOJ
Q
;
INIT ;
K XDRCLN,XDRCLN2
S XDRCLN=$G(XDRCD(XDRFL,XDRCD,.313,"I")),XDRCLN2=$G(XDRCD2(XDRFL,XDRCD2,.313,"I"))
S XDRCLN("MATCH")=$P(XDRDTEST(XDRDTO),U,6)
S XDRCLN("NO MATCH")=$P(XDRDTEST(XDRDTO),U,7)
Q
;
COMPARE ;
S XDRD("TEST SCORE")=$$NUMCOMP(XDRCLN,XDRCLN2,XDRCLN("MATCH"),XDRCLN("NO MATCH"),.8)
Q
;
NUMCOMP(VAL1,VAL2,MATCHVAL,NOMATCH,PARTIAL) ;
I VAL1']""!(VAL2']"") Q 0
I VAL1=VAL2 Q MATCHVAL
I '$D(PARTIAL)!($G(PARTIAL)>1) S PARTIAL=.8
N CNT,I,J,K S CNT=0
F I=1:1 Q:CNT>2 S J=$E(VAL1,I),K=$E(VAL2,I) Q:J=""&(K="") I J'=K S CNT=CNT+1
; THE FOLLOWING CODE WAS ADDED TO IDENTIFY THOSE VALUES IN WHICH
; TWO ADJACENT DIGITS WERE TRANSPOSED
I CNT=2 D
. ;N C11,C12,C21,C22,X1,X2,A1,A2
. S X1="",X2=""
. F I=1:1 S A1=$E(VAL1,I),A2=$E(VAL2,I) Q:A1=""&(A2="") I A1'=A2!(X1'="")!(X2'="") S X1=X1_A1,X2=X2_A2
. S CNT=1
. F I=2:1 S C12=$E(X1,I),C22=$E(X2,I) Q:C12=""&(C22="") S C11=$E(X1,I-1),C21=$E(X2,I-1) I C12'=C22,C11'=C22!(C12'=C21) S CNT=2 Q
Q $S(CNT>1:NOMATCH,1:(MATCHVAL*PARTIAL))
;
EOJ ;
K XDRCLN,XDRCLN2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRPTCLN 1275 printed Dec 13, 2024@02:39:42 Page 2
XDRPTCLN ;SF-IRMFO/IHS/OHPRD/JCM;COMPARES CLAIM NUMBERS; ;4/18/97 11:04
+1 ;;7.3;TOOLKIT;**23**;Apr 25, 1995
+2 ;;
START ;
+1 DO INIT
EN ; EP - Entry point for comparing dates
+1 DO COMPARE
END DO EOJ
+1 QUIT
+2 ;
INIT ;
+1 KILL XDRCLN,XDRCLN2
+2 SET XDRCLN=$GET(XDRCD(XDRFL,XDRCD,.313,"I"))
SET XDRCLN2=$GET(XDRCD2(XDRFL,XDRCD2,.313,"I"))
+3 SET XDRCLN("MATCH")=$PIECE(XDRDTEST(XDRDTO),U,6)
+4 SET XDRCLN("NO MATCH")=$PIECE(XDRDTEST(XDRDTO),U,7)
+5 QUIT
+6 ;
COMPARE ;
+1 SET XDRD("TEST SCORE")=$$NUMCOMP(XDRCLN,XDRCLN2,XDRCLN("MATCH"),XDRCLN("NO MATCH"),.8)
+2 QUIT
+3 ;
NUMCOMP(VAL1,VAL2,MATCHVAL,NOMATCH,PARTIAL) ;
+1 IF VAL1']""!(VAL2']"")
QUIT 0
+2 IF VAL1=VAL2
QUIT MATCHVAL
+3 IF '$DATA(PARTIAL)!($GET(PARTIAL)>1)
SET PARTIAL=.8
+4 NEW CNT,I,J,K
SET CNT=0
+5 FOR I=1:1
if CNT>2
QUIT
SET J=$EXTRACT(VAL1,I)
SET K=$EXTRACT(VAL2,I)
if J=""&(K="")
QUIT
IF J'=K
SET CNT=CNT+1
+6 ; THE FOLLOWING CODE WAS ADDED TO IDENTIFY THOSE VALUES IN WHICH
+7 ; TWO ADJACENT DIGITS WERE TRANSPOSED
+8 IF CNT=2
Begin DoDot:1
+9 ;N C11,C12,C21,C22,X1,X2,A1,A2
+10 SET X1=""
SET X2=""
+11 FOR I=1:1
SET A1=$EXTRACT(VAL1,I)
SET A2=$EXTRACT(VAL2,I)
if A1=""&(A2="")
QUIT
IF A1'=A2!(X1'="")!(X2'="")
SET X1=X1_A1
SET X2=X2_A2
+12 SET CNT=1
+13 FOR I=2:1
SET C12=$EXTRACT(X1,I)
SET C22=$EXTRACT(X2,I)
if C12=""&(C22="")
QUIT
SET C11=$EXTRACT(X1,I-1)
SET C21=$EXTRACT(X2,I-1)
IF C12'=C22
IF C11'=C22!(C12'=C21)
SET CNT=2
QUIT
End DoDot:1
+14 QUIT $SELECT(CNT>1:NOMATCH,1:(MATCHVAL*PARTIAL))
+15 ;
EOJ ;
+1 KILL XDRCLN,XDRCLN2
+2 QUIT
