BGP6D4 ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
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=0 ;$$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 'BGPI8DA,'BGPI8DB S BGPSTOP=1 Q
;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:"UP",1:"")_$S(BGPI8DB:",AC",1:"")_"|||"_$$DATE^BGP1UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
I BGPRTYPE=1 S BGPVALUE=$S(BGPI8DA:"UP",1:"")_$S(BGPI8DB:",AC",1:"")_"|||" I BGPN3 S BGPVALUE=BGPVALUE_$$DATE^BGP6UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
;I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP6UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
;S BGPVALUD="" I BGPI8DD S BGPVALUD="AC 52-74|||" I BGPN3 S BGPVALUD=BGPVALUD_$$DATE^BGP6UTL($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^BGP6UTL2(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^BGP6UTL1(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^BGP6UTL1(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^BGP6DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP6DU(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^BGP6DU(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^BGP6DU(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^BGP6DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
I BGPLMAM]"" Q BGPLMAM
;
I $G(FORECAST) Q ""
S T=$$CPTREFT^BGP6UTL1(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^BGP6UTL1(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,T1
K BGP
S BGP(1)=$$LASTPRC^BGP6UTL1(P,"BGP MASTECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I $P(BGP(1),U) Q 1
S BGP(1)=$$LASTDX^BGP6UTL1(P,"BGP MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
I $P(BGP(1),U,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,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^BGP6UTL2(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.18,.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.18,.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
..Q:%
..S M=""
..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.18,.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.18,.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)=""
..I $O(BGPRL(D,""))="" S BGPRL(D,"UNK")=""
..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^BGP6UTL2($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
..Q:%
..S M=""
..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)=""
..I $O(BGPRL(D,""))="" S BGPRL(D,"UNK")=""
..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 ;HAD 2 CPTS ON 2 DIFFERENT DATES
;K BGPX
;ADD IN UNKNOWN PROCEDURES
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^BGP6UTL2(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
.I '$D(BGPX(D)) S BGPX(D)=""
.I '$D(BGPRL(D)) S BGPRL(D,"UNK")=""
;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 ;HAD 2 UNKNOWNS
;ADD IN ICD10 RIGHT AND LEFT CODES
S T=$O(^ATXAX("B","BGP UNI RIGHT MASTECTOMY PROCS",0))
S T1=$O(^ATXAX("B","BGP UNI LEFT MASTECTOMY PROCS",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=""
.I $$ICD^BGP6UTL2(C,T,0) S G="RT"
.I $$ICD^BGP6UTL2(C,T1,0) S G="LT"
.Q:G=""
.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 BGPRL(D,G)=""
;ADD IN ALL DXS
S X=$$LASTDX^BGP6UTL1(P,"BGP RIGHT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL($P(X,U,3),"RT")=""
S X=$$LASTDX^BGP6UTL1(P,"BGP LEFT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL($P(X,U,3),"LT")=""
;SEE IF THERE IS A RT AND A LT
S G="",D=0,R="",L="" F S D=$O(BGPRL(D)) Q:D'=+D D
.I $D(BGPRL(D,"RT")) S R=D
.I $D(BGPRL(D,"LT")) S L=D
I R,L Q 1
;CHECK UNKNOWNS AND RT / LT
S X=0
S D=0 F S D=$O(BGPRL(D)) Q:D'=+D D
.I $D(BGPRL(D,"UNK")),R,R'=D S X=1
.I $D(BGPRL(D,"UNK")),L,L'=D S X=1
Q X
BGP6D4 ; IHS/CMI/LAB - measure 3 11 Dec 2009 5:58 PM 12 Sep 2010 10:17 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+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 ;S BGPI81=$$DEN81(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+7 ;I BGPACTCL,BGPI81 S BGPI8DC=1
+8 ;S BGPI82=0 ;$$DEN82(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+9 ;I BGPACTUP,BGPI82 S BGPI8DE=1
+10 ;I BGPACTCL,BGPI82 S BGPI8DD=1
+11 ;I 'BGPI8DA,'BGPI8DB,'BGPI8DC,'BGPI8DD,'BGPI8DE S BGPSTOP=1 Q ;not in ANY denom so quit
+12 IF 'BGPI8DA
IF 'BGPI8DB
SET BGPSTOP=1
QUIT
+13 ;I BGPRTYPE=3,'BGPI8DC S BGPSTOP=1 Q ;not in hedis denominator so stop
+14 SET BGPMAM=$$MAM(DFN,BGPEDATE,2)
+15 SET BGPN1=0
IF $PIECE(BGPMAM,U)=1
SET BGPN1=1
+16 IF $PIECE(BGPMAM,U,3)["Ref"
SET BGPN2=1
+17 IF BGPN1
IF 'BGPN2
SET BGPN3=1
+18 IF BGPRTYPE'=3
SET BGPVALUE=$SELECT(BGPI8DA:"UP",1:"")_$SELECT(BGPI8DB:",AC",1:"")_"|||"_$$DATE^BGP1UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+19 IF BGPRTYPE=1
SET BGPVALUE=$SELECT(BGPI8DA:"UP",1:"")_$SELECT(BGPI8DB:",AC",1:"")_"|||"
IF BGPN3
SET BGPVALUE=BGPVALUE_$$DATE^BGP6UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+20 ;I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP6UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
+21 ;S BGPVALUD="" I BGPI8DD S BGPVALUD="AC 52-74|||" I BGPN3 S BGPVALUD=BGPVALUD_$$DATE^BGP6UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
+22 KILL BGPI81,BGPI82,BGPI8,BGPMAM
+23 QUIT
+24 ;
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^BGP6UTL2(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^BGP6UTL1(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^BGP6UTL1(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^BGP6DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP6DU(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^BGP6DU(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^BGP6DU(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^BGP6DU(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^BGP6UTL1(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^BGP6UTL1(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,T1
+2 KILL BGP
+3 SET BGP(1)=$$LASTPRC^BGP6UTL1(P,"BGP MASTECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+4 IF $PIECE(BGP(1),U)
QUIT 1
+5 SET BGP(1)=$$LASTDX^BGP6UTL1(P,"BGP MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
+6 IF $PIECE(BGP(1),U,1)
QUIT 1
+7 ;check cpt codes for bilateral
+8 ;loop through all cpt codes up to Edate and if any match quit
+9 SET (X,Y,Z,G)=0
KILL BGPX,BGPRL
+10 SET T=$ORDER(^ATXAX("B","BGP MASTECTOMY CPTS",0))
+11 IF T
SET %=""
Begin DoDot:1
+12 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(%]"")
QUIT
Begin DoDot:2
+13 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+14 IF D=""
QUIT
+15 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+16 IF D=""
QUIT
+17 IF D>EDATE
QUIT
+18 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+19 IF '$$ICD^BGP6UTL2(X,T,1)
QUIT
+20 SET BGPX(D)=""
+21 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
+22 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
+23 IF ^DD(9000010.18,.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
+24 IF ^DD(9000010.18,.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
+25 IF %
QUIT
+26 SET M=""
+27 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)=""
+28 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)=""
+29 IF ^DD(9000010.18,.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)=""
+30 IF ^DD(9000010.18,.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)=""
+31 IF $ORDER(BGPRL(D,""))=""
SET BGPRL(D,"UNK")=""
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
IF %]""
QUIT 1
+34 ; now check tran codes
+35 IF T
IF $DATA(^AUPNVTC("AC",P))
SET %=""
Begin DoDot:1
+36 SET E=0
FOR
SET E=$ORDER(^AUPNVTC("AC",P,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+37 SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)
IF 'D
QUIT
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+38 IF '$$ICD^BGP6UTL2($PIECE(^AUPNVTC(E,0),U,7),T,1)
QUIT
+39 IF D>EDATE
QUIT
+40 SET BGPX(D)=""
+41 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
+42 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
+43 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
+44 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
+45 IF %
QUIT
+46 SET M=""
+47 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)=""
+48 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)=""
+49 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)=""
+50 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)=""
+51 IF $ORDER(BGPRL(D,""))=""
SET BGPRL(D,"UNK")=""
+52 QUIT
End DoDot:2
+53 QUIT
End DoDot:1
IF %]""
QUIT 1
+54 ;see if 2 on different dates
+55 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+56 ;HAD 2 CPTS ON 2 DIFFERENT DATES
IF C>1
QUIT 1
+57 ;K BGPX
+58 ;ADD IN UNKNOWN PROCEDURES
+59 SET T=$ORDER(^ATXAX("B","BGP UNI MASTECTOMY PROCEDURES",0))
+60 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
+61 SET G=0
IF $$ICD^BGP6UTL2(C,T,0)
SET G=1
+62 IF G=0
QUIT
+63 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+64 IF D>EDATE
QUIT
+65 IF '$DATA(BGPX(D))
SET BGPX(D)=""
+66 IF '$DATA(BGPRL(D))
SET BGPRL(D,"UNK")=""
End DoDot:1
+67 ;see if 2 on different dates
+68 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+69 ;HAD 2 UNKNOWNS
IF C>1
QUIT 1
+70 ;ADD IN ICD10 RIGHT AND LEFT CODES
+71 SET T=$ORDER(^ATXAX("B","BGP UNI RIGHT MASTECTOMY PROCS",0))
+72 SET T1=$ORDER(^ATXAX("B","BGP UNI LEFT MASTECTOMY PROCS",0))
+73 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
+74 SET G=""
+75 IF $$ICD^BGP6UTL2(C,T,0)
SET G="RT"
+76 IF $$ICD^BGP6UTL2(C,T1,0)
SET G="LT"
+77 IF G=""
QUIT
+78 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+79 IF D>EDATE
QUIT
+80 SET BGPRL(D,G)=""
End DoDot:1
+81 ;ADD IN ALL DXS
+82 SET X=$$LASTDX^BGP6UTL1(P,"BGP RIGHT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
IF X
SET BGPRL($PIECE(X,U,3),"RT")=""
+83 SET X=$$LASTDX^BGP6UTL1(P,"BGP LEFT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
IF X
SET BGPRL($PIECE(X,U,3),"LT")=""
+84 ;SEE IF THERE IS A RT AND A LT
+85 SET G=""
SET D=0
SET R=""
SET L=""
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+86 IF $DATA(BGPRL(D,"RT"))
SET R=D
+87 IF $DATA(BGPRL(D,"LT"))
SET L=D
End DoDot:1
+88 IF R
IF L
QUIT 1
+89 ;CHECK UNKNOWNS AND RT / LT
+90 SET X=0
+91 SET D=0
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+92 IF $DATA(BGPRL(D,"UNK"))
IF R
IF R'=D
SET X=1
+93 IF $DATA(BGPRL(D,"UNK"))
IF L
IF L'=D
SET X=1
End DoDot:1
+94 QUIT X
