- BGP2D5 ; IHS/CMI/LAB - measure calc ;
- ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- ;
- I20 ;EP
- S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- I 'BGPACTUP S BGPSTOP=1 Q
- I BGPSEX'="F" S BGPSTOP=1 Q
- I BGPAGEB<15 S BGPSTOP=1 Q
- I BGPAGEB>44 S BGPSTOP=1 Q
- I BGPACTUP S BGPD2=1
- I BGPACTCL S BGPD1=1
- S BGPN2=$$ALHF(DFN,BGP365,BGPEDATE)
- S BGPN3=$$ALDX^BGP2D5A(DFN,BGP365,BGPEDATE)
- I 'BGPN3 S BGPN3=$$ALPRC(DFN,BGP365,BGPEDATE)
- S BGPN4=$$ALPED(DFN,BGP365,BGPEDATE)
- S BGPN5=0
- I BGPN2 S BGPN1=1
- I BGPN3 S BGPN1=1
- I BGPN4 S BGPN1=1
- I 'BGPN1 S BGPN5=$$ALREF(DFN,BGP365,BGPEDATE)
- I BGPN5 S BGPN1=1
- I BGPN1,'BGPN5 S BGPN6=1
- S BGPVALUE=$S(BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")_"|||"
- I $P(BGPN2,U)=1 S BGPVALUE=BGPVALUE_"SCREEN: "_$P(BGPN2,U,3)_" "_$P(BGPN2,U,2)
- I $P(BGPN3,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"DX/PROC: "_$P(BGPN3,U,3)_" "_$P(BGPN3,U,2)
- I $P(BGPN4,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"PT ED: "_$P(BGPN4,U,3)_" "_$P(BGPN4,U,2)
- I BGPRTYPE'=1,$P(BGPN5,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"SCREEN: "_$P(BGPN5,U,3)_" "_$P(BGPN5,U,2)
- K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
- Q
- I21 ;EP
- S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- S (BGPDVEX,BGPDVDX,BGPDVPED,BGPDVREF)=""
- I 'BGPACTUP S BGPSTOP=1 Q
- I BGPSEX'="F" S BGPSTOP=1 Q
- I BGPAGEB<13 S BGPSTOP=1 Q
- I BGPACTUP S BGPD3=1
- I BGPACTCL S BGPD1=1
- I BGPAGEB>14,BGPAGEB<41,BGPACTCL S BGPD2=1 ;gpra denominator 15-40
- I BGPAGEB>14,BGPAGEB<41,BGPACTCB S BGPD4=1 ;ac+bh
- DV ;EP - called from elder care
- S BGPDVEX=$$DVEX(DFN,BGP365,BGPEDATE) I $P(BGPDVEX,U)=1 S BGPN2=1 ;EXAM ONLY
- S BGPDVDX=$$DVDX(DFN,BGP365,BGPEDATE) I $P(BGPDVDX,U)=1 S BGPN3=1 ;DX ONLY
- S BGPDVPED=$$DVPED(DFN,BGP365,BGPEDATE) I $P(BGPDVPED,U)=1 S BGPN4=1,BGPN8=1 ;W/O V61.11
- S BGPDVCOU=$$DV61(DFN,BGP365,BGPEDATE) I $P(BGPDVCOU,U)=1 S BGPN4=1 ;include in education for gpra
- I BGPN2 S BGPN1=1
- I BGPN3 S BGPN1=1
- I BGPN4 S BGPN1=1
- I 'BGPN1 S BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE) I $P(BGPDVREF,U)=1 S BGPN5=1
- I BGPN5 S BGPN1=1
- I BGPN1,'BGPN5 S BGPN6=1 ;
- I BGPN2!(BGPN3)!(BGPDVCOU) S BGPN7=1
- S BGPVALUE=$S(BGPD3:"UP",1:"")_","_$S(BGPD1:"AC",1:"")_"|||"
- I $P(BGPDVEX,U)=1 S BGPVALUE=BGPVALUE_"EXAM: "_$$DATE^BGP2UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
- I $P(BGPDVDX,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($P(BGPDVDX,U,2))_" "_$P(BGPDVDX,U,4)
- I $P(BGPDVPED,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)
- I $P(BGPDVCOU,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($P(BGPDVCOU,U,2))_" "_$P(BGPDVCOU,U,4)
- I BGPRTYPE'=1,$P(BGPDVREF,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"")_$$DATE^BGP2UTL($P(BGPDVREF,U,2))_" "_$P(BGPDVREF,U,3)
- S BGPVALUD="" I BGPD4 S BGPVALUD="AC+BH"_"|||" D
- .I $P(BGPDVEX,U)=1 S BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP2UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
- .I $P(BGPDVDX,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($P(BGPDVDX,U,2))_" "_$P(BGPDVDX,U,4)
- .I $P(BGPDVPED,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)
- .I $P(BGPDVCOU,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($P(BGPDVCOU,U,2))_" "_$P(BGPDVCOU,U,4)
- K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
- Q
- ;
- DVEX(P,BDATE,EDATE) ;EP
- S BGPLDV=""
- K BGPG S %=P_"^LAST EXAM 34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^IPV EXAM 34"_U_"Ex 34"_U_$$DATE^BGP2UTL($P(BGPG(1),U))
- S BGPC=0,BGPV=""
- S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
- .S X=$P($G(^AMHREC(V,14)),U)
- .I X="" Q ;no test
- .I $E(X)="U" Q ;don't count Refusal here
- .I X="REF" Q
- .S BGPC=BGPC+1,BGPV="1^"_(9999999-D)_"^BH IPV EXAM"_U_" BH Ex 34"_U_$$DATE^BGP2UTL((9999999-D))
- I $P(BGPLDV,U,2)<$P(BGPC,U,2) S BGPLDV=BGPC
- Q BGPLDV
- REFDV(P,BDATE,EDATE) ;EP
- ;add Refusal for exam 34
- S G=$$REFUSAL^BGP2UTL1(P,9999999.15,$O(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
- I $P(G,U)=1 Q 1_"^"_$P(G,U,2)_"^Refused Ex 34"
- S G=""
- S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X'=+X!(G) D
- .S H=""
- .I $P($P($G(^AUTTEDT(X,0)),U),"-")="DV"!($P($P($G(^AUTTEDT(X,0)),U),"-",2)="DV") S H=1
- .Q:H'=1
- .S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D'=+D D
- ..S Z=9999999-D
- ..Q:Z<BDATE
- ..Q:Z>EDATE
- ..S G=1_"^"_Z_"^Refused PtEd "_$P(^AUTTEDT(X,0),U)
- I $P(G,U,1)=1 Q G
- S BGPC=0 K BGPV
- S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
- .S X=$P($G(^AMHREC(V,14)),U)
- .I X="" Q ;no test
- .I X="U" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^Refused BH UTS" Q
- .I X="REF" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^Refused BH" Q
- .Q
- I BGPC Q BGPV
- Q ""
- DVDX(P,BDATE,EDATE) ;EP
- I $G(P)="" Q ""
- G DVDX^BGP2D54
- ;
- DVPED(P,BDATE,EDATE) ;EP
- NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV
- K BGPG
- S Y="BGPG(",BGPLDV=""
- S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- I '$D(BGPG(1)) G BHPED
- K BGPV S (X,D,E)=0,%="",T="" F S X=$O(BGPG(X)) Q:X'=+X D
- .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
- .Q:'T
- .Q:'$D(^AUTTEDT(T,0))
- .S T=$P(^AUTTEDT(T,0),U,2)
- .I $P(T,"-",1)="DV"!($P(T,"-",2)="DV") S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($P(BGPG(X),U)) Q
- .S S=$P(T,"-",1)
- .S S=$$ICDDX^ICDCODE(S)
- .I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9) S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($P(BGPG(X),U)) Q
- ;
- BHPED ;
- K BGPV S BGPC="",T="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
- .S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(BGPC) S T=$P($G(^AMHREDU(X,0)),U) D
- ..Q:'T
- ..Q:'$D(^AUTTEDT(T,0))
- ..S T=$P(^AUTTEDT(T,0),U,2)
- ..I $P(T,"-")="DV"!($P(T,"-",2)="DV"),$P(BGPLDV,U,2)<(9999999-$P(D,".")) D
- ...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$P(D,".")))
- ..S S=$P(T,"-",1)
- ..S S=$$ICDDX^ICDCODE(S)
- ..I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9),$P(BGPLDV,U,2)<(9999999-$P(D,".")) D
- ...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$P(D,".")))
- Q BGPLDV ;I BGPC Q BGPV
- DV61(P,BDATE,EDATE) ;EP
- NEW BGPLDV,BGPG,Y,X,E
- S BGPLDV=""
- K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP IPV/DV COUNSELING ICDS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,2)_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP2UTL($P(BGPG(1),U))
- Q BGPLDV
- ALHF(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
- NEW BGPLAL,BGPG,%,E,BGPC,T,F,D,X
- S BGPLAL=""
- K BGPG S %=P_"^LAST EXAM 35;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)) S BGPLAL=1_"^Ex 35^"_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
- ;now add in v measurements
- S BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDT")
- I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP2UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
- S BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDC")
- I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP2UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
- S BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","CRFT")
- I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP2UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
- ;pcc health factor CAGE only in v10.0
- K BGPG S %=P_"^LAST HEALTH CAGE 0/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 0/4^"_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
- K BGPG S %=P_"^LAST HEALTH CAGE 1/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 1/4^"_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
- K BGPG S %=P_"^LAST HEALTH CAGE 2/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 2/4^"_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
- K BGPG S %=P_"^LAST HEALTH CAGE 3/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 3/4^"_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
- K BGPG S %=P_"^LAST HEALTH CAGE 4/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 4/4^"_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
- ;CHECK BH HF FILE
- 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)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
- .S X=0 F S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRHF(X,0)),U) D
- ..Q:'F
- ..Q:'$D(^AUTTHF(F,0))
- ..S T=$P(^AUTTHF(F,0),U,3)
- ..Q:'T
- ..I $P($G(^AUTTHF(F,0)),U)["CAGE " S BGPC=1_U_"BH HF "_$P(^AUTTHF(F,0),U)_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
- ..Q
- .S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRMSR(X,0)),U) D
- ..Q:'F
- ..Q:'$D(^AUTTMSR(F,0))
- ..S T=$P(^AUTTMSR(F,0),U,1)
- ..I T="AUDT"!(T="AUDC")!(T="CRFT") S BGPC=1_U_"BH Meas "_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
- I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
- K BGPG S %=P_"^LAST DX [BGP ALCOHOL SCREEN DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
- I $D(BGPG(1)),$P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
- ;now add in CPT codes
- S BGPC=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),6)
- I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"CPT "_$P(BGPC,U,3)_U_$$DATE^BGP2UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
- ;go through BH record file and find up to 1 visits in date range
- S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
- .S X=$P($G(^AMHREC(V,14)),U)
- .D
- ..I X="" Q ;no test
- ..I $E(X)="U" Q ;don't count Refusal here
- ..I X="REF" Q
- ..S BGPC=1_U_"BH Alcohol scrn"_U_$$DATE^BGP2UTL((9999999-$P(D,".")))_U_(9999999-$P(D,"."))
- .S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRPRO(X,0)),U) D
- ..Q:'BGPP
- ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
- ..I BGPP=29.1 S BGPC=1_U_"BH POV 29.1"_U_$$DATE^BGP2UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q
- ..Q
- .S T=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
- .S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRPROC(X,0)),U) D
- ..Q:'F
- ..I '$$ICD^ATXCHK(T,$P(+$G(^AUPNVCPT(X,0)),U,1),1) Q
- ..S I=$$VAL^XBDIQ1(81,F,.01)
- ..S BGPC=1_U_"BH CPT "_I_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
- I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
- ;
- Q BGPLAL
- ALPRC(P,BDATE,EDATE) ;EP
- S BGPG=$$LASTPRC^BGP2UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
- I BGPG Q 1_U_"Proc "_$P(BGPG,U,2)_U_$$DATE^BGP2UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
- Q ""
- ALPED(P,BDATE,EDATE) ;EP
- K BGPG
- S Y="BGPG(",BGPLPED=""
- S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- I '$D(BGPG(1)) G ALMH
- S (X,D,E)=0,%="",T="" F S X=$O(BGPG(X)) Q:X'=+X D
- .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
- .Q:'T
- .Q:'$D(^AUTTEDT(T,0))
- .S T=$P(^AUTTEDT(T,0),U,2)
- .I $P(T,"-",1)="CD"!($P(T,"-",2)="CD")!($P(T,"-",1)="AOD")!($P(T,"-",2)="AOD"),$P(BGPLPED,U,4)<$P(BGPG(X),U) S BGPLPED=1_U_T_U_$$DATE^BGP2UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
- .S S=$P(T,"-",1)
- .S S=$$ICDDX^ICDCODE(S)
- .I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9),$P(BGPLPED,U,4)<$P(BGPG(X),U,1) S BGPLPED=1_U_""_T_U_$$DATE^BGP2UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
- .I $P(T,"-",1)="99408"!($P(T,"-",1)="99409")!($P(T,"-",1)["G0396")!($P(T,"-",1)["G0397")!($P(T,"-")["H0049")!($P(T,"-")["H0050")!($P(T,"-")["3016F"),$P(BGPLPED,U,4)<$P(BGPG(X),U) D
- ..S BGPLPED=1_U_T_U_$$DATE^BGP2UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
- ALMH ;
- S BGPC="",T="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
- .S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X S T=$P($G(^AMHREDU(X,0)),U) D
- ..Q:'T
- ..Q:'$D(^AUTTEDT(T,0))
- ..S T=$P(^AUTTEDT(T,0),U,2)
- ..I $P(T,"-",1)="CD"!($P(T,"-",2)="CD")!($P(T,"-",1)="AOD")!($P(T,"-",2)="AOD"),$P(BGPLPED,U,4)<(9999999-D) S BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
- ..S S=$P(T,"-",1)
- ..S S=$$ICDDX^ICDCODE(S)
- ..I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9) D
- ...S BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
- ..I $P(T,"-",1)="99408"!($P(T,"-",1)="99409")!($P(T,"-",1)["G0396")!($P(T,"-",1)["G0397")!($P(T,"-")["H0049")!($P(T,"-")["H0050"),$P(BGPLPED,U,4)<(9999999-D) D
- ...S BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
- Q BGPLPED
- ;
- LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
- S C=$O(^AUTTHF("B",C,0))
- I '$G(C) Q ""
- S (H,D)=0 K O
- F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
- .Q:'$D(^AUPNVHF("AA",P,H))
- .S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
- ..Q:(9999999-D)>EDATE ;after time frame
- ..Q:(9999999-D)<BDATE ;before time frame
- ..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
- .Q
- S D=$O(O(0))
- I D="" Q D
- Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP2UTL(9999999-D)_U_(9999999-D)
- ;
- ALREF(P,BDATE,EDATE) ;EP
- ;add Refusal for exam 35
- S G=$$REFUSAL^BGP2UTL1(P,9999999.15,$O(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
- I $P(G,U)=1 Q 1_"^Refused Ex 35^"_$$DATE^BGP2UTL($P(G,U,2))_U_$P(G,U,2)
- Q ""
- LOINC(A,B) ;
- NEW %
- S %=$P($G(^LAB(95.3,A,9999999)),U,2)
- I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
- S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
- I $D(^ATXAX(B,21,"B",%)) Q 1
- Q ""
- BGP2D5 ; IHS/CMI/LAB - measure calc ;
- +1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- +2 ;
- I20 ;EP
- +1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- +2 IF 'BGPACTUP
- SET BGPSTOP=1
- QUIT
- +3 IF BGPSEX'="F"
- SET BGPSTOP=1
- QUIT
- +4 IF BGPAGEB<15
- SET BGPSTOP=1
- QUIT
- +5 IF BGPAGEB>44
- SET BGPSTOP=1
- QUIT
- +6 IF BGPACTUP
- SET BGPD2=1
- +7 IF BGPACTCL
- SET BGPD1=1
- +8 SET BGPN2=$$ALHF(DFN,BGP365,BGPEDATE)
- +9 SET BGPN3=$$ALDX^BGP2D5A(DFN,BGP365,BGPEDATE)
- +10 IF 'BGPN3
- SET BGPN3=$$ALPRC(DFN,BGP365,BGPEDATE)
- +11 SET BGPN4=$$ALPED(DFN,BGP365,BGPEDATE)
- +12 SET BGPN5=0
- +13 IF BGPN2
- SET BGPN1=1
- +14 IF BGPN3
- SET BGPN1=1
- +15 IF BGPN4
- SET BGPN1=1
- +16 IF 'BGPN1
- SET BGPN5=$$ALREF(DFN,BGP365,BGPEDATE)
- +17 IF BGPN5
- SET BGPN1=1
- +18 IF BGPN1
- IF 'BGPN5
- SET BGPN6=1
- +19 SET BGPVALUE=$SELECT(BGPD2:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_"|||"
- +20 IF $PIECE(BGPN2,U)=1
- SET BGPVALUE=BGPVALUE_"SCREEN: "_$PIECE(BGPN2,U,3)_" "_$PIECE(BGPN2,U,2)
- +21 IF $PIECE(BGPN3,U)=1
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
- SET BGPVALUE=BGPVALUE_"DX/PROC: "_$PIECE(BGPN3,U,3)_" "_$PIECE(BGPN3,U,2)
- +22 IF $PIECE(BGPN4,U)=1
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
- SET BGPVALUE=BGPVALUE_"PT ED: "_$PIECE(BGPN4,U,3)_" "_$PIECE(BGPN4,U,2)
- +23 IF BGPRTYPE'=1
- IF $PIECE(BGPN5,U)=1
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
- SET BGPVALUE=BGPVALUE_"SCREEN: "_$PIECE(BGPN5,U,3)_" "_$PIECE(BGPN5,U,2)
- +24 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
- +25 QUIT
- I21 ;EP
- +1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- +2 SET (BGPDVEX,BGPDVDX,BGPDVPED,BGPDVREF)=""
- +3 IF 'BGPACTUP
- SET BGPSTOP=1
- QUIT
- +4 IF BGPSEX'="F"
- SET BGPSTOP=1
- QUIT
- +5 IF BGPAGEB<13
- SET BGPSTOP=1
- QUIT
- +6 IF BGPACTUP
- SET BGPD3=1
- +7 IF BGPACTCL
- SET BGPD1=1
- +8 ;gpra denominator 15-40
- IF BGPAGEB>14
- IF BGPAGEB<41
- IF BGPACTCL
- SET BGPD2=1
- +9 ;ac+bh
- IF BGPAGEB>14
- IF BGPAGEB<41
- IF BGPACTCB
- SET BGPD4=1
- DV ;EP - called from elder care
- +1 ;EXAM ONLY
- SET BGPDVEX=$$DVEX(DFN,BGP365,BGPEDATE)
- IF $PIECE(BGPDVEX,U)=1
- SET BGPN2=1
- +2 ;DX ONLY
- SET BGPDVDX=$$DVDX(DFN,BGP365,BGPEDATE)
- IF $PIECE(BGPDVDX,U)=1
- SET BGPN3=1
- +3 ;W/O V61.11
- SET BGPDVPED=$$DVPED(DFN,BGP365,BGPEDATE)
- IF $PIECE(BGPDVPED,U)=1
- SET BGPN4=1
- SET BGPN8=1
- +4 ;include in education for gpra
- SET BGPDVCOU=$$DV61(DFN,BGP365,BGPEDATE)
- IF $PIECE(BGPDVCOU,U)=1
- SET BGPN4=1
- +5 IF BGPN2
- SET BGPN1=1
- +6 IF BGPN3
- SET BGPN1=1
- +7 IF BGPN4
- SET BGPN1=1
- +8 IF 'BGPN1
- SET BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE)
- IF $PIECE(BGPDVREF,U)=1
- SET BGPN5=1
- +9 IF BGPN5
- SET BGPN1=1
- +10 ;
- IF BGPN1
- IF 'BGPN5
- SET BGPN6=1
- +11 IF BGPN2!(BGPN3)!(BGPDVCOU)
- SET BGPN7=1
- +12 SET BGPVALUE=$SELECT(BGPD3:"UP",1:"")_","_$SELECT(BGPD1:"AC",1:"")_"|||"
- +13 IF $PIECE(BGPDVEX,U)=1
- SET BGPVALUE=BGPVALUE_"EXAM: "_$$DATE^BGP2UTL($PIECE(BGPDVEX,U,2))_" "_$PIECE(BGPDVEX,U,4)
- +14 IF $PIECE(BGPDVDX,U)=1
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($PIECE(BGPDVDX,U,2))_" "_$PIECE(BGPDVDX,U,4)
- +15 IF $PIECE(BGPDVPED,U)=1
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($PIECE(BGPDVPED,U,2))_" "_$PIECE(BGPDVPED,U,4)
- +16 IF $PIECE(BGPDVCOU,U)=1
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($PIECE(BGPDVCOU,U,2))_" "_$PIECE(BGPDVCOU,U,4)
- +17 IF BGPRTYPE'=1
- IF $PIECE(BGPDVREF,U)=1
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")_$$DATE^BGP2UTL($PIECE(BGPDVREF,U,2))_" "_$PIECE(BGPDVREF,U,3)
- +18 SET BGPVALUD=""
- IF BGPD4
- SET BGPVALUD="AC+BH"_"|||"
- Begin DoDot:1
- +19 IF $PIECE(BGPDVEX,U)=1
- SET BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP2UTL($PIECE(BGPDVEX,U,2))_" "_$PIECE(BGPDVEX,U,4)
- +20 IF $PIECE(BGPDVDX,U)=1
- SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($PIECE(BGPDVDX,U,2))_" "_$PIECE(BGPDVDX,U,4)
- +21 IF $PIECE(BGPDVPED,U)=1
- SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($PIECE(BGPDVPED,U,2))_" "_$PIECE(BGPDVPED,U,4)
- +22 IF $PIECE(BGPDVCOU,U)=1
- SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($PIECE(BGPDVCOU,U,2))_" "_$PIECE(BGPDVCOU,U,4)
- End DoDot:1
- +23 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
- +24 QUIT
- +25 ;
- DVEX(P,BDATE,EDATE) ;EP
- +1 SET BGPLDV=""
- +2 KILL BGPG
- SET %=P_"^LAST EXAM 34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(%,"BGPG(")
- +3 IF $DATA(BGPG(1))
- SET BGPLDV=1_"^"_$PIECE(BGPG(1),U)_"^IPV EXAM 34"_U_"Ex 34"_U_$$DATE^BGP2UTL($PIECE(BGPG(1),U))
- +4 SET BGPC=0
- SET BGPV=""
- +5 SET E=9999999-BDATE
- SET D=9999999-EDATE-1_".99"
- FOR
- SET D=$ORDER(^AMHREC("AE",P,D))
- IF D'=+D!($PIECE(D,".")>E)!(BGPC)
- QUIT
- SET V=0
- FOR
- SET V=$ORDER(^AMHREC("AE",P,D,V))
- IF V'=+V!(BGPC)
- QUIT
- Begin DoDot:1
- +6 SET X=$PIECE($GET(^AMHREC(V,14)),U)
- +7 ;no test
- IF X=""
- QUIT
- +8 ;don't count Refusal here
- IF $EXTRACT(X)="U"
- QUIT
- +9 IF X="REF"
- QUIT
- +10 SET BGPC=BGPC+1
- SET BGPV="1^"_(9999999-D)_"^BH IPV EXAM"_U_" BH Ex 34"_U_$$DATE^BGP2UTL((9999999-D))
- End DoDot:1
- +11 IF $PIECE(BGPLDV,U,2)<$PIECE(BGPC,U,2)
- SET BGPLDV=BGPC
- +12 QUIT BGPLDV
- REFDV(P,BDATE,EDATE) ;EP
- +1 ;add Refusal for exam 34
- +2 SET G=$$REFUSAL^BGP2UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
- +3 IF $PIECE(G,U)=1
- QUIT 1_"^"_$PIECE(G,U,2)_"^Refused Ex 34"
- +4 SET G=""
- +5 SET X=0
- FOR
- SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))
- IF X'=+X!(G)
- QUIT
- Begin DoDot:1
- +6 SET H=""
- +7 IF $PIECE($PIECE($GET(^AUTTEDT(X,0)),U),"-")="DV"!($PIECE($PIECE($GET(^AUTTEDT(X,0)),U),"-",2)="DV")
- SET H=1
- +8 IF H'=1
- QUIT
- +9 SET D=0
- FOR
- SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))
- IF D'=+D
- QUIT
- Begin DoDot:2
- +10 SET Z=9999999-D
- +11 IF Z<BDATE
- QUIT
- +12 IF Z>EDATE
- QUIT
- +13 SET G=1_"^"_Z_"^Refused PtEd "_$PIECE(^AUTTEDT(X,0),U)
- End DoDot:2
- End DoDot:1
- +14 IF $PIECE(G,U,1)=1
- QUIT G
- +15 SET BGPC=0
- KILL BGPV
- +16 SET E=9999999-BDATE
- SET D=9999999-EDATE-1_".99"
- FOR
- SET D=$ORDER(^AMHREC("AE",P,D))
- IF D'=+D!($PIECE(D,".")>E)!(BGPC)
- QUIT
- SET V=0
- FOR
- SET V=$ORDER(^AMHREC("AE",P,D,V))
- IF V'=+V!(BGPC)
- QUIT
- Begin DoDot:1
- +17 SET X=$PIECE($GET(^AMHREC(V,14)),U)
- +18 ;no test
- IF X=""
- QUIT
- +19 IF X="U"
- SET BGPC=1
- SET BGPV=1_"^"_(9999999-D)_"^Refused BH UTS"
QUIT
+20 IF X="REF"
SET BGPC=1
SET BGPV=1_"^"_(9999999-D)_"^Refused BH"
QUIT
+21 QUIT
End DoDot:1
+22 IF BGPC
QUIT BGPV
+23 QUIT ""
DVDX(P,BDATE,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 GOTO DVDX^BGP2D54
+3 ;
DVPED(P,BDATE,EDATE) ;EP
+1 NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV
+2 KILL BGPG
+3 SET Y="BGPG("
SET BGPLDV=""
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BGPG(1))
GOTO BHPED
+6 KILL BGPV
SET (X,D,E)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+8 IF 'T
QUIT
+9 IF '$DATA(^AUTTEDT(T,0))
QUIT
+10 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+11 IF $PIECE(T,"-",1)="DV"!($PIECE(T,"-",2)="DV")
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))
QUIT
+12 SET S=$PIECE(T,"-",1)
+13 SET S=$$ICDDX^ICDCODE(S)
+14 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9)
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))
QUIT
End DoDot:1
+15 ;
BHPED ;
+1 KILL BGPV
SET BGPC=""
SET T=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET T=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+3 IF 'T
QUIT
+4 IF '$DATA(^AUTTEDT(T,0))
QUIT
+5 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+6 IF $PIECE(T,"-")="DV"!($PIECE(T,"-",2)="DV")
IF $PIECE(BGPLDV,U,2)<(9999999-$PIECE(D,"."))
Begin DoDot:3
+7 SET BGPLDV=1_"^"_(9999999-$PIECE(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$PIECE(D,".")))
End DoDot:3
+8 SET S=$PIECE(T,"-",1)
+9 SET S=$$ICDDX^ICDCODE(S)
+10 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9)
IF $PIECE(BGPLDV,U,2)<(9999999-$PIECE(D,"."))
Begin DoDot:3
+11 SET BGPLDV=1_"^"_(9999999-$PIECE(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$PIECE(D,".")))
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;I BGPC Q BGPV
QUIT BGPLDV
DV61(P,BDATE,EDATE) ;EP
+1 NEW BGPLDV,BGPG,Y,X,E
+2 SET BGPLDV=""
+3 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP IPV/DV COUNSELING ICDS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
SET BGPLDV=1_"^"_$PIECE(BGPG(1),U)_"^"_$PIECE(BGPG(1),U,2)_U_"POV "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP2UTL($PIECE(BGPG(1),U))
+5 QUIT BGPLDV
ALHF(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
+1 NEW BGPLAL,BGPG,%,E,BGPC,T,F,D,X
+2 SET BGPLAL=""
+3 KILL BGPG
SET %=P_"^LAST EXAM 35;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPLAL=1_"^Ex 35^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+5 ;now add in v measurements
+6 SET BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDT")
+7 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+8 SET BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDC")
+9 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+10 SET BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","CRFT")
+11 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+12 ;pcc health factor CAGE only in v10.0
+13 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 0/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+14 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 0/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+15 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 1/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+16 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 1/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+17 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 2/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+18 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 2/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+19 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 3/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 3/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+21 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 4/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+22 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 4/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+23 ;CHECK BH HF FILE
+24 SET BGPC=""
SET T=""
SET F=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+25 SET X=0
FOR
SET X=$ORDER(^AMHRHF("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET F=$PIECE($GET(^AMHRHF(X,0)),U)
Begin DoDot:2
+26 IF 'F
QUIT
+27 IF '$DATA(^AUTTHF(F,0))
QUIT
+28 SET T=$PIECE(^AUTTHF(F,0),U,3)
+29 IF 'T
QUIT
+30 IF $PIECE($GET(^AUTTHF(F,0)),U)["CAGE "
SET BGPC=1_U_"BH HF "_$PIECE(^AUTTHF(F,0),U)_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
+31 QUIT
End DoDot:2
+32 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET F=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+33 IF 'F
QUIT
+34 IF '$DATA(^AUTTMSR(F,0))
QUIT
+35 SET T=$PIECE(^AUTTMSR(F,0),U,1)
+36 IF T="AUDT"!(T="AUDC")!(T="CRFT")
SET BGPC=1_U_"BH Meas "_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:2
End DoDot:1
+37 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)
SET BGPLAL=BGPC
+38 KILL BGPG
SET %=P_"^LAST DX [BGP ALCOHOL SCREEN DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+39 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_U_"POV "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+40 ;now add in CPT codes
+41 SET BGPC=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),6)
+42 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"CPT "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+43 ;go through BH record file and find up to 1 visits in date range
+44 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+45 SET X=$PIECE($GET(^AMHREC(V,14)),U)
+46 Begin DoDot:2
+47 ;no test
IF X=""
QUIT
+48 ;don't count Refusal here
IF $EXTRACT(X)="U"
QUIT
+49 IF X="REF"
QUIT
+50 SET BGPC=1_U_"BH Alcohol scrn"_U_$$DATE^BGP2UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
End DoDot:2
+51 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+52 IF 'BGPP
QUIT
+53 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+54 IF BGPP=29.1
SET BGPC=1_U_"BH POV 29.1"_U_$$DATE^BGP2UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
QUIT
+55 QUIT
End DoDot:2
+56 SET T=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
+57 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET F=$PIECE($GET(^AMHRPROC(X,0)),U)
Begin DoDot:2
+58 IF 'F
QUIT
+59 IF '$$ICD^ATXCHK(T,$PIECE(+$GET(^AUPNVCPT(X,0)),U,1),1)
QUIT
+60 SET I=$$VAL^XBDIQ1(81,F,.01)
+61 SET BGPC=1_U_"BH CPT "_I_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:2
End DoDot:1
+62 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)
SET BGPLAL=BGPC
+63 ;
+64 QUIT BGPLAL
ALPRC(P,BDATE,EDATE) ;EP
+1 SET BGPG=$$LASTPRC^BGP2UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
+2 IF BGPG
QUIT 1_U_"Proc "_$PIECE(BGPG,U,2)_U_$$DATE^BGP2UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
+3 QUIT ""
ALPED(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
SET BGPLPED=""
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG(1))
GOTO ALMH
+5 SET (X,D,E)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 IF $PIECE(T,"-",1)="CD"!($PIECE(T,"-",2)="CD")!($PIECE(T,"-",1)="AOD")!($PIECE(T,"-",2)="AOD")
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U)
SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+11 SET S=$PIECE(T,"-",1)
+12 SET S=$$ICDDX^ICDCODE(S)
+13 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9)
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U,1)
SET BGPLPED=1_U_""_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+14 IF $PIECE(T,"-",1)="99408"!($PIECE(T,"-",1)="99409")!($PIECE(T,"-",1)["G0396")!($PIECE(T,"-",1)["G0397")!($PIECE(T,"-")["H0049")!($PIECE(T,"-")["H0050")!($PIECE(T,"-")["3016F")
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U)
Begin DoDot:2
+15 SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
End DoDot:1
ALMH ;
+1 SET BGPC=""
SET T=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X
QUIT
SET T=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+3 IF 'T
QUIT
+4 IF '$DATA(^AUTTEDT(T,0))
QUIT
+5 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+6 IF $PIECE(T,"-",1)="CD"!($PIECE(T,"-",2)="CD")!($PIECE(T,"-",1)="AOD")!($PIECE(T,"-",2)="AOD")
IF $PIECE(BGPLPED,U,4)<(9999999-D)
SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
+7 SET S=$PIECE(T,"-",1)
+8 SET S=$$ICDDX^ICDCODE(S)
+9 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9)
Begin DoDot:3
+10 SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:3
+11 IF $PIECE(T,"-",1)="99408"!($PIECE(T,"-",1)="99409")!($PIECE(T,"-",1)["G0396")!($PIECE(T,"-",1)["G0397")!($PIECE(T,"-")["H0049")!($PIECE(T,"-")["H0050")
IF $PIECE(BGPLPED,U,4)<(9999999-D)
Begin DoDot:3
+12 SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT BGPLPED
+14 ;
LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
+1 SET C=$ORDER(^AUTTHF("B",C,0))
+2 IF '$GET(C)
QUIT ""
+3 SET (H,D)=0
KILL O
+4 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+6 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+7 ;after time frame
IF (9999999-D)>EDATE
QUIT
+8 ;before time frame
IF (9999999-D)<BDATE
QUIT
+9 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(O(0))
+12 IF D=""
QUIT D
+13 QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP2UTL(9999999-D)_U_(9999999-D)
+14 ;
ALREF(P,BDATE,EDATE) ;EP
+1 ;add Refusal for exam 35
+2 SET G=$$REFUSAL^BGP2UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^Refused Ex 35^"_$$DATE^BGP2UTL($PIECE(G,U,2))_U_$PIECE(G,U,2)
+4 QUIT ""
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""