- 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 Mar 13, 2025@21:44:45 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
