BGP1D4 ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
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=3 S BGPVALUE="AC|||"_$$DATE^BGP1UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
S BGPVALUD="" I BGPI8DD S BGPVALUD="AC 42+|||"_$$DATE^BGP1UTL($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 %=P_"^LAST DX V76.11;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U) S BGPLMAM="1^"_$P(BGP(1),U)_"^POV V76.11"
K BGP S %=P_"^LAST DX V76.12;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U) S BGPLMAM="1^"_$P(BGP(1),U)_"^POV V76.12"
I BGPRTYPE=3 G MP ;if HEDIS don't use next 3 diagnoses
K BGP S %=P_"^LAST DX 793.80;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U) S BGPLMAM="1^"_$P(BGP(1),U)_"^POV 793.80"
K BGP S %=P_"^LAST DX 793.81;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U) S BGPLMAM="1^"_$P(BGP(1),U)_"^POV 793.81"
K BGP S %=P_"^LAST DX 793.89;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U) S BGPLMAM="1^"_$P(BGP(1),U)_"^POV 793.89"
MP ;
K BGP S %=P_"^LAST PROCEDURE 87.37;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U) S BGPLMAM="1^"_$P(BGP(1),U)_"^PROC 87.37"
K BGP S %=P_"^LAST PROCEDURE 87.36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLMAM,U,2)<$P(BGP(1),U) S BGPLMAM="1^"_$P(BGP(1),U)_"^PROC 87.36"
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^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP1DU(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^BGP1DU(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^BGP1DU(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^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
;S T="MAMMOGRAM,UNSPECIFIED",T=$O(^BWPN("B",T,0))
;I T D I $P(BGPLMAM,U,2)<X S BGPLMAM="1^"_X_"^WH"
;.S X=$$WH^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(2*365)),EDATE,T,3)
I BGPLMAM]"" Q BGPLMAM
;
I $G(FORECAST) Q ""
S T=$$CPTREFT^BGP1UTL1(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)_"^ref CPT "_$P(T,U,4) Q T
S T=$$RADREF^BGP1UTL1(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)_"^ref Rad/CPT "_$P(T,U,4)
Q $S(T:T,1:"")
MAS(P,EDATE) ;EP mastectomy before end of time frame
K BGP S %=P_"^LAST PROCEDURE 85.42;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)) Q 1
K BGP S %=P_"^LAST PROCEDURE 85.44;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)) Q 1
K BGP S %=P_"^LAST PROCEDURE 85.46;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)) Q 1
K BGP S %=P_"^LAST PROCEDURE 85.48;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)) 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
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)=""
..S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..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)=""
..S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..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 %=P_"^ALL PROCEDURE [BGP UNI MASTECTOMY PROCEDURES;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
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
Q 0
BGP1D4 ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+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=3
SET BGPVALUE="AC|||"_$$DATE^BGP1UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+19 SET BGPVALUD=""
IF BGPI8DD
SET BGPVALUD="AC 42+|||"_$$DATE^BGP1UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+20 KILL BGPI81,BGPI82,BGPI8,BGPMAM
+21 QUIT
+22 ;
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 KILL BGP
SET %=P_"^LAST DX V76.11;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+19 IF $DATA(BGP(1))
IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U)
SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^POV V76.11"
+20 KILL BGP
SET %=P_"^LAST DX V76.12;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+21 IF $DATA(BGP(1))
IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U)
SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^POV V76.12"
+22 ;if HEDIS don't use next 3 diagnoses
IF BGPRTYPE=3
GOTO MP
+23 KILL BGP
SET %=P_"^LAST DX 793.80;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+24 IF $DATA(BGP(1))
IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U)
SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^POV 793.80"
+25 KILL BGP
SET %=P_"^LAST DX 793.81;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+26 IF $DATA(BGP(1))
IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U)
SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^POV 793.81"
+27 KILL BGP
SET %=P_"^LAST DX 793.89;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+28 IF $DATA(BGP(1))
IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U)
SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^POV 793.89"
MP ;
+1 KILL BGP
SET %=P_"^LAST PROCEDURE 87.37;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+2 IF $DATA(BGP(1))
IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U)
SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^PROC 87.37"
+3 KILL BGP
SET %=P_"^LAST PROCEDURE 87.36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+4 IF $DATA(BGP(1))
IF $PIECE(BGPLMAM,U,2)<$PIECE(BGP(1),U)
SET BGPLMAM="1^"_$PIECE(BGP(1),U)_"^PROC 87.36"
+5 SET T=$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0))
+6 IF BGPRTYPE=3
SET T=$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))
+7 IF T
Begin DoDot:1
+8 SET X=$$CPT^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
IF X]""
QUIT
+9 SET X=$$TRAN^BGP1DU(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)
+10 SET T="MAMMOGRAM SCREENING"
SET T=$ORDER(^BWPN("B",T,0))
+11 IF T
Begin DoDot:1
+12 SET X=$$WH^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
End DoDot:1
IF $PIECE(BGPLMAM,U,2)<X
SET BGPLMAM="1^"_X_"^WH"
+13 SET T="MAMMOGRAM DX BILAT"
SET T=$ORDER(^BWPN("B",T,0))
+14 IF T
Begin DoDot:1
+15 SET X=$$WH^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
End DoDot:1
IF $PIECE(BGPLMAM,U,2)<X
SET BGPLMAM="1^"_X_"^WH"
+16 SET T="MAMMOGRAM DX UNILAT"
SET T=$ORDER(^BWPN("B",T,0))
+17 IF T
Begin DoDot:1
+18 SET X=$$WH^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
End DoDot:1
IF $PIECE(BGPLMAM,U,2)<X
SET BGPLMAM="1^"_X_"^WH"
+19 ;S T="MAMMOGRAM,UNSPECIFIED",T=$O(^BWPN("B",T,0))
+20 ;I T D I $P(BGPLMAM,U,2)<X S BGPLMAM="1^"_X_"^WH"
+21 ;.S X=$$WH^BGP1DU(P,$$FMADD^XLFDT(EDATE,-(2*365)),EDATE,T,3)
+22 IF BGPLMAM]""
QUIT BGPLMAM
+23 ;
+24 IF $GET(FORECAST)
QUIT ""
+25 SET T=$$CPTREFT^BGP1UTL1(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))))
+26 IF T
SET T="1^"_$PIECE(T,U,2)_"^ref CPT "_$PIECE(T,U,4)
QUIT T
+27 SET T=$$RADREF^BGP1UTL1(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))))
+28 IF T
SET T="1^"_$PIECE(T,U,2)_"^ref Rad/CPT "_$PIECE(T,U,4)
+29 QUIT $SELECT(T:T,1:"")
MAS(P,EDATE) ;EP mastectomy before end of time frame
+1 KILL BGP
SET %=P_"^LAST PROCEDURE 85.42;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+2 IF $DATA(BGP(1))
QUIT 1
+3 KILL BGP
SET %=P_"^LAST PROCEDURE 85.44;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+4 IF $DATA(BGP(1))
QUIT 1
+5 KILL BGP
SET %=P_"^LAST PROCEDURE 85.46;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+6 IF $DATA(BGP(1))
QUIT 1
+7 KILL BGP
SET %=P_"^LAST PROCEDURE 85.48;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+8 IF $DATA(BGP(1))
QUIT 1
+9 ;check cpt codes for bilateral
+10 ;loop through all cpt codes up to Edate and if any match quit
+11 SET (X,Y,Z,G)=0
KILL BGPX
+12 SET T=$ORDER(^ATXAX("B","BGP MASTECTOMY CPTS",0))
+13 IF T
SET %=""
Begin DoDot:1
+14 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(%]"")
QUIT
Begin DoDot:2
+15 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+16 IF D=""
QUIT
+17 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+18 IF D=""
QUIT
+19 IF D>EDATE
QUIT
+20 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+21 IF '$$ICD^ATXCHK(X,T,1)
QUIT
+22 SET BGPX(D)=""
+23 SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+24 SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
IF %]""
QUIT 1
+27 ; now check tran codes
+28 IF T
IF $DATA(^AUPNVTC("AC",P))
SET %=""
Begin DoDot:1
+29 SET E=0
FOR
SET E=$ORDER(^AUPNVTC("AC",P,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+30 SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)
IF 'D
QUIT
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+31 IF '$$ICD^ATXCHK($PIECE(^AUPNVTC(E,0),U,7),T,1)
QUIT
+32 IF D>EDATE
QUIT
+33 SET BGPX(D)=""
+34 SET M=$PIECE(^AUPNVTC(E,0),U,12)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+35 SET M=$PIECE(^AUPNVTC(E,0),U,15)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
IF %]""
QUIT 1
+38 ;see if 2 on different dates
+39 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+40 IF C>1
QUIT 1
+41 KILL BGPX
+42 ;S %=P_"^ALL PROCEDURE [BGP UNI MASTECTOMY PROCEDURES;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
+43 SET T=$ORDER(^ATXAX("B","BGP UNI MASTECTOMY PROCEDURES",0))
+44 SET (F,S)=0
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F
QUIT
SET C=$PIECE(^AUPNVPRC(F,0),U)
Begin DoDot:1
+45 SET G=0
IF $$ICD^ATXCHK(C,T,0)
SET G=1
+46 IF G=0
QUIT
+47 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+48 IF D>EDATE
QUIT
+49 SET BGPX(D)=$GET(BGPX(D))+1
End DoDot:1
+50 QUIT 0
