BGP3D4.m

BGP3D4 ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;

 ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7

 ;

I16 ;EP

 K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPMAM,BGPI8,BGPI81,BGPI8DA,BGPI8DB,BGPI8DC,BGPI8DD,BGPI8DE

 S BGPI8DA=0,BGPI8DB=0,BGPN1=0,BGPN2=0,BGPN3=0,BGPI8DC=0,BGPI8DD=0,BGPI8DE=0

 S BGPI8=$$DEN8(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 I BGPACTUP,BGPI8 S BGPI8DA=1

 I BGPACTCL,BGPI8 S BGPI8DB=1

 S BGPI81=$$DEN81(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 I BGPACTCL,BGPI81 S BGPI8DC=1

 S BGPI82=$$DEN82(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 I BGPACTUP,BGPI82 S BGPI8DE=1

 I BGPACTCL,BGPI82 S BGPI8DD=1

 I 'BGPI8DA,'BGPI8DB,'BGPI8DC,'BGPI8DD,'BGPI8DE S BGPSTOP=1 Q  ;not in ANY denom so quit

 I BGPRTYPE=3,'BGPI8DC S BGPSTOP=1 Q  ;not in hedis denominator so stop

 S BGPMAM=$$MAM(DFN,BGPEDATE,2)

 S BGPN1=0 I $P(BGPMAM,U)=1 S BGPN1=1

 I $P(BGPMAM,U,3)["Ref" S BGPN2=1

 I BGPN1,'BGPN2 S BGPN3=1

 I BGPRTYPE'=3 S BGPVALUE=$S(BGPI8DA!(BGPI8DE):"UP",1:"")_$S(BGPI8DB!(BGPI8DD):",AC",1:"")_","_$S(BGPI82:">41",1:"")_$S(BGPI8:",52-64",1:"")_"|||"_$$DATE^BGP1UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)

 I BGPRTYPE=1 S BGPVALUE=$S(BGPI8DA!(BGPI8DE):"UP",1:"")_$S(BGPI8DB!(BGPI8DD):",AC",1:"")_"|||" I BGPN3 S BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)

 I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP3UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)

 S BGPVALUD="" I BGPI8DD S BGPVALUD="AC 42+|||" I BGPN3 S BGPVALUD=BGPVALUD_$$DATE^BGP3UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)

 K BGPI81,BGPI82,BGPI8,BGPMAM

 Q

 ;

DEN8(P,AGEB,AGEE,SEX,EDATE) ;EP - is women in ind 8

 I SEX'="F" Q 0

 I AGEB<52 Q 0

 I AGEE>64 Q 0

 I $$MAS(P,EDATE) Q 0

 Q 1

DEN82(P,AGEB,AGEE,SEX,EDATE) ;is women 40+

 I SEX'="F" Q 0

 I AGEB<42 Q 0

 I $$MAS(P,EDATE) Q 0

 Q 1

DEN81(P,AGEB,AGEE,SEX,EDATE) ;is women in ind 8

 I SEX'="F" Q 0

 I AGEB<42 Q 0

 I AGEE>69 Q 0

 I $$MAS(P,EDATE) Q 0

 Q 1

MAM(P,EDATE,YEARS,FORECAST) ;EP

 S FORECAST=$G(FORECAST)

 S BGPLMAM=""

 K BGP S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))

 S (X,Y,V)=0,G="" F  S X=$O(^AUPNVRAD("AC",P,X)) Q:X'=+X  D

 .Q:'$D(^AUPNVRAD(X,0))

 .S V=$P(^AUPNVRAD(X,0),U,3)

 .Q:V=""

 .S V=$P($P($G(^AUPNVSIT(V,0)),U),".")

 .Q:V>EDATE

 .Q:V<BDATE

 .S Y=$P(^AUPNVRAD(X,0),U),Y=$P($G(^RAMIS(71,Y,0)),U,9)

 .Q:Y=""

 .Q:'$$ICD^ATXCHK(Y,$S(BGPRTYPE'=3:$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$O(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))),1)

 .S Y=$P($$CPT^ICPTCOD(Y),U,2)

 .I $P(BGPLMAM,U,2)<V S BGPLMAM="1^"_V_U_"RAD "_Y Q

 .Q

 ;I G]"" Q G

 K BGP  ; S BGP(1)=$$LASTDX^BGP3UTL1(P,"BGP MAMMOGRAM ICDS",BDATE,EDATE)

 ;I $P(BGP(1),U,1),$P(BGPLMAM,U,2)<$P(BGP(1),U,3) S BGPLMAM="1^"_$P(BGP(1),U,3)_"^POV "_$P(BGP(1),U,2)

 S Y="BGP("

 S X=P_"^LAST DX [BGP MAMMOGRAM DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U,1) S BGPLMAM="1^"_$P(BGP(1),U)_"^POV "_$P(BGP(1),U,2)

MP ;

 K BGP S BGP(1)=$$LASTPRC^BGP3UTL1(P,"BGP MAMMOGRAM PROCEDURES",BDATE,EDATE)

 I $P(BGP(1),U,1),$P(BGPLMAM,U,2)<$P(BGP(1),U,3) S BGPLMAM="1^"_$P(BGP(1),U,3)_"^PROC "_$P(BGP(1),U,2)

 S T=$O(^ATXAX("B","BGP CPT MAMMOGRAM",0))

 I BGPRTYPE=3 S T=$O(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))

 I T D  I X]"",$P(BGPLMAM,U,2)<$P(X,U,1) S BGPLMAM="1^"_$P(X,U,1)_"^"_"CPT "_$P(X,U,2)

 .S X=$$CPT^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q

 .S X=$$TRAN^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)

 S T="MAMMOGRAM SCREENING",T=$O(^BWPN("B",T,0))

 I T D  I $P(BGPLMAM,U,2)<X S BGPLMAM="1^"_X_"^WH"

 .S X=$$WH^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

 S T="MAMMOGRAM DX BILAT",T=$O(^BWPN("B",T,0))

 I T D  I $P(BGPLMAM,U,2)<X S BGPLMAM="1^"_X_"^WH"

 .S X=$$WH^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

 S T="MAMMOGRAM DX UNILAT",T=$O(^BWPN("B",T,0))

 I T D  I $P(BGPLMAM,U,2)<X S BGPLMAM="1^"_X_"^WH"

 .S X=$$WH^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

 I BGPLMAM]"" Q BGPLMAM

 ;

 I $G(FORECAST) Q ""

 S T=$$CPTREFT^BGP3UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$S(BGPRTYPE'=3:$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$O(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))

 I T S T="1^"_$P(T,U,2)_"^Refused CPT "_$P(T,U,4) Q T

 S T=$$RADREF^BGP3UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$S(BGPRTYPE'=3:$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$O(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))

 I T S T="1^"_$P(T,U,2)_"^Refused RAD/CPT "_$P(T,U,4)

 Q $S(T:T,1:"")

MAS(P,EDATE) ;EP mastectomy before end of time frame

 NEW BGP,X,Y,Z,G,T,%,D,M,BGPX,E,BGPRL

 K BGP

 S BGP(1)=$$LASTPRC^BGP3UTL1(P,"BGP MASTECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)

 I $P(BGP(1),U) Q 1

 ;check cpt codes for bilateral

 ;loop through all cpt codes up to Edate and if any match quit

 S (X,Y,Z,G)=0 K BGPX,BGPRL

 S T=$O(^ATXAX("B","BGP MASTECTOMY CPTS",0))

 I T S %="" D  I %]"" Q 1

 .S Y=0 F  S Y=$O(^AUPNVCPT("AC",P,Y)) Q:Y'=+Y!(%]"")  D

 ..S D=$P($G(^AUPNVCPT(Y,0)),U,3)

 ..Q:D=""

 ..S D=$P($P($G(^AUPNVSIT(D,0)),U),".") ;date done

 ..Q:D=""

 ..I D>EDATE Q

 ..S X=$P(^AUPNVCPT(Y,0),U)

 ..Q:'$$ICD^ATXCHK(X,T,1)

 ..S BGPX(D)=""

 ..I ^DD(9000010.18,.08,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1

 ..I ^DD(9000010.18,.09,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1

 ..I ^DD(9000010.08,.08,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1

 ..I ^DD(9000010.08,.09,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1

 ..I ^DD(9000010.18,.08,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) S BGPRL(D,M)=""

 ..I ^DD(9000010.18,.09,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) S BGPRL(D,M)=""

 ..I ^DD(9000010.08,.08,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^DIC(81.3,M,0)),U) S BGPRL(D,M)=""

 ..I ^DD(9000010.08,.09,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^DIC(81.3,M,0)),U) S BGPRL(D,M)=""

 ..Q

 .Q

 ; now check tran codes

 I T,$D(^AUPNVTC("AC",P)) S %="" D  I %]"" Q 1

 .S E=0 F  S E=$O(^AUPNVTC("AC",P,E)) Q:E'=+E!(%]"")  D

 ..S D=$P($G(^AUPNVTC(E,0)),U,3) Q:'D  S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 ..Q:'$$ICD^ATXCHK($P(^AUPNVTC(E,0),U,7),T,1)

 ..I D>EDATE Q

 ..S BGPX(D)=""

 ..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1

 ..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1

 ..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1

 ..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1

 ..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^AUTTCMOD(M,0)),U) S BGPRL(D,M)=""

 ..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^AUTTCMOD(M,0)),U) S BGPRL(D,M)=""

 ..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^DIC(81.3,M,0)),U) S BGPRL(D,M)=""

 ..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^DIC(81.3,M,0)),U) S BGPRL(D,M)=""

 ..Q

 .Q

 ;see if 2 on different dates

 S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1

 I C>1 Q 1

 K BGPX

 S T=$O(^ATXAX("B","BGP UNI MASTECTOMY PROCEDURES",0))

 S (F,S)=0 F  S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F  S C=$P(^AUPNVPRC(F,0),U) D

 .S G=0 S:$$ICD^ATXCHK(C,T,0) G=1

 .Q:G=0

 .S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")

 .I D>EDATE Q

 .S BGPX(D)=$G(BGPX(D))+1

 ;see if 2 on different dates

 S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1

 I C>1 Q 1

 ;SEE IF THERE IS A RT AND A LT

 S G="",D=0 F  S D=$O(BGPRL(D)) Q:D'=+D  D

 .I $D(BGPRL(D,"RT")),$D(BGPRL(D,"LT")) S G=1

 I G Q 1

 Q 0

BGP3D4    ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;

 +1       ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7

 +2       ;

I16       ;EP

 +1        KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPMAM,BGPI8,BGPI81,BGPI8DA,BGPI8DB,BGPI8DC,BGPI8DD,BGPI8DE

 +2        SET BGPI8DA=0

           SET BGPI8DB=0

           SET BGPN1=0

           SET BGPN2=0

           SET BGPN3=0

           SET BGPI8DC=0

           SET BGPI8DD=0

           SET BGPI8DE=0

 +3        SET BGPI8=$$DEN8(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 +4        IF BGPACTUP

               IF BGPI8

                   SET BGPI8DA=1

 +5        IF BGPACTCL

               IF BGPI8

                   SET BGPI8DB=1

 +6        SET BGPI81=$$DEN81(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 +7        IF BGPACTCL

               IF BGPI81

                   SET BGPI8DC=1

 +8        SET BGPI82=$$DEN82(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 +9        IF BGPACTUP

               IF BGPI82

                   SET BGPI8DE=1

 +10       IF BGPACTCL

               IF BGPI82

                   SET BGPI8DD=1

 +11      ;not in ANY denom so quit

           IF 'BGPI8DA

               IF 'BGPI8DB

                   IF 'BGPI8DC

                       IF 'BGPI8DD

                           IF 'BGPI8DE

                               SET BGPSTOP=1

                               QUIT 

 +12      ;not in hedis denominator so stop

           IF BGPRTYPE=3

               IF 'BGPI8DC

                   SET BGPSTOP=1

                   QUIT 

 +13       SET BGPMAM=$$MAM(DFN,BGPEDATE,2)

 +14       SET BGPN1=0

           IF $PIECE(BGPMAM,U)=1

               SET BGPN1=1

 +15       IF $PIECE(BGPMAM,U,3)["Ref"

               SET BGPN2=1

 +16       IF BGPN1

               IF 'BGPN2

                   SET BGPN3=1

 +17       IF BGPRTYPE'=3

               SET BGPVALUE=$SELECT(BGPI8DA!(BGPI8DE):"UP",1:"")_$SELECT(BGPI8DB!(BGPI8DD):",AC",1:"")_","_$SELECT(BGPI82:">41",1:"")_$SELECT(BGPI8:",52-64",1:"")_"|||"_$$DATE^BGP1UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)

 +18       IF BGPRTYPE=1

               SET BGPVALUE=$SELECT(BGPI8DA!(BGPI8DE):"UP",1:"")_$SELECT(BGPI8DB!(BGPI8DD):",AC",1:"")_"|||"

               IF BGPN3

                   SET BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)

 +19       IF BGPRTYPE=3

               SET BGPVALUE="AC|||"_$$DATE^BGP3UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)

 +20       SET BGPVALUD=""

           IF BGPI8DD

               SET BGPVALUD="AC 42+|||"

               IF BGPN3

                   SET BGPVALUD=BGPVALUD_$$DATE^BGP3UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)

 +21       KILL BGPI81,BGPI82,BGPI8,BGPMAM

 +22       QUIT 

 +23      ;

DEN8(P,AGEB,AGEE,SEX,EDATE) ;EP - is women in ind 8

 +1        IF SEX'="F"

               QUIT 0

 +2        IF AGEB<52

               QUIT 0

 +3        IF AGEE>64

               QUIT 0

 +4        IF $$MAS(P,EDATE)

               QUIT 0

 +5        QUIT 1

DEN82(P,AGEB,AGEE,SEX,EDATE) ;is women 40+

 +1        IF SEX'="F"

               QUIT 0

 +2        IF AGEB<42

               QUIT 0

 +3        IF $$MAS(P,EDATE)

               QUIT 0

 +4        QUIT 1

DEN81(P,AGEB,AGEE,SEX,EDATE) ;is women in ind 8

 +1        IF SEX'="F"

               QUIT 0

 +2        IF AGEB<42

               QUIT 0

 +3        IF AGEE>69

               QUIT 0

 +4        IF $$MAS(P,EDATE)

               QUIT 0

 +5        QUIT 1

MAM(P,EDATE,YEARS,FORECAST) ;EP

 +1        SET FORECAST=$GET(FORECAST)

 +2        SET BGPLMAM=""

 +3        KILL BGP

           SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))

 +4        SET (X,Y,V)=0

           SET G=""

           FOR 

               SET X=$ORDER(^AUPNVRAD("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                IF '$DATA(^AUPNVRAD(X,0))

                       QUIT 

 +6                SET V=$PIECE(^AUPNVRAD(X,0),U,3)

 +7                IF V=""

                       QUIT 

 +8                SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")

 +9                IF V>EDATE

                       QUIT 

 +10               IF V<BDATE

                       QUIT 

 +11               SET Y=$PIECE(^AUPNVRAD(X,0),U)

                   SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)

 +12               IF Y=""

                       QUIT 

 +13               IF '$$ICD^ATXCHK(Y,$SELECT(BGPRTYPE'=3

                       QUIT 

 +14               SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)

 +15               IF $PIECE(BGPLMAM,U,2)<V

                       SET BGPLMAM="1^"_V_U_"RAD "_Y

                       QUIT 

 +16               QUIT 

               End DoDot:1

 +17      ;I G]"" Q G

 +18      ; S BGP(1)=$$LASTDX^BGP3UTL1(P,"BGP MAMMOGRAM ICDS",BDATE,EDATE)

           KILL BGP

 +19      ;I $P(BGP(1),U,1),$P(BGPLMAM,U,2)<$P(BGP(1),U,3) S BGPLMAM="1^"_$P(BGP(1),U,3)_"^POV "_$P(BGP(1),U,2)

 +20       SET Y="BGP("

 +21       SET X=P_"^LAST DX [BGP MAMMOGRAM DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,Y)

 +22       IF $DATA(BGP(1))

               IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U,1)

                   SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^POV "_$PIECE(BGP(1),U,2)

MP        ;

 +1        KILL BGP

           SET BGP(1)=$$LASTPRC^BGP3UTL1(P,"BGP MAMMOGRAM PROCEDURES",BDATE,EDATE)

 +2        IF $PIECE(BGP(1),U,1)

               IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U,3)

                   SET BGPLMAM="1^"_$PIECE(BGP(1),U,3)_"^PROC "_$PIECE(BGP(1),U,2)

 +3        SET T=$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0))

 +4        IF BGPRTYPE=3

               SET T=$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))

 +5        IF T

               Begin DoDot:1

 +6                SET X=$$CPT^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)

                   IF X]""

                       QUIT 

 +7                SET X=$$TRAN^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)

               End DoDot:1

               IF X]""

                   IF $PIECE(BGPLMAM,U,2)<$PIECE(X,U,1)

                       SET BGPLMAM="1^"_$PIECE(X,U,1)_"^"_"CPT "_$PIECE(X,U,2)

 +8        SET T="MAMMOGRAM SCREENING"

           SET T=$ORDER(^BWPN("B",T,0))

 +9        IF T

               Begin DoDot:1

 +10               SET X=$$WH^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

               End DoDot:1

               IF $PIECE(BGPLMAM,U,2)<X

                   SET BGPLMAM="1^"_X_"^WH"

 +11       SET T="MAMMOGRAM DX BILAT"

           SET T=$ORDER(^BWPN("B",T,0))

 +12       IF T

               Begin DoDot:1

 +13               SET X=$$WH^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

               End DoDot:1

               IF $PIECE(BGPLMAM,U,2)<X

                   SET BGPLMAM="1^"_X_"^WH"

 +14       SET T="MAMMOGRAM DX UNILAT"

           SET T=$ORDER(^BWPN("B",T,0))

 +15       IF T

               Begin DoDot:1

 +16               SET X=$$WH^BGP3DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

               End DoDot:1

               IF $PIECE(BGPLMAM,U,2)<X

                   SET BGPLMAM="1^"_X_"^WH"

 +17       IF BGPLMAM]""

               QUIT BGPLMAM

 +18      ;

 +19       IF $GET(FORECAST)

               QUIT ""

 +20       SET T=$$CPTREFT^BGP3UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$SELECT(BGPRTYPE'=3:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))

 +21       IF T

               SET T="1^"_$PIECE(T,U,2)_"^Refused CPT "_$PIECE(T,U,4)

               QUIT T

 +22       SET T=$$RADREF^BGP3UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$SELECT(BGPRTYPE'=3:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))

 +23       IF T

               SET T="1^"_$PIECE(T,U,2)_"^Refused RAD/CPT "_$PIECE(T,U,4)

 +24       QUIT $SELECT(T:T,1:"")

MAS(P,EDATE) ;EP mastectomy before end of time frame

 +1        NEW BGP,X,Y,Z,G,T,%,D,M,BGPX,E,BGPRL

 +2        KILL BGP

 +3        SET BGP(1)=$$LASTPRC^BGP3UTL1(P,"BGP MASTECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)

 +4        IF $PIECE(BGP(1),U)

               QUIT 1

 +5       ;check cpt codes for bilateral

 +6       ;loop through all cpt codes up to Edate and if any match quit

 +7        SET (X,Y,Z,G)=0

           KILL BGPX,BGPRL

 +8        SET T=$ORDER(^ATXAX("B","BGP MASTECTOMY CPTS",0))

 +9        IF T

               SET %=""

               Begin DoDot:1

 +10               SET Y=0

                   FOR 

                       SET Y=$ORDER(^AUPNVCPT("AC",P,Y))

                       IF Y'=+Y!(%]"")

                           QUIT 

                       Begin DoDot:2

 +11                       SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)

 +12                       IF D=""

                               QUIT 

 +13      ;date done

                           SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +14                       IF D=""

                               QUIT 

 +15                       IF D>EDATE

                               QUIT 

 +16                       SET X=$PIECE(^AUPNVCPT(Y,0),U)

 +17                       IF '$$ICD^ATXCHK(X,T,1)

                               QUIT 

 +18                       SET BGPX(D)=""

 +19                       IF ^DD(9000010.18,.08,0)["AUTTCMOD"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,8)

                               IF M

                                   SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)

                                   IF M=50

                                       SET %=1

 +20                       IF ^DD(9000010.18,.09,0)["AUTTCMOD"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,9)

                               IF M

                                   SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)

                                   IF M=50

                                       SET %=1

 +21                       IF ^DD(9000010.08,.08,0)["DIC(81.3"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,8)

                               IF M

                                   SET M=$PIECE($GET(^DIC(81.3,M,0)),U)

                                   IF M=50

                                       SET %=1

 +22                       IF ^DD(9000010.08,.09,0)["DIC(81.3"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,9)

                               IF M

                                   SET M=$PIECE($GET(^DIC(81.3,M,0)),U)

                                   IF M=50

                                       SET %=1

 +23                       IF ^DD(9000010.18,.08,0)["AUTTCMOD"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,8)

                               IF M

                                   SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)

                                   SET BGPRL(D,M)=""

 +24                       IF ^DD(9000010.18,.09,0)["AUTTCMOD"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,9)

                               IF M

                                   SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)

                                   SET BGPRL(D,M)=""

 +25                       IF ^DD(9000010.08,.08,0)["DIC(81.3"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,8)

                               IF M

                                   SET M=$PIECE($GET(^DIC(81.3,M,0)),U)

                                   SET BGPRL(D,M)=""

 +26                       IF ^DD(9000010.08,.09,0)["DIC(81.3"

                               SET M=$PIECE(^AUPNVCPT(Y,0),U,9)

                               IF M

                                   SET M=$PIECE($GET(^DIC(81.3,M,0)),U)

                                   SET BGPRL(D,M)=""

 +27                       QUIT 

                       End DoDot:2

 +28               QUIT 

               End DoDot:1

               IF %]""

                   QUIT 1

 +29      ; now check tran codes

 +30       IF T

               IF $DATA(^AUPNVTC("AC",P))

                   SET %=""

                   Begin DoDot:1

 +31                   SET E=0

                       FOR 

                           SET E=$ORDER(^AUPNVTC("AC",P,E))

                           IF E'=+E!(%]"")

                               QUIT 

                           Begin DoDot:2

 +32                           SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)

                               IF 'D

                                   QUIT 

                               SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +33                           IF '$$ICD^ATXCHK($PIECE(^AUPNVTC(E,0),U,7),T,1)

                                   QUIT 

 +34                           IF D>EDATE

                                   QUIT 

 +35                           SET BGPX(D)=""

 +36                           IF '$DATA(^DIC(81.3,0))

                                   SET M=$PIECE(^AUPNVTC(E,0),U,12)

                                   IF M

                                       SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)

                                       IF M=50

                                           SET %=1

 +37                           IF '$DATA(^DIC(81.3,0))

                                   SET M=$PIECE(^AUPNVTC(E,0),U,15)

                                   IF M

                                       SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)

                                       IF M=50

                                           SET %=1

 +38                           IF $DATA(^DIC(81.3,0))

                                   SET M=$PIECE(^AUPNVTC(E,0),U,12)

                                   IF M

                                       SET M=$PIECE($GET(^DIC(81.3,M,0)),U)

                                       IF M=50

                                           SET %=1

 +39                           IF $DATA(^DIC(81.3,0))

                                   SET M=$PIECE(^AUPNVTC(E,0),U,15)

                                   IF M

                                       SET M=$PIECE($GET(^DIC(81.3,M,0)),U)