XDRPTCLN.m

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 ---XDRPTCLN   1275     printed  Apr 09, 2024@21:42:04                                                                                                                                                                                                    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