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

BGP1D26.m

Go to the documentation of this file. 
  1. BGP1D26 ; IHS/CMI/LAB - measure 6 03 Jun 2011 3:16 PM ;
  1.  ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
  1.  ;
  1.  S DFN=10000,BGPBDATE=2990101,BGPEDATE=3031231,BGPACTCL=1
  1.  F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D
  1.  .;W DFN,"."
  1.  .S BGPVALUE=""
  1.  .S BGPAGEB=$$AGE^AUPNPAT(DFN,2990101)
  1.  .S BGPAGEE=$$AGE^AUPNPAT(DFN,3031231)
  1.  .S BGPSEX=$P(^DPT(DFN,0),U,2)
  1.  .D COMPHS
  1.  .I BGPVALUE]"" W !,BGPVALUE
  1.  .Q
  1.  Q
  1. COMPHS ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;not active clinical
  1.  S BGPVALUE=""
  1.  I BGPAGEB<2 S BGPSTOP=1 Q  ;needs to be at least 2
  1.  I BGPAGEB>11,BGPAGEB<76 S BGPD3=1  ;alcohol screening
  1.  I BGPAGEB>17 S BGPD4=1  ;depression screening
  1.  I BGPAGEB>14,BGPAGEB<41,BGPSEX="F" S BGPD5=1  ;ipv/dv screening
  1.  I BGPAGEB>4 S BGPD6=1  ;tobacco screening
  1.  I BGPAGEB>1,BGPAGEB<75 S BGPD7=1  ;BMI
  1.  I BGPAGEB>19 S BGPD8=1  ;BP Assessed
  1.  I BGPAGEB>4 S BGPD9=1  ;PA Assessed
  1.  I '(BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9) W BGPBOMB
  1.  S BGPD1=1
  1.  S BGPD2=1
  1.  ;now set up numerators
  1.  S BGPVAL=""
  1.  I BGPD3 D  I BGPVAL S BGPN3=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"ALC: "_$P(BGPVAL,U,3)_" "_$P(BGPVAL,U,2)
  1.  .S BGPVAL=$$ALSCRN(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
  1.  .S BGPVAL=$$ALDX^BGP1D55(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
  1.  .S BGPVAL=$$ALPRC^BGP1D5(DFN,BGPBDATE,BGPEDATE)
  1.  S BGPVAL=""
  1.  I BGPD4 D  I BGPVAL S BGPN4=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"DEPR: "_$P(BGPVAL,U,3)_" "_$S($P(BGPVAL,U,5)]"":$P(BGPVAL,U,5),1:$P(BGPVAL,U,2))
  1.  .S BGPVAL=$$DEPSCR^BGP1D25(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
  1.  .S BGPVAL=$$DEP^BGP1D25(DFN,BGPBDATE,BGPEDATE) Q
  1.  S BGPVAL=""
  1.  I BGPD5 D  I BGPVAL S BGPN5=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"IPV: "_$P(BGPVAL,U,5)_" "_$P(BGPVAL,U,4)
  1.  .S BGPVAL=$$DVEX^BGP1D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
  1.  .S BGPVAL=$$DVDX^BGP1D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q  ;DX ONLY
  1.  .S BGPVAL=$$DVPED^BGP1D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q  ;W/O V61.11
  1.  .S BGPVAL=$$DV61^BGP1D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q  ;include in education for gpra
  1.  I BGPD6 D
  1.  .S BGPVAL=$$TOBACCO^BGP1D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$P(BGPVAL,U,2)_" "_$P(BGPVAL,U,1) Q
  1.  .S BGPVAL=$$DX^BGP1D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP1UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
  1.  .S BGPVAL=$$PED^BGP1D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP1UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
  1.  .S BGPVAL=$$DENT^BGP1D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP1UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
  1.  .S BGPVAL=$$CPTSM^BGP1D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP1UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
  1.  I BGPD7 D  I $P(BGPVAL,U,1)]"" S BGPN7=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"BMI: "_$$SB^BGP1PDL1($J($P(BGPVAL,U),6,2))
  1.  .S BGPVAL=$$BMI^BGP1D6(DFN,BGPEDATE,BGPAGEE)
  1.  I BGPD8 D  I BGPVAL]"" S BGPN8=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"BP: "_$P($P(BGPVAL,U,1)," ")
  1.  .S BGPVAL=$$MEANBP^BGP1D41(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE) I BGPVAL]"",BGPVAL'["unknown" Q
  1.  .I BGPVAL["unknown" S BGPVAL=$P($$BPCPT^BGP1D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE),U,2)
  1.  I BGPD9 D
  1.  .S BGPVAL=$$FIRSTHF^BGP1D8(DFN,BGPBDATE,BGPEDATE,"ACTIVITY LEVEL")  ;get the first health factor in this category recorded in this time period
  1.  .I BGPVAL S BGPN9=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"PHYS ACT: "_$P(BGPVAL,U,3)_" "_$P(BGPVAL,U,4)
  1.  S G=1
  1.  I BGPD1 D
  1.  .I BGPD3 I 'BGPN3 S G=0
  1.  .I BGPD4 I 'BGPN4 S G=0
  1.  .I BGPD5 I 'BGPN5 S G=0
  1.  .I BGPD6 I 'BGPN6 S G=0
  1.  .I BGPD7 I 'BGPN7 S G=0
  1.  .I BGPD8 I 'BGPN8 S G=0
  1.  .I BGPD9 I 'BGPN9 S G=0
  1.  .I G S BGPN1=1,BGPVALUE="ALL COMP HEALTH: "_BGPVALUE
  1.  S H=1
  1.  I BGPD1 D
  1.  .I BGPD3 I 'BGPN3 S H=0
  1.  .I BGPD4 I 'BGPN4 S H=0
  1.  .I BGPD5 I 'BGPN5 S H=0
  1.  .I BGPD6 I 'BGPN6 S H=0
  1.  .I BGPD7 I 'BGPN7 S H=0
  1.  .I BGPD8 I 'BGPN8 S H=0
  1.  .I H S BGPN2=1 I 'G S BGPVALUE="COMP HEALTH: "_BGPVALUE
  1.  S BGPVALUE="AC|||"_BGPVALUE
  1.  Q
  1. ALSCRN(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
  1.  NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD,BGPVALF
  1.  S BGPVALF=""
  1. PCC ;check PCC first
  1.  S BGPCT=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
  1.  K BGPG
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
  1.  S BGPX=0 F  S BGPX=$O(BGPG(BGPX)) Q:BGPX'=+BGPX!(BGPVALF)  S BGPV=$P(BGPG(BGPX),U,5) D
  1.  .S BGPVD=$$VD^APCLV(BGPV)
  1. PCCEX .;
  1.  .S E=0 F  S E=$O(^AUPNVXAM("AD",BGPV,E)) Q:E'=+E!(BGPVALF)  D
  1.  ..S I=$P($G(^AUPNVXAM(E,0)),U,1)
  1.  ..Q:'I
  1.  ..Q:$P($G(^AUTTEXAM(I,0)),U,2)'=35
  1.  ..S BGPVALF=1_"^Ex 35^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  .Q:BGPVALF
  1. PCCHF .;
  1.  .S E=0 F  S E=$O(^AUPNVHF("AD",BGPV,E)) Q:E'=+E!(BGPVALF)  D
  1.  ..S I=$P($G(^AUPNVHF(E,0)),U,1)
  1.  ..S I=$P($G(^AUTTHF(I,0)),U,1)
  1.  ..I I'="CAGE 0/4",I'="CAGE 1/4",I'="CAGE 2/4",I'="CAGE 3/4",I'="CAGE 4/4" Q  ;cage only
  1.  ..S BGPVALF=1_"^HF "_I_"^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  .Q:BGPVALF
  1. PCCDX .;
  1.  .S E=0 F  S E=$O(^AUPNVPOV("AD",BGPV,E)) Q:E'=+E!(BGPVALF)  D
  1.  ..S I=$$VAL^XBDIQ1(9000010.07,E,.01)
  1.  ..I I'="V79.1",I'="V11.3" Q
  1.  ..S BGPVALF=1_U_"POV "_I_U_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  .Q:BGPVALF
  1. PCCCPT .;
  1.  .S E=0 F  S E=$O(^AUPNVCPT("AD",BGPV,E)) Q:E'=+E!(BGPVALF)  D
  1.  ..S I=$P($G(^AUPNVCPT(E,0)),U,1)
  1.  ..Q:'I
  1.  ..S J=$P(^ICPT(I,0),U)
  1.  ..Q:'$$ICD^ATXCHK(I,BGPCT,1)
  1.  ..S BGPVALF=1_"^CPT "_J_"^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  .Q:BGPVALF
  1. PCCMEAS .;now add in v measurements
  1.  .S E=0 F  S E=$O(^AUPNVMSR("AD",BGPV,E)) Q:E'=+E!(BGPVALF)  D
  1.  ..S I=$$VAL^XBDIQ1(9000010.01,E,.01)
  1.  ..I I'="AUDT",I'="AUDC",I'="CRFT" Q
  1.  ..S BGPVALF=1_"^MEAS "_I_"^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  I BGPVALF Q BGPVALF
  1. BH ;CHECK BH VISITS
  1.  S BGPC="",T="",F=""
  1.  S E=9999999-BDATE,D=9999999-EDATE-1_".99"
  1.  F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPVALF)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V  D
  1. BHEX .;
  1.  .S BGPVD=9999999-$P(D,"."),BGPIVD=$P(D,".")
  1.  .S X=$P($G(^AMHREC(V,14)),U,3)
  1.  .I X="P"!(X="N") D
  1.  ..S BGPVALF=1_"^BH Ex 35^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  .Q:BGPVALF
  1. BHHF .;
  1.  .S X=0 F  S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X!(BGPVALF)  D
  1.  ..S I=$P($G(^AMHRHF(X,0)),U,1)
  1.  ..Q:'I
  1.  ..S I=$P($G(^AUTTHF(I,0)),U,1)
  1.  ..I I'="CAGE 0/4",I'="CAGE 1/4",I'="CAGE 2/4",I'="CAGE 3/4",I'="CAGE 4/4" Q  ;cage only
  1.  ..S BGPVALF=1_"^BH HF: "_I_"^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  ..Q
  1.  .Q:BGPVALF
  1. BHDX .;
  1.  .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPVALF)  D
  1.  ..S I=$$VAL^XBDIQ1(9002011.01,X,.01)
  1.  ..I I'="V79.1",I'="V11.3",I'="29.1" Q
  1.  ..S BGPVALF=1_U_"BH DX "_I_U_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  ..Q
  1.  .Q:BGPVALF
  1. BHMEAS .;
  1.  .S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPVALF)  D
  1.  ..S I=$$VAL^XBDIQ1(9002011.12,X,.01)
  1.  ..I I'="AUDT",I'="AUDC",I'="CRFT" Q
  1.  ..S BGPVALF=1_"^BH Meas "_I_"^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  .Q:BGPVALF
  1. BHCPT .;now add in CPT codes
  1.  .S X=0 F  S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPVALF)  D
  1.  ..S I=$P($G(^AMHRPROC(X,0)),U,1)
  1.  ..Q:'I
  1.  ..Q:'$$ICD^ATXCHK(I,BGPCT,1)
  1.  ..S BGPVALF=1_"^BH CPT: "_J_"^"_$$DATE^BGP1UTL(BGPVD)_U_BGPVD
  1.  ..Q
  1.  .Q:BGPVALF
  1.  Q BGPVALF