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

BGP2D5.m

Go to the documentation of this file.
  1. BGP2D5 ; IHS/CMI/LAB - measure calc ;
  1. ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1. ;
  1. I20 ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1. I 'BGPACTUP S BGPSTOP=1 Q
  1. I BGPSEX'="F" S BGPSTOP=1 Q
  1. I BGPAGEB<15 S BGPSTOP=1 Q
  1. I BGPAGEB>44 S BGPSTOP=1 Q
  1. I BGPACTUP S BGPD2=1
  1. I BGPACTCL S BGPD1=1
  1. S BGPN2=$$ALHF(DFN,BGP365,BGPEDATE)
  1. S BGPN3=$$ALDX^BGP2D5A(DFN,BGP365,BGPEDATE)
  1. I 'BGPN3 S BGPN3=$$ALPRC(DFN,BGP365,BGPEDATE)
  1. S BGPN4=$$ALPED(DFN,BGP365,BGPEDATE)
  1. S BGPN5=0
  1. I BGPN2 S BGPN1=1
  1. I BGPN3 S BGPN1=1
  1. I BGPN4 S BGPN1=1
  1. I 'BGPN1 S BGPN5=$$ALREF(DFN,BGP365,BGPEDATE)
  1. I BGPN5 S BGPN1=1
  1. I BGPN1,'BGPN5 S BGPN6=1
  1. S BGPVALUE=$S(BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")_"|||"
  1. I $P(BGPN2,U)=1 S BGPVALUE=BGPVALUE_"SCREEN: "_$P(BGPN2,U,3)_" "_$P(BGPN2,U,2)
  1. 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)
  1. 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)
  1. 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)
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1. Q
  1. I21 ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1. S (BGPDVEX,BGPDVDX,BGPDVPED,BGPDVREF)=""
  1. I 'BGPACTUP S BGPSTOP=1 Q
  1. I BGPSEX'="F" S BGPSTOP=1 Q
  1. I BGPAGEB<13 S BGPSTOP=1 Q
  1. I BGPACTUP S BGPD3=1
  1. I BGPACTCL S BGPD1=1
  1. I BGPAGEB>14,BGPAGEB<41,BGPACTCL S BGPD2=1 ;gpra denominator 15-40
  1. I BGPAGEB>14,BGPAGEB<41,BGPACTCB S BGPD4=1 ;ac+bh
  1. DV ;EP - called from elder care
  1. S BGPDVEX=$$DVEX(DFN,BGP365,BGPEDATE) I $P(BGPDVEX,U)=1 S BGPN2=1 ;EXAM ONLY
  1. S BGPDVDX=$$DVDX(DFN,BGP365,BGPEDATE) I $P(BGPDVDX,U)=1 S BGPN3=1 ;DX ONLY
  1. S BGPDVPED=$$DVPED(DFN,BGP365,BGPEDATE) I $P(BGPDVPED,U)=1 S BGPN4=1,BGPN8=1 ;W/O V61.11
  1. S BGPDVCOU=$$DV61(DFN,BGP365,BGPEDATE) I $P(BGPDVCOU,U)=1 S BGPN4=1 ;include in education for gpra
  1. I BGPN2 S BGPN1=1
  1. I BGPN3 S BGPN1=1
  1. I BGPN4 S BGPN1=1
  1. I 'BGPN1 S BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE) I $P(BGPDVREF,U)=1 S BGPN5=1
  1. I BGPN5 S BGPN1=1
  1. I BGPN1,'BGPN5 S BGPN6=1 ;
  1. I BGPN2!(BGPN3)!(BGPDVCOU) S BGPN7=1
  1. S BGPVALUE=$S(BGPD3:"UP",1:"")_","_$S(BGPD1:"AC",1:"")_"|||"
  1. I $P(BGPDVEX,U)=1 S BGPVALUE=BGPVALUE_"EXAM: "_$$DATE^BGP2UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
  1. 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)
  1. 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)
  1. 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)
  1. 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)
  1. S BGPVALUD="" I BGPD4 S BGPVALUD="AC+BH"_"|||" D
  1. .I $P(BGPDVEX,U)=1 S BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP2UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
  1. .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)
  1. .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)
  1. .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)
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1. Q
  1. ;
  1. DVEX(P,BDATE,EDATE) ;EP
  1. S BGPLDV=""
  1. K BGPG S %=P_"^LAST EXAM 34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^IPV EXAM 34"_U_"Ex 34"_U_$$DATE^BGP2UTL($P(BGPG(1),U))
  1. S BGPC=0,BGPV=""
  1. 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
  1. .S X=$P($G(^AMHREC(V,14)),U)
  1. .I X="" Q ;no test
  1. .I $E(X)="U" Q ;don't count Refusal here
  1. .I X="REF" Q
  1. .S BGPC=BGPC+1,BGPV="1^"_(9999999-D)_"^BH IPV EXAM"_U_" BH Ex 34"_U_$$DATE^BGP2UTL((9999999-D))
  1. I $P(BGPLDV,U,2)<$P(BGPC,U,2) S BGPLDV=BGPC
  1. Q BGPLDV
  1. REFDV(P,BDATE,EDATE) ;EP
  1. ;add Refusal for exam 34
  1. S G=$$REFUSAL^BGP2UTL1(P,9999999.15,$O(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
  1. I $P(G,U)=1 Q 1_"^"_$P(G,U,2)_"^Refused Ex 34"
  1. S G=""
  1. S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X'=+X!(G) D
  1. .S H=""
  1. .I $P($P($G(^AUTTEDT(X,0)),U),"-")="DV"!($P($P($G(^AUTTEDT(X,0)),U),"-",2)="DV") S H=1
  1. .Q:H'=1
  1. .S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D'=+D D
  1. ..S Z=9999999-D
  1. ..Q:Z<BDATE
  1. ..Q:Z>EDATE
  1. ..S G=1_"^"_Z_"^Refused PtEd "_$P(^AUTTEDT(X,0),U)
  1. I $P(G,U,1)=1 Q G
  1. S BGPC=0 K BGPV
  1. 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
  1. .S X=$P($G(^AMHREC(V,14)),U)
  1. .I X="" Q ;no test
  1. .I X="U" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^Refused BH UTS" Q
  1. .I X="REF" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^Refused BH" Q
  1. .Q
  1. I BGPC Q BGPV
  1. Q ""
  1. DVDX(P,BDATE,EDATE) ;EP
  1. I $G(P)="" Q ""
  1. G DVDX^BGP2D54
  1. ;
  1. DVPED(P,BDATE,EDATE) ;EP
  1. NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV
  1. K BGPG
  1. S Y="BGPG(",BGPLDV=""
  1. S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I '$D(BGPG(1)) G BHPED
  1. K BGPV S (X,D,E)=0,%="",T="" F S X=$O(BGPG(X)) Q:X'=+X D
  1. .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
  1. .Q:'T
  1. .Q:'$D(^AUTTEDT(T,0))
  1. .S T=$P(^AUTTEDT(T,0),U,2)
  1. .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
  1. .S S=$P(T,"-",1)
  1. .S S=$$ICDDX^ICDCODE(S)
  1. .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
  1. ;
  1. BHPED ;
  1. 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
  1. .S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(BGPC) S T=$P($G(^AMHREDU(X,0)),U) D
  1. ..Q:'T
  1. ..Q:'$D(^AUTTEDT(T,0))
  1. ..S T=$P(^AUTTEDT(T,0),U,2)
  1. ..I $P(T,"-")="DV"!($P(T,"-",2)="DV"),$P(BGPLDV,U,2)<(9999999-$P(D,".")) D
  1. ...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$P(D,".")))
  1. ..S S=$P(T,"-",1)
  1. ..S S=$$ICDDX^ICDCODE(S)
  1. ..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
  1. ...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$P(D,".")))
  1. Q BGPLDV ;I BGPC Q BGPV
  1. DV61(P,BDATE,EDATE) ;EP
  1. NEW BGPLDV,BGPG,Y,X,E
  1. S BGPLDV=""
  1. 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)
  1. 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))
  1. Q BGPLDV
  1. ALHF(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
  1. NEW BGPLAL,BGPG,%,E,BGPC,T,F,D,X
  1. S BGPLAL=""
  1. K BGPG S %=P_"^LAST EXAM 35;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) S BGPLAL=1_"^Ex 35^"_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
  1. ;now add in v measurements
  1. S BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDT")
  1. 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)
  1. S BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDC")
  1. 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)
  1. S BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","CRFT")
  1. 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)
  1. ;pcc health factor CAGE only in v10.0
  1. K BGPG S %=P_"^LAST HEALTH CAGE 0/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. 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)
  1. K BGPG S %=P_"^LAST HEALTH CAGE 1/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. 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)
  1. K BGPG S %=P_"^LAST HEALTH CAGE 2/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. 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)
  1. K BGPG S %=P_"^LAST HEALTH CAGE 3/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. 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)
  1. K BGPG S %=P_"^LAST HEALTH CAGE 4/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. 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)
  1. ;CHECK BH HF FILE
  1. 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
  1. .S X=0 F S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRHF(X,0)),U) D
  1. ..Q:'F
  1. ..Q:'$D(^AUTTHF(F,0))
  1. ..S T=$P(^AUTTHF(F,0),U,3)
  1. ..Q:'T
  1. ..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)
  1. ..Q
  1. .S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRMSR(X,0)),U) D
  1. ..Q:'F
  1. ..Q:'$D(^AUTTMSR(F,0))
  1. ..S T=$P(^AUTTMSR(F,0),U,1)
  1. ..I T="AUDT"!(T="AUDC")!(T="CRFT") S BGPC=1_U_"BH Meas "_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
  1. I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
  1. K BGPG S %=P_"^LAST DX [BGP ALCOHOL SCREEN DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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)
  1. ;now add in CPT codes
  1. S BGPC=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),6)
  1. 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)
  1. ;go through BH record file and find up to 1 visits in date range
  1. 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
  1. .S X=$P($G(^AMHREC(V,14)),U)
  1. .D
  1. ..I X="" Q ;no test
  1. ..I $E(X)="U" Q ;don't count Refusal here
  1. ..I X="REF" Q
  1. ..S BGPC=1_U_"BH Alcohol scrn"_U_$$DATE^BGP2UTL((9999999-$P(D,".")))_U_(9999999-$P(D,"."))
  1. .S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRPRO(X,0)),U) D
  1. ..Q:'BGPP
  1. ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
  1. ..I BGPP=29.1 S BGPC=1_U_"BH POV 29.1"_U_$$DATE^BGP2UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q
  1. ..Q
  1. .S T=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
  1. .S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRPROC(X,0)),U) D
  1. ..Q:'F
  1. ..I '$$ICD^ATXCHK(T,$P(+$G(^AUPNVCPT(X,0)),U,1),1) Q
  1. ..S I=$$VAL^XBDIQ1(81,F,.01)
  1. ..S BGPC=1_U_"BH CPT "_I_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
  1. I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
  1. ;
  1. Q BGPLAL
  1. ALPRC(P,BDATE,EDATE) ;EP
  1. S BGPG=$$LASTPRC^BGP2UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
  1. I BGPG Q 1_U_"Proc "_$P(BGPG,U,2)_U_$$DATE^BGP2UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
  1. Q ""
  1. ALPED(P,BDATE,EDATE) ;EP
  1. K BGPG
  1. S Y="BGPG(",BGPLPED=""
  1. S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I '$D(BGPG(1)) G ALMH
  1. S (X,D,E)=0,%="",T="" F S X=$O(BGPG(X)) Q:X'=+X D
  1. .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
  1. .Q:'T
  1. .Q:'$D(^AUTTEDT(T,0))
  1. .S T=$P(^AUTTEDT(T,0),U,2)
  1. .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)
  1. .S S=$P(T,"-",1)
  1. .S S=$$ICDDX^ICDCODE(S)
  1. .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)
  1. .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
  1. ..S BGPLPED=1_U_T_U_$$DATE^BGP2UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
  1. ALMH ;
  1. 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
  1. .S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X S T=$P($G(^AMHREDU(X,0)),U) D
  1. ..Q:'T
  1. ..Q:'$D(^AUTTEDT(T,0))
  1. ..S T=$P(^AUTTEDT(T,0),U,2)
  1. ..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)
  1. ..S S=$P(T,"-",1)
  1. ..S S=$$ICDDX^ICDCODE(S)
  1. ..I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9) D
  1. ...S BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
  1. ..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
  1. ...S BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
  1. Q BGPLPED
  1. ;
  1. LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
  1. S C=$O(^AUTTHF("B",C,0))
  1. I '$G(C) Q ""
  1. S (H,D)=0 K O
  1. F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
  1. .Q:'$D(^AUPNVHF("AA",P,H))
  1. .S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
  1. ..Q:(9999999-D)>EDATE ;after time frame
  1. ..Q:(9999999-D)<BDATE ;before time frame
  1. ..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
  1. .Q
  1. S D=$O(O(0))
  1. I D="" Q D
  1. Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP2UTL(9999999-D)_U_(9999999-D)
  1. ;
  1. ALREF(P,BDATE,EDATE) ;EP
  1. ;add Refusal for exam 35
  1. S G=$$REFUSAL^BGP2UTL1(P,9999999.15,$O(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
  1. I $P(G,U)=1 Q 1_"^Refused Ex 35^"_$$DATE^BGP2UTL($P(G,U,2))_U_$P(G,U,2)
  1. Q ""
  1. LOINC(A,B) ;
  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 ""