BGP4D4 ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
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:"52-74",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^BGP4UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP4UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
S BGPVALUD="" I BGPI8DD S BGPVALUD="AC 52-74|||" I BGPN3 S BGPVALUD=BGPVALUD_$$DATE^BGP4UTL($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<52 Q 0
I AGEB>74 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^BGP4UTL2(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^BGP4UTL1(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^BGP4UTL1(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^BGP4DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP4DU(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^BGP4DU(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^BGP4DU(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^BGP4DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
I BGPLMAM]"" Q BGPLMAM
;
I $G(FORECAST) Q ""
S T=$$CPTREFT^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL2(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^BGP4UTL2($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^BGP4UTL2(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
BGP4D4 ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+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:"52-74",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^BGP4UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+19 IF BGPRTYPE=3
SET BGPVALUE="AC|||"_$$DATE^BGP4UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+20 SET BGPVALUD=""
IF BGPI8DD
SET BGPVALUD="AC 52-74|||"
IF BGPN3
SET BGPVALUD=BGPVALUD_$$DATE^BGP4UTL($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<52
QUIT 0
+3 IF AGEB>74
QUIT 0
+4 IF $$MAS(P,EDATE)
QUIT 0
+5 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^BGP4UTL2(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^BGP4UTL1(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^BGP4UTL1(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^BGP4DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP4DU(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^BGP4DU(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^BGP4DU(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^BGP4DU(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^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL2(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^BGP4UTL2($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)
IF M=50
SET %=1
+40 IF '$DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,12)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
SET BGPRL(D,M)=""
+41 IF '$DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,15)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
SET BGPRL(D,M)=""
+42 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)
SET BGPRL(D,M)=""
+43 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)
SET BGPRL(D,M)=""
+44 QUIT
End DoDot:2
+45 QUIT
End DoDot:1
IF %]""
QUIT 1
+46 ;see if 2 on different dates
+47 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+48 IF C>1
QUIT 1
+49 KILL BGPX
+50 SET T=$ORDER(^ATXAX("B","BGP UNI MASTECTOMY PROCEDURES",0))
+51 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
+52 SET G=0
IF $$ICD^BGP4UTL2(C,T,0)
SET G=1
+53 IF G=0
QUIT
+54 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+55 IF D>EDATE
QUIT
+56 SET BGPX(D)=$GET(BGPX(D))+1
End DoDot:1
+57 ;see if 2 on different dates
+58 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+59 IF C>1
QUIT 1
+60 ;SEE IF THERE IS A RT AND A LT
+61 SET G=""
SET D=0
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+62 IF $DATA(BGPRL(D,"RT"))
IF $DATA(BGPRL(D,"LT"))
SET G=1
End DoDot:1
+63 IF G
QUIT 1
+64 QUIT 0
