BGP8D4 ;IHS/CMI/LAB - MEASURE LOGIC 3;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
I16 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPMAM,BGPI8,BGPI81,BGPI8DA,BGPI8DB,BGPI8DC,BGPI8DD,BGPI8DE
S (BGPD1,BGPD2)=0
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
;NEW DENOM V18 BGPD1,BGPD2
S X=0
I BGPSEX="F",BGPAGEB>51,BGPAGEB<75,'$$MAS(DFN,BGPEDATE) S X=1
I X,BGPACTCL S BGPD1=1
I X,BGPACTUP S BGPD2=1
I 'BGPD1,'BGPD2,'BGPI8DA,'BGPI8DB S BGPSTOP=1 Q ;not in any denominator
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^BGP8UTL($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^BGP8UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
I BGPD2 S BGPVALUD="" S BGPVALUD="UP"_$S(BGPD1:",AC",1:"")_" 52-74|||" I BGPN3 S BGPVALUD=BGPVALUD_$$DATE^BGP8UTL($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^BGP8UTL2(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^BGP8UTL1(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^BGP8UTL1(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^BGP8DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(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^BGP8DU(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^BGP8DU(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^BGP8DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
I BGPLMAM]"" Q BGPLMAM
;
I $G(FORECAST) Q ""
S T=$$CPTREFT^BGP8UTL1(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^BGP8UTL1(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^BGP8UTL1(P,"BGP MASTECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I $P(BGP(1),U) Q 1
S BGP(1)=$$LASTDX^BGP8UTL1(P,"BGP MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
I $P(BGP(1),U,1) Q 1
;v17 problem list
S X=$$PLTAXND^BGP8DU(P,"BGP MASTECTOMY DXS",EDATE)
I X Q 1
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP BILAT MASTECTOMY",EDATE)
I X 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^BGP8UTL2(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^BGP8UTL2($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^BGP8UTL2(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^BGP8UTL2(C,T,0) S G="RT"
.I $$ICD^BGP8UTL2(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^BGP8UTL1(P,"BGP RIGHT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL($P(X,U,3),"RT")=""
S X=$$PLTAXND^BGP8DU(P,"BGP RIGHT MASTECTOMY DXS",EDATE) I X S BGPRL(DT,"RT")=""
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP RIGHT MASTECTOMY",EDATE) I X S BGPRL(DT,"RT")=""
S X=$$LASTDX^BGP8UTL1(P,"BGP LEFT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL($P(X,U,3),"LT")=""
S X=$$PLTAXND^BGP8DU(P,"BGP LEFT MASTECTOMY DXS",EDATE) I X S BGPRL(DT,"LT")=""
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP LEFT MASTECTOMY",EDATE) I X S BGPRL(DT,"RT")=""
;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
BGP8D4 ;IHS/CMI/LAB - MEASURE LOGIC 3;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
I16 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPMAM,BGPI8,BGPI81,BGPI8DA,BGPI8DB,BGPI8DC,BGPI8DD,BGPI8DE
+2 SET (BGPD1,BGPD2)=0
+3 SET BGPI8DA=0
SET BGPI8DB=0
SET BGPN1=0
SET BGPN2=0
SET BGPN3=0
SET BGPI8DC=0
SET BGPI8DD=0
SET BGPI8DE=0
+4 SET BGPI8=$$DEN8(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+5 IF BGPACTUP
IF BGPI8
SET BGPI8DA=1
+6 IF BGPACTCL
IF BGPI8
SET BGPI8DB=1
+7 ;NEW DENOM V18 BGPD1,BGPD2
+8 SET X=0
+9 IF BGPSEX="F"
IF BGPAGEB>51
IF BGPAGEB<75
IF '$$MAS(DFN,BGPEDATE)
SET X=1
+10 IF X
IF BGPACTCL
SET BGPD1=1
+11 IF X
IF BGPACTUP
SET BGPD2=1
+12 ;not in any denominator
IF 'BGPD1
IF 'BGPD2
IF 'BGPI8DA
IF 'BGPI8DB
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:"UP",1:"")_$SELECT(BGPI8DB:",AC",1:"")_"|||"_$$DATE^BGP8UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+18 IF BGPRTYPE=1
SET BGPVALUE=$SELECT(BGPI8DA:"UP",1:"")_$SELECT(BGPI8DB:",AC",1:"")_"|||"
IF BGPN3
SET BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+19 IF BGPD2
SET BGPVALUD=""
SET BGPVALUD="UP"_$SELECT(BGPD1:",AC",1:"")_" 52-74|||"
IF BGPN3
SET BGPVALUD=BGPVALUD_$$DATE^BGP8UTL($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<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^BGP8UTL2(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^BGP8UTL1(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^BGP8UTL1(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^BGP8DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP8DU(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^BGP8DU(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^BGP8DU(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^BGP8DU(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^BGP8UTL1(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^BGP8UTL1(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^BGP8UTL1(P,"BGP MASTECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+4 IF $PIECE(BGP(1),U)
QUIT 1
+5 SET BGP(1)=$$LASTDX^BGP8UTL1(P,"BGP MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
+6 IF $PIECE(BGP(1),U,1)
QUIT 1
+7 ;v17 problem list
+8 SET X=$$PLTAXND^BGP8DU(P,"BGP MASTECTOMY DXS",EDATE)
+9 IF X
QUIT 1
+10 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP BILAT MASTECTOMY",EDATE)
+11 IF X
QUIT 1
+12 ;check cpt codes for bilateral
+13 ;loop through all cpt codes up to Edate and if any match quit
+14 SET (X,Y,Z,G)=0
KILL BGPX,BGPRL
+15 SET T=$ORDER(^ATXAX("B","BGP MASTECTOMY CPTS",0))
+16 IF T
SET %=""
Begin DoDot:1
+17 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(%]"")
QUIT
Begin DoDot:2
+18 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+19 IF D=""
QUIT
+20 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+21 IF D=""
QUIT
+22 IF D>EDATE
QUIT
+23 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+24 IF '$$ICD^BGP8UTL2(X,T,1)
QUIT
+25 SET BGPX(D)=""
+26 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
+27 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
+28 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
+29 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
+30 IF %
QUIT
+31 SET M=""
+32 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)=""
+33 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)=""
+34 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)=""
+35 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)=""
+36 IF $ORDER(BGPRL(D,""))=""
SET BGPRL(D,"UNK")=""
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
IF %]""
QUIT 1
+39 ; now check tran codes
+40 IF T
IF $DATA(^AUPNVTC("AC",P))
SET %=""
Begin DoDot:1
+41 SET E=0
FOR
SET E=$ORDER(^AUPNVTC("AC",P,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+42 SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)
IF 'D
QUIT
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+43 IF '$$ICD^BGP8UTL2($PIECE(^AUPNVTC(E,0),U,7),T,1)
QUIT
+44 IF D>EDATE
QUIT
+45 SET BGPX(D)=""
+46 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
+47 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
+48 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
+49 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
+50 IF %
QUIT
+51 SET M=""
+52 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)=""
+53 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)=""
+54 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)=""
+55 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)=""
+56 IF $ORDER(BGPRL(D,""))=""
SET BGPRL(D,"UNK")=""
+57 QUIT
End DoDot:2
+58 QUIT
End DoDot:1
IF %]""
QUIT 1
+59 ;see if 2 on different dates
+60 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+61 ;HAD 2 CPTS ON 2 DIFFERENT DATES
IF C>1
QUIT 1
+62 ;K BGPX
+63 ;ADD IN UNKNOWN PROCEDURES
+64 SET T=$ORDER(^ATXAX("B","BGP UNI MASTECTOMY PROCEDURES",0))
+65 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
+66 SET G=0
IF $$ICD^BGP8UTL2(C,T,0)
SET G=1
+67 IF G=0
QUIT
+68 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+69 IF D>EDATE
QUIT
+70 IF '$DATA(BGPX(D))
SET BGPX(D)=""
+71 IF '$DATA(BGPRL(D))
SET BGPRL(D,"UNK")=""
End DoDot:1
+72 ;see if 2 on different dates
+73 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+74 ;HAD 2 UNKNOWNS
IF C>1
QUIT 1
+75 ;ADD IN ICD10 RIGHT AND LEFT CODES
+76 SET T=$ORDER(^ATXAX("B","BGP UNI RIGHT MASTECTOMY PROCS",0))
+77 SET T1=$ORDER(^ATXAX("B","BGP UNI LEFT MASTECTOMY PROCS",0))
+78 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
+79 SET G=""
+80 IF $$ICD^BGP8UTL2(C,T,0)
SET G="RT"
+81 IF $$ICD^BGP8UTL2(C,T1,0)
SET G="LT"
+82 IF G=""
QUIT
+83 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+84 IF D>EDATE
QUIT
+85 SET BGPRL(D,G)=""
End DoDot:1
+86 ;ADD IN ALL DXS
+87 SET X=$$LASTDX^BGP8UTL1(P,"BGP RIGHT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
IF X
SET BGPRL($PIECE(X,U,3),"RT")=""
+88 SET X=$$PLTAXND^BGP8DU(P,"BGP RIGHT MASTECTOMY DXS",EDATE)
IF X
SET BGPRL(DT,"RT")=""
+89 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP RIGHT MASTECTOMY",EDATE)
IF X
SET BGPRL(DT,"RT")=""
+90 SET X=$$LASTDX^BGP8UTL1(P,"BGP LEFT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
IF X
SET BGPRL($PIECE(X,U,3),"LT")=""
+91 SET X=$$PLTAXND^BGP8DU(P,"BGP LEFT MASTECTOMY DXS",EDATE)
IF X
SET BGPRL(DT,"LT")=""
+92 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP LEFT MASTECTOMY",EDATE)
IF X
SET BGPRL(DT,"RT")=""
+93 ;SEE IF THERE IS A RT AND A LT
+94 SET G=""
SET D=0
SET R=""
SET L=""
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+95 IF $DATA(BGPRL(D,"RT"))
SET R=D
+96 IF $DATA(BGPRL(D,"LT"))
SET L=D
End DoDot:1
+97 IF R
IF L
QUIT 1
+98 ;CHECK UNKNOWNS AND RT / LT
+99 SET X=0
+100 SET D=0
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+101 IF $DATA(BGPRL(D,"UNK"))
IF R
IF R'=D
SET X=1
+102 IF $DATA(BGPRL(D,"UNK"))
IF L
IF L'=D
SET X=1
End DoDot:1
+103 QUIT X
