BGP0D26 ; IHS/CMI/LAB - measure 6 03 Jun 2010 3:16 PM ;
;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
;
S DFN=10000,BGPBDATE=2990101,BGPEDATE=3031231,BGPACTCL=1
F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.;W DFN,"."
.S BGPVALUE=""
.S BGPAGEB=$$AGE^AUPNPAT(DFN,2990101)
.S BGPAGEE=$$AGE^AUPNPAT(DFN,3031231)
.S BGPSEX=$P(^DPT(DFN,0),U,2)
.D COMPHS
.I BGPVALUE]"" W !,BGPVALUE
.Q
Q
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>14,BGPAGEB<41,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=$$ALSCRN(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$ALDX^BGP0D55(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$ALPRC^BGP0D5(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^BGP0D25(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$DEP^BGP0D25(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^BGP0D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q
.S BGPVAL=$$DVDX^BGP0D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q ;DX ONLY
.S BGPVAL=$$DVPED^BGP0D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q ;W/O V61.11
.S BGPVAL=$$DV61^BGP0D5(DFN,BGPBDATE,BGPEDATE) I BGPVAL Q ;include in education for gpra
I BGPD6 D
.S BGPVAL=$$TOBACCO^BGP0D7(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^BGP0D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
.S BGPVAL=$$PED^BGP0D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
.S BGPVAL=$$DENT^BGP0D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($P(BGPVAL,U,2))_" "_$P(BGPVAL,U,1) Q
.S BGPVAL=$$CPTSM^BGP0D7(DFN,BGPBDATE,BGPEDATE) I $P(BGPVAL,U,1)]"" S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($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^BGP0PDL1($J($P(BGPVAL,U),6,2))
.S BGPVAL=$$BMI^BGP0D6(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^BGP0D41(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE) I BGPVAL]"",BGPVAL'["unknown" Q
.I BGPVAL["unknown" S BGPVAL=$P($$BPCPT^BGP0D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE),U,2)
I BGPD9 D
.S BGPVAL=$$FIRSTHF^BGP0D8(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
ALSCRN(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
S BGPVALF=""
PCC ;check PCC first
S BGPCT=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
K BGPG
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
S BGPX=0 F S BGPX=$O(BGPG(BGPX)) Q:BGPX'=+BGPX!(BGPVALF) S BGPV=$P(BGPG(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^BGP0UTL(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^BGP0UTL(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 I'="V79.1",I'="V11.3" Q
..S BGPVALF=1_U_"POV "_I_U_$$DATE^BGP0UTL(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^ATXCHK(I,BGPCT,1)
..S BGPVALF=1_"^CPT "_J_"^"_$$DATE^BGP0UTL(BGPVD)_U_BGPVD
.Q:BGPVALF
PCCMEAS .;now add in v measurements
.S E=0 F S E=$O(^AUPNVCPT("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^BGP0UTL(BGPVD)_U_BGPVD_U_T_U_"POSITIVE: "_R
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^BGP0UTL(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^BGP0UTL(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 I'="V79.1",I'="V11.3",I'="29.1" Q
..S BGPVALF=1_U_"BH DX "_I_U_$$DATE^BGP0UTL(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^BGP0UTL(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(^AUPNVCPT(X,0)),U,1)
..Q:'I
..Q:'$$ICD^ATXCHK(I,BGPCT,1)
..S BGPVALF=1_"^BH CPT: "_J_"^"_$$DATE^BGP0UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
..Q
.Q:BGPVALF
Q BGPVALF
BGP0D26 ; IHS/CMI/LAB - measure 6 03 Jun 2010 3:16 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
+2 ;
+3 SET DFN=10000
SET BGPBDATE=2990101
SET BGPEDATE=3031231
SET BGPACTCL=1
+4 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+5 ;W DFN,"."
+6 SET BGPVALUE=""
+7 SET BGPAGEB=$$AGE^AUPNPAT(DFN,2990101)
+8 SET BGPAGEE=$$AGE^AUPNPAT(DFN,3031231)
+9 SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)
+10 DO COMPHS
+11 IF BGPVALUE]""
WRITE !,BGPVALUE
+12 QUIT
End DoDot:1
+13 QUIT
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>14
IF BGPAGEB<41
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=$$ALSCRN(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+19 SET BGPVAL=$$ALDX^BGP0D55(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+20 SET BGPVAL=$$ALPRC^BGP0D5(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^BGP0D25(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+24 SET BGPVAL=$$DEP^BGP0D25(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^BGP0D5(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+28 ;DX ONLY
SET BGPVAL=$$DVDX^BGP0D5(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+29 ;W/O V61.11
SET BGPVAL=$$DVPED^BGP0D5(DFN,BGPBDATE,BGPEDATE)
IF BGPVAL
QUIT
+30 ;include in education for gpra
SET BGPVAL=$$DV61^BGP0D5(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^BGP0D7(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^BGP0D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
+34 SET BGPVAL=$$PED^BGP0D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
+35 SET BGPVAL=$$DENT^BGP0D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
+36 SET BGPVAL=$$CPTSM^BGP0D7(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVAL,U,1)]""
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"TOB: "_$$DATE^BGP0UTL($PIECE(BGPVAL,U,2))_" "_$PIECE(BGPVAL,U,1)
QUIT
End DoDot:1
+37 IF BGPD7
Begin DoDot:1
+38 SET BGPVAL=$$BMI^BGP0D6(DFN,BGPEDATE,BGPAGEE)
End DoDot:1
IF $PIECE(BGPVAL,U,1)]""
SET BGPN7=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"BMI: "_$$SB^BGP0PDL1($JUSTIFY($PIECE(BGPVAL,U),6,2))
+39 IF BGPD8
Begin DoDot:1
+40 SET BGPVAL=$$MEANBP^BGP0D41(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
IF BGPVAL]""
IF BGPVAL'["unknown"
QUIT
+41 IF BGPVAL["unknown"
SET BGPVAL=$PIECE($$BPCPT^BGP0D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),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^BGP0D8(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
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
+2 SET BGPVALF=""
PCC ;check PCC first
+1 SET BGPCT=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
+2 KILL BGPG
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
+4 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPG(BGPX))
IF BGPX'=+BGPX!(BGPVALF)
QUIT
SET BGPV=$PIECE(BGPG(BGPX),U,5)
Begin DoDot:1
+5 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^BGP0UTL(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^BGP0UTL(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 I'="V79.1"
IF I'="V11.3"
QUIT
+4 SET BGPVALF=1_U_"POV "_I_U_$$DATE^BGP0UTL(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^ATXCHK(I,BGPCT,1)
QUIT
+6 SET BGPVALF=1_"^CPT "_J_"^"_$$DATE^BGP0UTL(BGPVD)_U_BGPVD
End DoDot:2
+7 IF BGPVALF
QUIT
PCCMEAS ;now add in v measurements
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("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^BGP0UTL(BGPVD)_U_BGPVD_U_T_U_"POSITIVE: "_R
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^BGP0UTL(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^BGP0UTL(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 I'="V79.1"
IF I'="V11.3"
IF I'="29.1"
QUIT
+4 SET BGPVALF=1_U_"BH DX "_I_U_$$DATE^BGP0UTL(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^BGP0UTL(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(^AUPNVCPT(X,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^ATXCHK(I,BGPCT,1)
QUIT
+5 SET BGPVALF=1_"^BH CPT: "_J_"^"_$$DATE^BGP0UTL(BGPVD)_U_BGPVD_U_$SELECT(R="POSITIVE":1,1:0)_U_R
+6 QUIT
End DoDot:2
+7 IF BGPVALF
QUIT
End DoDot:1
+8 QUIT BGPVALF
