BGP7D26 ; IHS/CMI/LAB - measure 6 03 Jun 2017 3:16 PM 12 Jul 2017 9:31 AM ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
COMPHS ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical
S BGPVALUE=""
I BGPAGEB<2 S BGPSTOP=1 Q ;needs to be at least 2
I BGPAGEB>11,BGPAGEB<76 S BGPD3=1 ;alcohol screening
I BGPAGEB>17 S BGPD4=1 ;depression screening
I BGPAGEB>13,BGPAGEB<47,BGPSEX="F" S BGPD5=1 ;ipv/dv screening
I BGPAGEB>4 S BGPD6=1 ;tobacco screening
I BGPAGEB>1,BGPAGEB<75 S BGPD7=1 ;BMI
I BGPAGEB>19 S BGPD8=1 ;BP Assessed
I BGPAGEB>4 S BGPD9=1 ;PA Assessed
I '(BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9) W BGPBOMB
S BGPD1=1
S BGPD2=1
;now set up numerators
S BGPVAL=""
I BGPD3 D I BGPVAL S BGPN3=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"ALC: "_$P(BGPVAL,U,3)_" "_$P(BGPVAL,U,2)
.S BGPVAL=$$ALSCRNRP(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$ALDX^BGP7D55(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$ALPRC^BGP7D5(DFN,BGPBDATE,BGPEDATE)
S BGPVAL=""
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))
.S BGPVAL=$$DEPSCR^BGP7D25(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$DEP^BGP7D25(DFN,BGPBDATE,BGPEDATE) Q
S BGPVAL=""
I BGPD5 D I BGPVAL S BGPN5=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"IPV: "_$P(BGPVAL,U,5)_" "_$P(BGPVAL,U,4)
.S BGPVAL=$$DVEX^BGP7D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$DVDX^BGP7D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q ;DX ONLY
.S BGPVAL=$$DVPED^BGP7D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q ;W/O V61.11
.S BGPVAL=$$DV61^BGP7D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q ;include in education for gpra
I BGPD6 D
.S BGPVAL=$$TOBACCO^BGP7D7(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
.S BGPVAL=$$DX^BGP7D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
.S BGPVAL=$$PED^BGP7D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
.S BGPVAL=$$DENT^BGP7D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
.S BGPVAL=$$CPTSM^BGP7D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
I BGPD7 D I $P(BGPVAL,U,1)]"" S BGPN7=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"BMI: "_$$SB^BGP7PDL1($J($P(BGPVAL,U),6,2))
.S BGPVAL=$$BMI^BGP7D6(DFN,BGPEDATE,BGPAGEE)
I BGPD8 D I BGPVAL]"" S BGPN8=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"BP: "_$P($P(BGPVAL,U,1)," ")
.S BGPVAL=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1) I BGPVAL]"",BGPVAL'["unknown" Q
.I BGPVAL["unknown" S BGPVAL=$P($$BPCPT^BGP7D22(DFN,BGPBDATE,BGPEDATE),U,2)
I BGPD9 D
.S BGPVAL=$$FIRSTHF^BGP7D8(DFN,BGPBDATE,BGPEDATE,"ACTIVITY LEVEL") ;get the first health factor in this category recorded in this time period
.I BGPVAL S BGPN9=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"PHYS ACT: "_$P(BGPVAL,U,3)_" "_$P(BGPVAL,U,4)
S G=1
I BGPD1 D
.I BGPD3 I 'BGPN3 S G=0
.I BGPD4 I 'BGPN4 S G=0
.I BGPD5 I 'BGPN5 S G=0
.I BGPD6 I 'BGPN6 S G=0
.I BGPD7 I 'BGPN7 S G=0
.I BGPD8 I 'BGPN8 S G=0
.I BGPD9 I 'BGPN9 S G=0
.I G S BGPN1=1,BGPVALUE="ALL COMP HEALTH: "_BGPVALUE
S H=1
I BGPD1 D
.I BGPD3 I 'BGPN3 S H=0
.I BGPD4 I 'BGPN4 S H=0
.I BGPD5 I 'BGPN5 S H=0
.I BGPD6 I 'BGPN6 S H=0
.I BGPD7 I 'BGPN7 S H=0
.I BGPD8 I 'BGPN8 S H=0
.I H S BGPN2=1 I 'G S BGPVALUE="COMP HEALTH: "_BGPVALUE
S BGPVALUE="AC|||"_BGPVALUE
Q
ALSCRNRP(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD,BGPVALF,A
S BGPVALF=""
PCC ;check PCC first
S BGPCT=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S BGPX=0 F S BGPX=$O(^TMP($J,"A",BGPX)) Q:BGPX'=+BGPX!(BGPVALF) S BGPV=$P(^TMP($J,"A",BGPX),U,5) D
.S BGPVD=$$VD^APCLV(BGPV)
PCCEX .;
.S E=0 F S E=$O(^AUPNVXAM("AD",BGPV,E)) Q:E'=+E!(BGPVALF) D
..S I=$P($G(^AUPNVXAM(E,0)),U,1)
..Q:'I
..Q:$P($G(^AUTTEXAM(I,0)),U,2)'=35
..S BGPVALF=1_"^Ex 35^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
.Q:BGPVALF
PCCHF .;
.S E=0 F S E=$O(^AUPNVHF("AD",BGPV,E)) Q:E'=+E!(BGPVALF) D
..S I=$P($G(^AUPNVHF(E,0)),U,1)
..S I=$P($G(^AUTTHF(I,0)),U,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
..S BGPVALF=1_"^HF "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
.Q:BGPVALF
PCCDX .;
.S E=0 F S E=$O(^AUPNVPOV("AD",BGPV,E)) Q:E'=+E!(BGPVALF) D
..S I=$$VAL^XBDIQ1(9000010.07,E,.01)
..I '$$ICD^BGP7UTL2($$VALI^XBDIQ1(9000010.07,E,.01),$O(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9) Q
..S BGPVALF=1_U_"POV "_I_U_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
.Q:BGPVALF
PCCCPT .;
.S E=0 F S E=$O(^AUPNVCPT("AD",BGPV,E)) Q:E'=+E!(BGPVALF) D
..S I=$P($G(^AUPNVCPT(E,0)),U,1)
..Q:'I
..S J=$P(^ICPT(I,0),U)
..Q:'$$ICD^BGP7UTL2(I,BGPCT,1)
..S BGPVALF=1_"^CPT "_J_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
.Q:BGPVALF
PCCMEAS .;now add in v measurements
.S E=0 F S E=$O(^AUPNVMSR("AD",BGPV,E)) Q:E'=+E!(BGPVALF) D
..S I=$$VAL^XBDIQ1(9000010.01,E,.01)
..I I'="AUDT",I'="AUDC",I'="CRFT" Q
..S BGPVALF=1_"^MEAS "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
I BGPVALF Q BGPVALF
BH ;CHECK BH VISITS
S BGPC="",T="",F=""
S E=9999999-BDATE,D=9999999-EDATE-1_".99"
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
BHEX .;
.S BGPVD=9999999-$P(D,"."),BGPIVD=$P(D,".")
.S X=$P($G(^AMHREC(V,14)),U,3)
.I X="P"!(X="N") D
..S BGPVALF=1_"^BH Ex 35^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
.Q:BGPVALF
BHHF .;
.S X=0 F S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X!(BGPVALF) D
..S I=$P($G(^AMHRHF(X,0)),U,1)
..Q:'I
..S I=$P($G(^AUTTHF(I,0)),U,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
..S BGPVALF=1_"^BH HF: "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
..Q
.Q:BGPVALF
BHDX .;
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPVALF) D
..S I=$$VAL^XBDIQ1(9002011.01,X,.01)
..I '$$ICD^BGP7UTL2($$VALI^XBDIQ1(9002011.01,X,.01),$O(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9),I'="29.1" Q
..S BGPVALF=1_U_"BH DX "_I_U_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
..Q
.Q:BGPVALF
BHMEAS .;
.S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPVALF) D
..S I=$$VAL^XBDIQ1(9002011.12,X,.01)
..I I'="AUDT",I'="AUDC",I'="CRFT" Q
..S BGPVALF=1_"^BH Meas "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
.Q:BGPVALF
BHCPT .;now add in CPT codes
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPVALF) D
..S I=$P($G(^AMHRPROC(X,0)),U,1)
..Q:'I
..Q:'$$ICD^BGP7UTL2(I,BGPCT,1)
..S J=$P($G(^ICPT(I,0)),U,1)
..S BGPVALF=1_"^BH CPT: "_J_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
..Q
.Q:BGPVALF
Q BGPVALF
MEANBP(P,BDATE,EDATE,GDEV) ;EP
S GDEV=$G(GDEV)
S X=$$BPS(P,BDATE,EDATE,"I",GDEV)
S S=$$SYSMEAN(X) I S="" Q "unknown^^"
S DS=$$DIAMEAN(X) I DS="" Q "unknown^^"
;I S>159!(DS>99) Q S_"/"_DS_" STG 2 HTN"_U_6
;I S>139&(S<160)!(DS>89&(DS<100)) Q S_"/"_DS_" STG 1 HTN"_U_5
;I S>129&(S<140)!(DS>80&(DS<90)) Q S_"/"_DS_" PRE HTN 2"_U_4
;I S>119&(S<130)!(DS=80) Q S_"/"_DS_" PRE HTN 1"_U_3
;I S<120&(DS<80) Q S_"/"_DS_" NORMAL"_U_2
Q S_"/"_DS_U_1
SYSMEAN(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/")+T
Q T\C
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
;
DIAMEAN(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/",2)+T
Q T\C
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
;
BPS(P,BDATE,EDATE,F,GDEV) ;EP ;
I $G(F)="" S F="E"
S GDEV=$G(GDEV)
NEW BGPGLL,BGPGV,BGPG,X,Y,BGPBP,V,T,Z
S BGPGLL=0,BGPGV=""
K BGPG
K ^TMP($J,"BPV")
S A="^TMP($J,""BPV"",",B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"BPV",1)) Q ""
;S X=P_"^LAST 50 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
;S BGPGL=0 F S BGPGL=$O(BGPG(BGPGL)) Q:BGPGL'=+BGPGL!(BGPGLL=3) S BGPGBP=$P($G(BGPG(BGPGL)),U,2) D
S Y=0 F S Y=$O(^TMP($J,"BPV",Y)) Q:Y'=+Y!(BGPGLL=3) D
.S V=$P(^TMP($J,"BPV",Y),U,5)
.Q:$$CLINIC^APCLV(V,"C")=30 ;NO ER CLINIC VISITS COUNTED
.I $G(GDEV) Q:$$GDEV^BGP7D2(V)
.Q:'$D(^AUPNVMSR("AD",V)) ;no measurements to look at
.;NOW GET ALL BPS ON THIS VISIT
.S BGPBP=""
.S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X D
..Q:'$D(^AUPNVMSR(X,0)) ;BAD AD XREF
..Q:$P($G(^AUPNVMSR(X,2)),U,1)
..S T=$P($G(^AUPNVMSR(X,0)),U)
..Q:T="" ;BAD AD XREF
..Q:$P($G(^AUTTMSR(T,0)),U)'="BP" ;not a BP measurement type
..S Z=$P(^AUPNVMSR(X,0),U,4) ;blood pressure value
..I BGPBP="" S BGPBP=Z Q
..I $P(Z,"/")'>$P(BGPBP,"/") S BGPBP=Z
.Q:BGPBP=""
.S BGPGLL=BGPGLL+1
.I F="E" S $P(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($P(^TMP($J,"BPV",V),U))
.I F="I" S $P(BGPGV,";",BGPGLL)=$P(BGPBP," ")
K ^TMP($J,"BPV")
Q BGPGV
BGP7D26 ; IHS/CMI/LAB - measure 6 03 Jun 2017 3:16 PM 12 Jul 2017 9:31 AM ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+2 ;
COMPHS ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 ;not active clinical
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 SET BGPVALUE=""
+4 ;needs to be at least 2
IF BGPAGEB<2
SET BGPSTOP=1
QUIT
+5 ;alcohol screening
IF BGPAGEB>11
IF BGPAGEB<76
SET BGPD3=1
+6 ;depression screening
IF BGPAGEB>17
SET BGPD4=1
+7 ;ipv/dv screening
IF BGPAGEB>13
IF BGPAGEB<47
IF BGPSEX="F"
SET BGPD5=1
+8 ;tobacco screening
IF BGPAGEB>4
SET BGPD6=1
+9 ;BMI
IF BGPAGEB>1
IF BGPAGEB<75
SET BGPD7=1
+10 ;BP Assessed
IF BGPAGEB>19
SET BGPD8=1
+11 ;PA Assessed
IF BGPAGEB>4
SET BGPD9=1
+12 IF '(BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9)
WRITE BGPBOMB
+13 SET BGPD1=1
+14 SET BGPD2=1
+15 ;now set up numerators
+16 SET BGPVAL=""
+17 IF BGPD3
Begin DoDot:1
+18 SET BGPVAL=$$ALSCRNRP(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+19 SET BGPVAL=$$ALDX^BGP7D55(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+20 SET BGPVAL=$$ALPRC^BGP7D5(DFN,BGPBDATE,BGPEDATE)
End DoDot:1
IF BGPVAL
SET BGPN3=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"ALC: "_$PIECE(BGPVAL,U,3)_" "_$PIECE(BGPVAL,U,2)
+21 SET BGPVAL=""
+22 IF BGPD4
Begin DoDot:1
+23 SET BGPVAL=$$DEPSCR^BGP7D25(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+24 SET BGPVAL=$$DEP^BGP7D25(DFN,BGPBDATE,BGPEDATE)
QUIT
End DoDot:1
IF BGPVAL
SET BGPN4=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"DEPR: "_$PIECE(BGPVAL,U,3)_" "_$SELECT($PIECE(BGPVAL,U,5)]"":$PIECE(BGPVAL,U,5),1:$PIECE(BGPVAL,U,2))
+25 SET BGPVAL=""
+26 IF BGPD5
Begin DoDot:1
+27 SET BGPVAL=$$DVEX^BGP7D5(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+28 ;DX ONLY
SET BGPVAL=$$DVDX^BGP7D5(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+29 ;W/O V61.11
SET BGPVAL=$$DVPED^BGP7D5(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+30 ;include in education for gpra
SET BGPVAL=$$DV61^BGP7D5(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
End DoDot:1
IF BGPVAL
SET BGPN5=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"IPV: "_$PIECE(BGPVAL,U,5)_" "_$PIECE(BGPVAL,U,4)
+31 IF BGPD6
Begin DoDot:1
+32 SET BGPVAL=$$TOBACCO^BGP7D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$PIECE(BGPVAL,U,2)_" "_$PIECE(BGPVAL,U,1)
QUIT
+33 SET BGPVAL=$$DX^BGP7D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
+34 SET BGPVAL=$$PED^BGP7D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
+35 SET BGPVAL=$$DENT^BGP7D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
+36 SET BGPVAL=$$CPTSM^BGP7D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP7UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
End DoDot:1
+37 IF BGPD7
Begin DoDot:1
+38 SET BGPVAL=$$BMI^BGP7D6(DFN,BGPEDATE,BGPAGEE)
End DoDot:1
IF $PIECE(BGPVAL,U,1)]""
SET BGPN7=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"BMI: "_$$SB^BGP7PDL1($JUSTIFY($PIECE(BGPVAL,U),6,2))
+39 IF BGPD8
Begin DoDot:1
+40 SET BGPVAL=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1)
IF BGPVAL]""
IF BGPVAL'["unknown"
QUIT
+41 IF BGPVAL["unknown"
SET BGPVAL=$PIECE($$BPCPT^BGP7D22(DFN,BGPBDATE,BGPEDATE),U,2)
End DoDot:1
IF BGPVAL]""
SET BGPN8=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"BP: "_$PIECE($PIECE(BGPVAL,U,1)," ")
+42 IF BGPD9
Begin DoDot:1
+43 ;get the first health factor in this category recorded in this time period
SET BGPVAL=$$FIRSTHF^BGP7D8(DFN,BGPBDATE,BGPEDATE,"ACTIVITY LEVEL")
+44 IF BGPVAL
SET BGPN9=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"PHYS ACT: "_$PIECE(BGPVAL,U,3)_" "_$PIECE(BGPVAL,U,4)
End DoDot:1
+45 SET G=1
+46 IF BGPD1
Begin DoDot:1
+47 IF BGPD3
IF 'BGPN3
SET G=0
+48 IF BGPD4
IF 'BGPN4
SET G=0
+49 IF BGPD5
IF 'BGPN5
SET G=0
+50 IF BGPD6
IF 'BGPN6
SET G=0
+51 IF BGPD7
IF 'BGPN7
SET G=0
+52 IF BGPD8
IF 'BGPN8
SET G=0
+53 IF BGPD9
IF 'BGPN9
SET G=0
+54 IF G
SET BGPN1=1
SET BGPVALUE="ALL COMP HEALTH: "_BGPVALUE
End DoDot:1
+55 SET H=1
+56 IF BGPD1
Begin DoDot:1
+57 IF BGPD3
IF 'BGPN3
SET H=0
+58 IF BGPD4
IF 'BGPN4
SET H=0
+59 IF BGPD5
IF 'BGPN5
SET H=0
+60 IF BGPD6
IF 'BGPN6
SET H=0
+61 IF BGPD7
IF 'BGPN7
SET H=0
+62 IF BGPD8
IF 'BGPN8
SET H=0
+63 IF H
SET BGPN2=1
IF 'G
SET BGPVALUE="COMP HEALTH: "_BGPVALUE
End DoDot:1
+64 SET BGPVALUE="AC|||"_BGPVALUE
+65 QUIT
ALSCRNRP(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,A
+2 SET BGPVALF=""
PCC ;check PCC first
+1 SET BGPCT=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
+2 KILL ^TMP($JOB,"A")
+3 SET A="^TMP($J,""A"","
+4 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+5 SET BGPX=0
FOR
SET BGPX=$ORDER(^TMP($JOB,"A",BGPX))
IF BGPX'=+BGPX!(BGPVALF)
QUIT
SET BGPV=$PIECE(^TMP($JOB,"A",BGPX),U,5)
Begin DoDot:1
+6 SET BGPVD=$$VD^APCLV(BGPV)
PCCEX ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVXAM("AD",BGPV,E))
IF E'=+E!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVXAM(E,0)),U,1)
+3 IF 'I
QUIT
+4 IF $PIECE($GET(^AUTTEXAM(I,0)),U,2)'=35
QUIT
+5 SET BGPVALF=1_"^Ex 35^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
End DoDot:2
+6 IF BGPVALF
QUIT
PCCHF ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVHF("AD",BGPV,E))
IF E'=+E!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVHF(E,0)),U,1)
+3 SET I=$PIECE($GET(^AUTTHF(I,0)),U,1)
+4 ;cage only
IF I'="CAGE 0/4"
IF I'="CAGE 1/4"
IF I'="CAGE 2/4"
IF I'="CAGE 3/4"
IF I'="CAGE 4/4"
QUIT
+5 SET BGPVALF=1_"^HF "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
End DoDot:2
+6 IF BGPVALF
QUIT
PCCDX ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVPOV("AD",BGPV,E))
IF E'=+E!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9000010.07,E,.01)
+3 IF '$$ICD^BGP7UTL2($$VALI^XBDIQ1(9000010.07,E,.01),$ORDER(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9)
QUIT
+4 SET BGPVALF=1_U_"POV "_I_U_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
End DoDot:2
+5 IF BGPVALF
QUIT
PCCCPT ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",BGPV,E))
IF E'=+E!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVCPT(E,0)),U,1)
+3 IF 'I
QUIT
+4 SET J=$PIECE(^ICPT(I,0),U)
+5 IF '$$ICD^BGP7UTL2(I,BGPCT,1)
QUIT
+6 SET BGPVALF=1_"^CPT "_J_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
End DoDot:2
+7 IF BGPVALF
QUIT
PCCMEAS ;now add in v measurements
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVMSR("AD",BGPV,E))
IF E'=+E!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9000010.01,E,.01)
+3 IF I'="AUDT"
IF I'="AUDC"
IF I'="CRFT"
QUIT
+4 SET BGPVALF=1_"^MEAS "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
End DoDot:2
End DoDot:1
+5 IF BGPVALF
QUIT BGPVALF
BH ;CHECK BH VISITS
+1 SET BGPC=""
SET T=""
SET F=""
+2 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
+3 FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPVALF)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
BHEX ;
+1 SET BGPVD=9999999-$PIECE(D,".")
SET BGPIVD=$PIECE(D,".")
+2 SET X=$PIECE($GET(^AMHREC(V,14)),U,3)
+3 IF X="P"!(X="N")
Begin DoDot:2
+4 SET BGPVALF=1_"^BH Ex 35^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
End DoDot:2
+5 IF BGPVALF
QUIT
BHHF ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHRHF("AD",V,X))
IF X'=+X!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AMHRHF(X,0)),U,1)
+3 IF 'I
QUIT
+4 SET I=$PIECE($GET(^AUTTHF(I,0)),U,1)
+5 ;cage only
IF I'="CAGE 0/4"
IF I'="CAGE 1/4"
IF I'="CAGE 2/4"
IF I'="CAGE 3/4"
IF I'="CAGE 4/4"
QUIT
+6 SET BGPVALF=1_"^BH HF: "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
+7 QUIT
End DoDot:2
+8 IF BGPVALF
QUIT
BHDX ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9002011.01,X,.01)
+3 IF '$$ICD^BGP7UTL2($$VALI^XBDIQ1(9002011.01,X,.01),$ORDER(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9)
IF I'="29.1"
QUIT
+4 SET BGPVALF=1_U_"BH DX "_I_U_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
+5 QUIT
End DoDot:2
+6 IF BGPVALF
QUIT
BHMEAS ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9002011.12,X,.01)
+3 IF I'="AUDT"
IF I'="AUDC"
IF I'="CRFT"
QUIT
+4 SET BGPVALF=1_"^BH Meas "_I_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
End DoDot:2
+5 IF BGPVALF
QUIT
BHCPT ;now add in CPT codes
+1 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X!(BGPVALF)
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AMHRPROC(X,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^BGP7UTL2(I,BGPCT,1)
QUIT
+5 SET J=$PIECE($GET(^ICPT(I,0)),U,1)
+6 SET BGPVALF=1_"^BH CPT: "_J_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD
+7 QUIT
End DoDot:2
+8 IF BGPVALF
QUIT
End DoDot:1
+9 QUIT BGPVALF
MEANBP(P,BDATE,EDATE,GDEV) ;EP
+1 SET GDEV=$GET(GDEV)
+2 SET X=$$BPS(P,BDATE,EDATE,"I",GDEV)
+3 SET S=$$SYSMEAN(X)
IF S=""
QUIT "unknown^^"
+4 SET DS=$$DIAMEAN(X)
IF DS=""
QUIT "unknown^^"
+5 ;I S>159!(DS>99) Q S_"/"_DS_" STG 2 HTN"_U_6
+6 ;I S>139&(S<160)!(DS>89&(DS<100)) Q S_"/"_DS_" STG 1 HTN"_U_5
+7 ;I S>129&(S<140)!(DS>80&(DS<90)) Q S_"/"_DS_" PRE HTN 2"_U_4
+8 ;I S>119&(S<130)!(DS=80) Q S_"/"_DS_" PRE HTN 1"_U_3
+9 ;I S<120&(DS<80) Q S_"/"_DS_" NORMAL"_U_2
+10 QUIT S_"/"_DS_U_1
SYSMEAN(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<2
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/")+T
+5 QUIT T\C
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 ;
DIAMEAN(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<2
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/",2)+T
+5 QUIT T\C
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 ;
BPS(P,BDATE,EDATE,F,GDEV) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 SET GDEV=$GET(GDEV)
+3 NEW BGPGLL,BGPGV,BGPG,X,Y,BGPBP,V,T,Z
+4 SET BGPGLL=0
SET BGPGV=""
+5 KILL BGPG
+6 KILL ^TMP($JOB,"BPV")
+7 SET A="^TMP($J,""BPV"","
SET B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+8 IF '$DATA(^TMP($JOB,"BPV",1))
QUIT ""
+9 ;S X=P_"^LAST 50 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
+10 ;S BGPGL=0 F S BGPGL=$O(BGPG(BGPGL)) Q:BGPGL'=+BGPGL!(BGPGLL=3) S BGPGBP=$P($G(BGPG(BGPGL)),U,2) D
+11 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"BPV",Y))
IF Y'=+Y!(BGPGLL=3)
QUIT
Begin DoDot:1
+12 SET V=$PIECE(^TMP($JOB,"BPV",Y),U,5)
+13 ;NO ER CLINIC VISITS COUNTED
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+14 IF $GET(GDEV)
IF $$GDEV^BGP7D2(V)
QUIT
+15 ;no measurements to look at
IF '$DATA(^AUPNVMSR("AD",V))
QUIT
+16 ;NOW GET ALL BPS ON THIS VISIT
+17 SET BGPBP=""
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+19 ;BAD AD XREF
IF '$DATA(^AUPNVMSR(X,0))
QUIT
+20 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+21 SET T=$PIECE($GET(^AUPNVMSR(X,0)),U)
+22 ;BAD AD XREF
IF T=""
QUIT
+23 ;not a BP measurement type
IF $PIECE($GET(^AUTTMSR(T,0)),U)'="BP"
QUIT
+24 ;blood pressure value
SET Z=$PIECE(^AUPNVMSR(X,0),U,4)
+25 IF BGPBP=""
SET BGPBP=Z
QUIT
+26 IF $PIECE(Z,"/")'>$PIECE(BGPBP,"/")
SET BGPBP=Z
End DoDot:2
+27 IF BGPBP=""
QUIT
+28 SET BGPGLL=BGPGLL+1
+29 IF F="E"
SET $PIECE(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($PIECE(^TMP($JOB,"BPV",V),U))
+30 IF F="I"
SET $PIECE(BGPGV,";",BGPGLL)=$PIECE(BGPBP," ")
End DoDot:1
+31 KILL ^TMP($JOB,"BPV")
+32 QUIT BGPGV
