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

BGP8PC10.m

Go to the documentation of this file. 
  1. BGP8PC10 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018  11:25 AM
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1. CRC ;EP
  1.  I BGPAGEE<50 S BGPSTOP=1 Q  ;18 or greater during time period
  1.  I BGPAGEB>74 S BGPSTOP=1 Q  ;LESS THAN 75 during time period
  1.  ;
  1.  S BGPDV=$$ENC10(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 $$CRCCOLE(DFN,BGPEDATE) S BGPSTOP=1 Q
  1.  ;
  1.  S (BGPN1,BGPD1)=0
  1.  ;
  1.  S BGPD1=1
  1.  ;
  1.  S BGPVAL=""
  1.  S X=$$SCREEN(DFN,BGPBDATE,BGPEDATE)
  1.  I X S BGPN1=1,BGPVAL=$P(X,U,2)_" "_$P(X,U,3)
  1. SV ;
  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. ENC10(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,$$OFFCPT10(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,$$OFFCPT10(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
  1.  Q G
  1. OFFCPT10(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. CRCCOLE(P,EDATE) ;EP
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^LAST DX [BGP IPC COLON CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPG(1)) Q 1  ;has a dx
  1.  S X=$$PLTAXND^BGP8DU(P,"BGP IPC COLON CANCER DXS",EDATE)
  1.  I X Q 1
  1.  S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP IPC COLON CANCER",EDATE)
  1.  I X Q 1
  1.  S T=$O(^ATXAX("B","BGP IPC TOTAL COLECTOMY CPTS",0))
  1.  I T D  I X]"" Q 1
  1.  .S X=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1.  Q 0
  1. SCREEN(P,BDATE,EDATE) ;
  1.  NEW X,Y,Z,BGPC,G,V,D
  1.  S G=$$COLO(P,($E(EDATE,1,3)-9)_$E(EDATE,4,7),EDATE)
  1.  I G Q G
  1.  S G=$$FOBT(P,BDATE,EDATE)
  1.  I G Q G
  1.  S G=$$SIG(P,($E(EDATE,1,3)-4)_$E(EDATE,4,7),EDATE)
  1.  I G Q G
  1.  S G=$$FIT(P,($E(EDATE,1,3)-2)_$E(EDATE,4,7),EDATE)
  1.  I G Q G
  1.  S G=$$CT(P,($E(EDATE,1,3)-4)_$E(EDATE,4,7),EDATE)
  1.  I G Q G
  1.  Q ""
  1. COLO(P,BDATE,EDATE) ;
  1.  NEW BGPG,BGPLCOLO,T,X
  1.  K BGPG
  1.  S BGPLCOLO=""
  1.  S T=$O(^ATXAX("B","BGP IPC COLONOSCOPY CPTS",0))
  1.  I T D  I X]"",$P(BGPLCOLO,U,3)<$P(X,U,1) S BGPLCOLO=1_U_$P(X,U,1)_U_"COLO 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 BGPLCOLO
  1. SIG(P,BDATE,EDATE) ;
  1.  NEW BGPG,BGPLCOLO,T,X
  1.  K BGPG
  1.  S BGPLCOLO=""
  1.  S T=$O(^ATXAX("B","BGP IPC SIG CPT CODES",0))
  1.  I T D  I X]"",$P(BGPLCOLO,U,3)<$P(X,U,1) S BGPLCOLO=1_U_$P(X,U,1)_U_"SIG 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 BGPLCOLO
  1. FOBT(P,BDATE,EDATE) ;EP
  1.  NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
  1.  S BGPC="",BGPLFOB=""
  1.  S T=$O(^ATXAX("B","BGP IPC FOBT LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP GPRA FOB TESTS",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"")  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"")  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...Q:$P(^AUPNVLAB(X,0),U,4)=""  ;must have a result
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="Lab"_U_(9999999-D) Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BGPC="LOINC"_U_(9999999-D) Q
  1.  ...Q
  1.  I BGPC]"" Q 1_U_$P(BGPC,U,2)_U_"FOBT "_$P(BGPC,U,1)
  1.  Q ""
  1.  ;
  1. CT(P,BDATE,EDATE) ;EP - CT COLONOGRAPHY
  1.  NEW BGPLCT,T,X,BGPG
  1.  S BGPLCT=""
  1.  ;
  1.  S T=$O(^ATXAX("B","BGP IPC CT COLONOGRAPHY CPTS",0))
  1.  I T D  I X]"" S BGPLCT=1_U_$P(X,U,1)_U_"CT 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 BGPLCT
  1.  ;
  1. FIT(P,BDATE,EDATE) ;EP
  1.  NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
  1.  S BGPC="",BGPLFOB=""
  1.  S T=$O(^ATXAX("B","BGP IPC FIT-DNA LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP FIT-DNA TESTS",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"")  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"")  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I $P(^AUPNVLAB(X,0),U,4)="" Q
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="FIT-DNA Lab"_U_(9999999-D) Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BGPC="LOINC"_U_(9999999-D) Q
  1.  ...Q
  1.  I BGPC]"" Q 1_U_$P(BGPC,U,2)_U_"FIT-DNA "_$P(BGPC,U,1)
  1.  Q ""
  1.  ;