- XDRPTDOB ;SF-IRMFO/IHS/OHPRD/JCM;COMPARES DATE OF BIRTHS; ;1/27/97 15:11
- ;;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 XDRDOB,XDRDOB2
- S XDRDOB=XDRCD(XDRFL,XDRCD,.03,"I"),XDRDOB2=XDRCD2(XDRFL,XDRCD2,.03,"I")
- S XDRDOB("MATCH")=$P(XDRDTEST(XDRDTO),U,6)
- S XDRDOB("NO MATCH")=$P(XDRDTEST(XDRDTO),U,7)
- Q
- ;
- COMPARE ;
- S XDRD("TEST SCORE")=$$DATECOMP(XDRDOB,XDRDOB2,XDRDOB("MATCH"),XDRDOB("NO MATCH"),.8,.6)
- Q
- ;
- DATECOMP(DATE1,DATE2,MATCH,NOMATCH,VAL1,VAL2) ;
- N Y
- S Y=$$NUMCOMP^XDRPTCLN(DATE1,DATE2,MATCH,NOMATCH,VAL1)
- I Y=NOMATCH D
- . I $E(DATE1,4,5)="00"!($E(DATE2,4,5)="00") S DATE1=$E(DATE1,1,3)_"0000",DATE2=$E(DATE2,1,3)_"0000" S MATCH=VAL2*MATCH
- . I $E(DATE1,4,5)'="00",$E(DATE1,6,7)="00"!($E(DATE2,6,7)="00") S DATE1=$E(DATE1,1,5)_"00",DATE2=$E(DATE2,1,5)_"00" S MATCH=VAL1*MATCH
- . S Y=$$NUMCOMP^XDRPTCLN(DATE1,DATE2,MATCH,NOMATCH,(NOMATCH/MATCH))
- Q Y
- ;
- EOJ ;
- K XDRDOB,XDRDOB2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRPTDOB 1017 printed Mar 13, 2025@21:44:46 Page 2
- XDRPTDOB ;SF-IRMFO/IHS/OHPRD/JCM;COMPARES DATE OF BIRTHS; ;1/27/97 15:11
- +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 XDRDOB,XDRDOB2
- +2 SET XDRDOB=XDRCD(XDRFL,XDRCD,.03,"I")
- SET XDRDOB2=XDRCD2(XDRFL,XDRCD2,.03,"I")
- +3 SET XDRDOB("MATCH")=$PIECE(XDRDTEST(XDRDTO),U,6)
- +4 SET XDRDOB("NO MATCH")=$PIECE(XDRDTEST(XDRDTO),U,7)
- +5 QUIT
- +6 ;
- COMPARE ;
- +1 SET XDRD("TEST SCORE")=$$DATECOMP(XDRDOB,XDRDOB2,XDRDOB("MATCH"),XDRDOB("NO MATCH"),.8,.6)
- +2 QUIT
- +3 ;
- DATECOMP(DATE1,DATE2,MATCH,NOMATCH,VAL1,VAL2) ;
- +1 NEW Y
- +2 SET Y=$$NUMCOMP^XDRPTCLN(DATE1,DATE2,MATCH,NOMATCH,VAL1)
- +3 IF Y=NOMATCH
- Begin DoDot:1
- +4 IF $EXTRACT(DATE1,4,5)="00"!($EXTRACT(DATE2,4,5)="00")
- SET DATE1=$EXTRACT(DATE1,1,3)_"0000"
- SET DATE2=$EXTRACT(DATE2,1,3)_"0000"
- SET MATCH=VAL2*MATCH
- +5 IF $EXTRACT(DATE1,4,5)'="00"
- IF $EXTRACT(DATE1,6,7)="00"!($EXTRACT(DATE2,6,7)="00")
- SET DATE1=$EXTRACT(DATE1,1,5)_"00"
- SET DATE2=$EXTRACT(DATE2,1,5)_"00"
- SET MATCH=VAL1*MATCH
- +6 SET Y=$$NUMCOMP^XDRPTCLN(DATE1,DATE2,MATCH,NOMATCH,(NOMATCH/MATCH))
- End DoDot:1
- +7 QUIT Y
- +8 ;
- EOJ ;
- +1 KILL XDRDOB,XDRDOB2
- +2 QUIT
