BGP8PC9 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
BCS ;EP
S (BGPN1,BGPD1)=0
S BGPDV=""
I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q ;female only
I BGPAGEE<51 S BGPSTOP=1 Q ;18 or greater during time period
I BGPAGEB>73 S BGPSTOP=1 Q ;74 or less during time period
;
S BGPDV=$$ENC9(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 Q ;no office visit
;
;now what about exclusions?
I $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;no hospice pts
;Hysterectomy?
I $$MAS(DFN,BGPEDATE) S BGPSTOP=1 Q
;
S BGPD1=1
;
S BGPVAL=""
S X=$$MAM(DFN,$$FMADD^XLFDT(BGPEDATE,-824),BGPEDATE) ;PAP IN 3 YRS?
I $E(X)=1 S BGPN1=1,BGPVAL=X
S BGPVALUE=""
S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||" ;hit denominator
I BGPN1 S BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($P(X,U,2))_" "_$P(X,U,3)
K V,BGPDV,BGPVAL
Q
ENC9(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
;HAS one of the following
;1. cpt in BGP IPC OFFICE VISIT CPTS
;2. snomed in PXRM BGP IPC FACE2FACE
;3. CPT in BGP IPC PREVCARE EOV >=18 CPTS
;4. CPT in BGP IPC PREVCARE IOV >=18 CPTS
;5. CPT in BGP IPC HOMEHEALTH VISIT CPTS
NEW X,Y,Z,G,BGPV,D
;Let's check all Visits, looping through once
S G="" ;return variable
;get all visits in date range in BGPV
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
S X=0 F S X=$O(BGPV(X)) Q:X'=+X!(G) S V=$P(BGPV(X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9) ;no dependent entries
.Q:$P(^AUPNVSIT(V,0),U,11) ;deleted
.S D=$$VD^APCLV(V)
.S Y=$$FTOF^BGP8PC2(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y Q
.;is .17 a cpt we want?
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$OFFCPT9(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
.;now check all V CPTs
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G) D
..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)
..I Y,$$OFFCPT9(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
Q G
OFFCPT9(C) ;EP
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1) Q 1
Q ""
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
MAS(P,EDATE) ;EP mastectomy before end of time frame
NEW BGP,X,Y,Z,G,T,%,D,M,BGPX,E,BGPRL,T1,I,BGPC,BGPG,S
K BGP
;V POV
S BGP(1)=$$LASTDX^BGP8UTL1(P,"BGP IPC BILAT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
I $P(BGP(1),U,1) Q 1
;problem list
S T=$O(^ATXAX("B","BGP IPC BILAT MASTECTOMY DXS",0))
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.I $P(^AUPNPROB(X,0),U,12)="D" Q
.S Y=$P(^AUPNPROB(X,0),U)
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.I $$ICD^BGP8UTL2(Y,T,9) S I=1 Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S=428529004 S I=1 Q
.Q
I I Q 1
;NOW V POV FOR SNOMED CODE
;NOW SNOMED USING ASNC
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I S=428529004 S I=1 Q
.Q:'I
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
I G Q 1
;check cpt codes for 2 unilateral
;loop through all cpt codes up to Edate and count them
S (X,Y,Z,G)=0
S BGPC=0
S T=$O(^ATXAX("B","BGP IPC UNILAT MASTECTOMY CPTS",0))
I T D I BGPC>1 Q 1
.S Y=0 F S Y=$O(^AUPNVCPT("AC",P,Y)) Q:Y'=+Y!(BGPC>1) 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 BGPC=BGPC+1
.Q
;NOW CHECK PROBLEM LIST AND V POV FOR A RIGHT AND AN LEFT
K BGPRL
S T=$O(^ATXAX("B","BGP IPC RT MASTECTOMY DXS",0))
S T1=$O(^ATXAX("B","BGP IPC LT MASTECTOMY DXS",0))
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNPROB(X,0))
.I $P(^AUPNPROB(X,0),U,12)="D" Q
.S Y=$P(^AUPNPROB(X,0),U)
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.I $$ICD^BGP8UTL2(Y,T,9) S BGPRL("RT")=1 Q
.I $$ICD^BGP8UTL2(Y,T1,9) S BGPRL("LT")=1 Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S=429242008 S BGPRL("RT")=1 Q
.I S=429009003 S BGPRL("LT")=1 Q
.S C=$$VAL^XBDIQ1(9000011,X,.22)
.Q:C=""
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC UNI MAST DX",S)),$$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC UNI MAST DX",S)),$$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
.I $$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP IPC UNILAT MASTECTOMY DXS",0)),9),$$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
.I $$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP IPC UNILAT MASTECTOMY DXS",0)),9),$$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
.Q
I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
;NOW V POV
S X=$$LASTDX^BGP8UTL1(P,"BGP IPC RT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL("RT")=1
S X=$$LASTDX^BGP8UTL1(P,"BGP IPC LT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL("LT")=1
I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
S S=429242008
S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
.S Y=9999999-D
.Q:Y>EDATE
.S BGPRL("RT")=1
S S=429009003
S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
.S Y=9999999-D
.Q:Y>EDATE
.S BGPRL("LT")=1
I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
;NOW V POV FOR UNILATERAL WITH LATERALITY LEFT OR RIGHT
S Y="BGPG("
S X=P_"^ALL DX [BGP IPC UNILAT MASTECTOMY DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X D
.S C=$$VAL^XBDIQ1(9000010.07,+$P(BGPG(X),U,4),1104)
.I $$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
.I $$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
;NOW SNOMED USING ASNC
S G=0
S T="PXRM BGP IPC UNI MAST DX"
S S=0 F S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S="" D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D="" D
..S Y=9999999-D
..Q:Y>EDATE
..S I=0 F S I=$O(^AUPNVPOV("ASNC",P,S,D,I)) Q:I="" D
...S C=$$VAL^XBDIQ1(9000010.07,I,1104)
...Q:C=""
...I $$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
...I $$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
Q ""
MAM(P,BDATE,EDATE) ;
NEW BGPLMAM,X,Y,V,G
S BGPLMAM=""
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)
.I Y,$$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP IPC MAMMOGRAM CPTS",0)),1) D Q
..S Y=$P($$CPT^ICPTCOD(Y),U,2)
..I $P(BGPLMAM,U,2)<V S BGPLMAM="1^"_V_U_"RAD "_Y Q
.S Z="" F S Z=$O(^AUPNVRAD(X,27,"B",Z)) Q:Z="" D
..I $D(^ATXAX($O(^ATXAX("B","BGP IPC MAMMOGRAM LOINC CODES",0)),21,"B",Z)) I $P(BGPLMAM,U,2)<V S BGPLMAM="1^"_V_U_"RAD "_Y Q
.Q
S T=$O(^ATXAX("B","BGP IPC MAMMOGRAM CPTS",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,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
Q BGPLMAM
BGP8PC9 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
BCS ;EP
+1 SET (BGPN1,BGPD1)=0
+2 SET BGPDV=""
+3 ;female only
IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET BGPSTOP=1
QUIT
+4 ;18 or greater during time period
IF BGPAGEE<51
SET BGPSTOP=1
QUIT
+5 ;74 or less during time period
IF BGPAGEB>73
SET BGPSTOP=1
QUIT
+6 ;
+7 ;no office visit
SET BGPDV=$$ENC9(DFN,BGPBDATE,BGPEDATE)
IF BGPDV=""
SET BGPSTOP=1
QUIT
+8 ;
+9 ;now what about exclusions?
+10 ;no hospice pts
IF $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+11 ;Hysterectomy?
+12 IF $$MAS(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+13 ;
+14 SET BGPD1=1
+15 ;
+16 SET BGPVAL=""
+17 ;PAP IN 3 YRS?
SET X=$$MAM(DFN,$$FMADD^XLFDT(BGPEDATE,-824),BGPEDATE)
+18 IF $EXTRACT(X)=1
SET BGPN1=1
SET BGPVAL=X
+19 SET BGPVALUE=""
+20 ;hit denominator
SET BGPVALUE="ENC "_$PIECE(BGPDV,U,2)_"|||"
+21 IF BGPN1
SET BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+22 KILL V,BGPDV,BGPVAL
+23 QUIT
ENC9(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
+1 ;HAS one of the following
+2 ;1. cpt in BGP IPC OFFICE VISIT CPTS
+3 ;2. snomed in PXRM BGP IPC FACE2FACE
+4 ;3. CPT in BGP IPC PREVCARE EOV >=18 CPTS
+5 ;4. CPT in BGP IPC PREVCARE IOV >=18 CPTS
+6 ;5. CPT in BGP IPC HOMEHEALTH VISIT CPTS
+7 NEW X,Y,Z,G,BGPV,D
+8 ;Let's check all Visits, looping through once
+9 ;return variable
SET G=""
+10 ;get all visits in date range in BGPV
+11 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+12 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
+13 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+14 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+15 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+16 SET D=$$VD^APCLV(V)
+17 SET Y=$$FTOF^BGP8PC2(V)
IF Y]""
SET G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y
QUIT
+18 ;is .17 a cpt we want?
+19 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+20 IF Y
IF $$OFFCPT9(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
+21 ;now check all V CPTs
+22 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+23 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+24 IF Y
IF $$OFFCPT9(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
End DoDot:2
End DoDot:1
+25 QUIT G
OFFCPT9(C) ;EP
+1 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)
QUIT 1
+2 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1)
QUIT 1
+3 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1)
QUIT 1
+4 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1)
QUIT 1
+5 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1)
QUIT 1
+6 QUIT ""
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
MAS(P,EDATE) ;EP mastectomy before end of time frame
+1 NEW BGP,X,Y,Z,G,T,%,D,M,BGPX,E,BGPRL,T1,I,BGPC,BGPG,S
+2 KILL BGP
+3 ;V POV
+4 SET BGP(1)=$$LASTDX^BGP8UTL1(P,"BGP IPC BILAT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
+5 IF $PIECE(BGP(1),U,1)
QUIT 1
+6 ;problem list
+7 SET T=$ORDER(^ATXAX("B","BGP IPC BILAT MASTECTOMY DXS",0))
+8 SET (X,Y,I)=0
+9 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNPROB(X,0))
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+12 SET Y=$PIECE(^AUPNPROB(X,0),U)
+13 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+14 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+15 IF $$ICD^BGP8UTL2(Y,T,9)
SET I=1
QUIT
+16 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+17 IF S=428529004
SET I=1
QUIT
+18 QUIT
End DoDot:1
+19 IF I
QUIT 1
+20 ;NOW V POV FOR SNOMED CODE
+21 ;NOW SNOMED USING ASNC
+22 SET G=""
SET I=""
+23 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+24 SET I=0
+25 IF S=428529004
SET I=1
QUIT
+26 IF 'I
QUIT
+27 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+28 SET Y=9999999-D
+29 IF Y>EDATE
QUIT
+30 SET G=1
End DoDot:2
End DoDot:1
+31 IF G
QUIT 1
+32 ;check cpt codes for 2 unilateral
+33 ;loop through all cpt codes up to Edate and count them
+34 SET (X,Y,Z,G)=0
+35 SET BGPC=0
+36 SET T=$ORDER(^ATXAX("B","BGP IPC UNILAT MASTECTOMY CPTS",0))
+37 IF T
Begin DoDot:1
+38 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(BGPC>1)
QUIT
Begin DoDot:2
+39 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+40 IF D=""
QUIT
+41 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+42 IF D=""
QUIT
+43 IF D>EDATE
QUIT
+44 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+45 IF '$$ICD^BGP8UTL2(X,T,1)
QUIT
+46 SET BGPC=BGPC+1
End DoDot:2
+47 QUIT
End DoDot:1
IF BGPC>1
QUIT 1
+48 ;NOW CHECK PROBLEM LIST AND V POV FOR A RIGHT AND AN LEFT
+49 KILL BGPRL
+50 SET T=$ORDER(^ATXAX("B","BGP IPC RT MASTECTOMY DXS",0))
+51 SET T1=$ORDER(^ATXAX("B","BGP IPC LT MASTECTOMY DXS",0))
+52 SET (X,Y,I)=0
+53 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+54 IF '$DATA(^AUPNPROB(X,0))
QUIT
+55 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+56 SET Y=$PIECE(^AUPNPROB(X,0),U)
+57 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+58 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+59 IF $$ICD^BGP8UTL2(Y,T,9)
SET BGPRL("RT")=1
QUIT
+60 IF $$ICD^BGP8UTL2(Y,T1,9)
SET BGPRL("LT")=1
QUIT
+61 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+62 IF S=429242008
SET BGPRL("RT")=1
QUIT
+63 IF S=429009003
SET BGPRL("LT")=1
QUIT
+64 SET C=$$VAL^XBDIQ1(9000011,X,.22)
+65 IF C=""
QUIT
+66 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC UNI MAST DX",S))
IF $$UP^XLFSTR(C)["LEFT"
SET BGPRL("LT")=1
QUIT
+67 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC UNI MAST DX",S))
IF $$UP^XLFSTR(C)["RIGHT"
SET BGPRL("RT")=1
QUIT
+68 IF $$ICD^BGP8UTL2(Y,$ORDER(^ATXAX("B","BGP IPC UNILAT MASTECTOMY DXS",0)),9)
IF $$UP^XLFSTR(C)["LEFT"
SET BGPRL("LT")=1
QUIT
+69 IF $$ICD^BGP8UTL2(Y,$ORDER(^ATXAX("B","BGP IPC UNILAT MASTECTOMY DXS",0)),9)
IF $$UP^XLFSTR(C)["RIGHT"
SET BGPRL("RT")=1
QUIT
+70 QUIT
End DoDot:1
+71 IF $DATA(BGPRL("RT"))
IF $DATA(BGPRL("LT"))
QUIT 1
+72 ;NOW V POV
+73 SET X=$$LASTDX^BGP8UTL1(P,"BGP IPC RT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
IF X
SET BGPRL("RT")=1
+74 SET X=$$LASTDX^BGP8UTL1(P,"BGP IPC LT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
IF X
SET BGPRL("LT")=1
+75 IF $DATA(BGPRL("RT"))
IF $DATA(BGPRL("LT"))
QUIT 1
+76 SET S=429242008
+77 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:1
+78 SET Y=9999999-D
+79 IF Y>EDATE
QUIT
+80 SET BGPRL("RT")=1
End DoDot:1
+81 SET S=429009003
+82 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:1
+83 SET Y=9999999-D
+84 IF Y>EDATE
QUIT
+85 SET BGPRL("LT")=1
End DoDot:1
+86 IF $DATA(BGPRL("RT"))
IF $DATA(BGPRL("LT"))
QUIT 1
+87 ;NOW V POV FOR UNILATERAL WITH LATERALITY LEFT OR RIGHT
+88 SET Y="BGPG("
+89 SET X=P_"^ALL DX [BGP IPC UNILAT MASTECTOMY DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+90 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+91 SET C=$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(X),U,4),1104)
+92 IF $$UP^XLFSTR(C)["LEFT"
SET BGPRL("LT")=1
QUIT
+93 IF $$UP^XLFSTR(C)["RIGHT"
SET BGPRL("RT")=1
QUIT
End DoDot:1
+94 IF $DATA(BGPRL("RT"))
IF $DATA(BGPRL("LT"))
QUIT 1
+95 ;NOW SNOMED USING ASNC
+96 SET G=0
+97 SET T="PXRM BGP IPC UNI MAST DX"
+98 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""
QUIT
Begin DoDot:1
+99 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+100 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""
QUIT
Begin DoDot:2
+101 SET Y=9999999-D
+102 IF Y>EDATE
QUIT
+103 SET I=0
FOR
SET I=$ORDER(^AUPNVPOV("ASNC",P,S,D,I))
IF I=""
QUIT
Begin DoDot:3
+104 SET C=$$VAL^XBDIQ1(9000010.07,I,1104)
+105 IF C=""
QUIT
+106 IF $$UP^XLFSTR(C)["LEFT"
SET BGPRL("LT")=1
QUIT
+107 IF $$UP^XLFSTR(C)["RIGHT"
SET BGPRL("RT")=1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+108 IF $DATA(BGPRL("RT"))
IF $DATA(BGPRL("LT"))
QUIT 1
+109 QUIT ""
MAM(P,BDATE,EDATE) ;
+1 NEW BGPLMAM,X,Y,V,G
+2 SET BGPLMAM=""
+3 SET (X,Y,V)=0
SET G=""
FOR
SET X=$ORDER(^AUPNVRAD("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNVRAD(X,0))
QUIT
+5 SET V=$PIECE(^AUPNVRAD(X,0),U,3)
+6 IF V=""
QUIT
+7 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+8 IF V>EDATE
QUIT
+9 IF V<BDATE
QUIT
+10 SET Y=$PIECE(^AUPNVRAD(X,0),U)
SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
+11 IF Y
IF $$ICD^BGP8UTL2(Y,$ORDER(^ATXAX("B","BGP IPC MAMMOGRAM CPTS",0)),1)
Begin DoDot:2
+12 SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
+13 IF $PIECE(BGPLMAM,U,2)<V
SET BGPLMAM="1^"_V_U_"RAD "_Y
QUIT
End DoDot:2
QUIT
+14 SET Z=""
FOR
SET Z=$ORDER(^AUPNVRAD(X,27,"B",Z))
IF Z=""
QUIT
Begin DoDot:2
+15 IF $DATA(^ATXAX($ORDER(^ATXAX("B","BGP IPC MAMMOGRAM LOINC CODES",0)),21,"B",Z))
IF $PIECE(BGPLMAM,U,2)<V
SET BGPLMAM="1^"_V_U_"RAD "_Y
QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 SET T=$ORDER(^ATXAX("B","BGP IPC MAMMOGRAM CPTS",0))
+18 IF T
Begin DoDot:1
+19 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+20 SET X=$$TRAN^BGP8DU(P,BDATE,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)
+21 QUIT BGPLMAM
