Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP8PC9

BGP8PC9.m

Go to the documentation of this file. 
  1. BGP8PC9 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018  11:25 AM
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1. BCS ;EP
  1.  S (BGPN1,BGPD1)=0
  1.  S BGPDV=""
  1.  I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q  ;female only
  1.  I BGPAGEE<51 S BGPSTOP=1 Q  ;18 or greater during time period
  1.  I BGPAGEB>73 S BGPSTOP=1 Q  ;74 or less during time period
  1.  ;
  1.  S BGPDV=$$ENC9(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 Q  ;no office visit
  1.  ;
  1.  ;now what about exclusions?
  1.  I $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q  ;no hospice pts
  1.  ;Hysterectomy?
  1.  I $$MAS(DFN,BGPEDATE) S BGPSTOP=1 Q
  1.  ;
  1.  S BGPD1=1
  1.  ;
  1.  S BGPVAL=""
  1.  S X=$$MAM(DFN,$$FMADD^XLFDT(BGPEDATE,-824),BGPEDATE)  ;PAP IN 3 YRS?
  1.  I $E(X)=1 S BGPN1=1,BGPVAL=X
  1.  S BGPVALUE=""
  1.  S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||"  ;hit denominator
  1.  I BGPN1 S BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($P(X,U,2))_" "_$P(X,U,3)
  1.  K V,BGPDV,BGPVAL
  1.  Q
  1. ENC9(P,BDATE,EDATE) ;EP  - have encounter per CMS122v6
  1.  ;HAS one of the following
  1.  ;1.  cpt in BGP IPC OFFICE VISIT CPTS
  1.  ;2.  snomed in PXRM BGP IPC FACE2FACE
  1.  ;3.  CPT in BGP IPC PREVCARE EOV >=18 CPTS
  1.  ;4.  CPT in BGP IPC PREVCARE IOV >=18 CPTS
  1.  ;5.  CPT in BGP IPC HOMEHEALTH VISIT CPTS
  1.  NEW X,Y,Z,G,BGPV,D
  1.  ;Let's check all Visits, looping through once
  1.  S G=""  ;return variable
  1.  ;get all visits in date range in BGPV
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
  1.  ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
  1.  S X=0 F  S X=$O(BGPV(X)) Q:X'=+X!(G)  S V=$P(BGPV(X),U,5)  D
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)  ;no dependent entries
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)  ;deleted
  1.  .S D=$$VD^APCLV(V)
  1.  .S Y=$$FTOF^BGP8PC2(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y Q
  1.  .;is .17 a cpt we want?
  1.  .S Y=$$VALI^XBDIQ1(9000010,V,.17)
  1.  .I Y,$$OFFCPT9(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
  1.  .;now check all V CPTs
  1.  .S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G)  D
  1.  ..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)
  1.  ..I Y,$$OFFCPT9(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
  1.  Q G
  1. OFFCPT9(C) ;EP
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) Q 1
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1) Q 1
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1) Q 1
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1) Q 1
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1) Q 1
  1.  Q ""
  1. LOINC(A,B) ;EP
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  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,I,BGPC,BGPG,S
  1.  K BGP
  1.  ;V POV
  1.  S BGP(1)=$$LASTDX^BGP8UTL1(P,"BGP IPC BILAT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
  1.  I $P(BGP(1),U,1) Q 1
  1.  ;problem list
  1.  S T=$O(^ATXAX("B","BGP IPC BILAT MASTECTOMY DXS",0))
  1.  S (X,Y,I)=0
  1.  F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  D
  1.  .Q:'$D(^AUPNPROB(X,0))
  1.  .I $P(^AUPNPROB(X,0),U,12)="D" Q
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .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
  1.  .I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q  ;entered after report period, skip
  1.  .I $$ICD^BGP8UTL2(Y,T,9) S I=1 Q
  1.  .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1.  .I S=428529004 S I=1 Q
  1.  .Q
  1.  I I Q 1
  1.  ;NOW V POV FOR SNOMED CODE
  1.  ;NOW SNOMED USING ASNC
  1.  S G="",I=""
  1.  S S="" F  S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G)  D
  1.  .S I=0
  1.  .I S=428529004 S I=1 Q
  1.  .Q:'I
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S G=1
  1.  I G Q 1
  1.  ;check cpt codes for 2 unilateral
  1.  ;loop through all cpt codes up to Edate and count them
  1.  S (X,Y,Z,G)=0
  1.  S BGPC=0
  1.  S T=$O(^ATXAX("B","BGP IPC UNILAT MASTECTOMY CPTS",0))
  1.  I T D  I BGPC>1 Q 1
  1.  .S Y=0 F  S Y=$O(^AUPNVCPT("AC",P,Y)) Q:Y'=+Y!(BGPC>1)  D
  1.  ..S D=$P($G(^AUPNVCPT(Y,0)),U,3)
  1.  ..Q:D=""
  1.  ..S D=$P($P($G(^AUPNVSIT(D,0)),U),".") ;date done
  1.  ..Q:D=""
  1.  ..I D>EDATE Q
  1.  ..S X=$P(^AUPNVCPT(Y,0),U)
  1.  ..Q:'$$ICD^BGP8UTL2(X,T,1)
  1.  ..S BGPC=BGPC+1
  1.  .Q
  1.  ;NOW CHECK PROBLEM LIST AND V POV FOR A RIGHT AND AN LEFT
  1.  K BGPRL
  1.  S T=$O(^ATXAX("B","BGP IPC RT MASTECTOMY DXS",0))
  1.  S T1=$O(^ATXAX("B","BGP IPC LT MASTECTOMY DXS",0))
  1.  S (X,Y,I)=0
  1.  F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNPROB(X,0))
  1.  .I $P(^AUPNPROB(X,0),U,12)="D" Q
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .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
  1.  .I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q  ;entered after report period, skip
  1.  .I $$ICD^BGP8UTL2(Y,T,9) S BGPRL("RT")=1 Q
  1.  .I $$ICD^BGP8UTL2(Y,T1,9) S BGPRL("LT")=1 Q
  1.  .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1.  .I S=429242008 S BGPRL("RT")=1 Q
  1.  .I S=429009003 S BGPRL("LT")=1 Q
  1.  .S C=$$VAL^XBDIQ1(9000011,X,.22)
  1.  .Q:C=""
  1.  .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC UNI MAST DX",S)),$$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
  1.  .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC UNI MAST DX",S)),$$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
  1.  .I $$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP IPC UNILAT MASTECTOMY DXS",0)),9),$$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
  1.  .I $$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP IPC UNILAT MASTECTOMY DXS",0)),9),$$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
  1.  .Q
  1.  I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
  1.  ;NOW V POV
  1.  S X=$$LASTDX^BGP8UTL1(P,"BGP IPC RT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL("RT")=1
  1.  S X=$$LASTDX^BGP8UTL1(P,"BGP IPC LT MASTECTOMY DXS",$$DOB^AUPNPAT(P),EDATE) I X S BGPRL("LT")=1
  1.  I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
  1.  S S=429242008
  1.  S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D
  1.  .S Y=9999999-D
  1.  .Q:Y>EDATE
  1.  .S BGPRL("RT")=1
  1.  S S=429009003
  1.  S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D
  1.  .S Y=9999999-D
  1.  .Q:Y>EDATE
  1.  .S BGPRL("LT")=1
  1.  I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
  1.  ;NOW V POV FOR UNILATERAL WITH LATERALITY LEFT OR RIGHT
  1.  S Y="BGPG("
  1.  S X=P_"^ALL DX [BGP IPC UNILAT MASTECTOMY DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  D
  1.  .S C=$$VAL^XBDIQ1(9000010.07,+$P(BGPG(X),U,4),1104)
  1.  .I $$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
  1.  .I $$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
  1.  I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
  1.  ;NOW SNOMED USING ASNC
  1.  S G=0
  1.  S T="PXRM BGP IPC UNI MAST DX"
  1.  S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""  D
  1.  .Q:'$D(^AUPNVPOV("ASNC",P,S))
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S I=0 F  S I=$O(^AUPNVPOV("ASNC",P,S,D,I)) Q:I=""  D
  1.  ...S C=$$VAL^XBDIQ1(9000010.07,I,1104)
  1.  ...Q:C=""
  1.  ...I $$UP^XLFSTR(C)["LEFT" S BGPRL("LT")=1 Q
  1.  ...I $$UP^XLFSTR(C)["RIGHT" S BGPRL("RT")=1 Q
  1.  I $D(BGPRL("RT")),$D(BGPRL("LT")) Q 1
  1.  Q ""
  1. MAM(P,BDATE,EDATE) ;
  1.  NEW BGPLMAM,X,Y,V,G
  1.  S BGPLMAM=""
  1.  S (X,Y,V)=0,G="" F  S X=$O(^AUPNVRAD("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVRAD(X,0))
  1.  .S V=$P(^AUPNVRAD(X,0),U,3)
  1.  .Q:V=""
  1.  .S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:V>EDATE
  1.  .Q:V<BDATE
  1.  .S Y=$P(^AUPNVRAD(X,0),U),Y=$P($G(^RAMIS(71,Y,0)),U,9)
  1.  .I Y,$$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP IPC MAMMOGRAM CPTS",0)),1) D  Q
  1.  ..S Y=$P($$CPT^ICPTCOD(Y),U,2)
  1.  ..I $P(BGPLMAM,U,2)<V S BGPLMAM="1^"_V_U_"RAD "_Y Q
  1.  .S Z="" F  S Z=$O(^AUPNVRAD(X,27,"B",Z)) Q:Z=""  D
  1.  ..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
  1.  .Q
  1.  S T=$O(^ATXAX("B","BGP IPC MAMMOGRAM CPTS",0))
  1.  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)
  1.  .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
  1.  Q BGPLMAM