- BGP0D7 ; IHS/CMI/LAB - measure 31 ;
- ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
- I18 ;EP
- S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPTD,BGP1320)=0
- I BGPAGEB<5 S BGPSTOP=1 Q
- I BGPACTUP S BGPD1=1
- I BGPAGEB>4,BGPAGEB<14 S BGPD2=1
- I BGPAGEB>13,BGPAGEB<18 S BGPD3=1
- I BGPAGEB>17,BGPAGEB<25 S BGPD4=1
- I BGPAGEB>24,BGPAGEB<45 S BGPD5=1
- I BGPAGEB>44,BGPAGEB<65 S BGPD6=1
- I BGPAGEB>64 S BGPD7=1
- I BGPSEX="F",$$PREG(DFN,$$FMADD^XLFDT(BGPEDATE,(-(30*20))),BGPEDATE) S BGPD8=1
- I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) S BGPSTOP=1 Q
- S BGP20M=$$FMADD^XLFDT(BGPEDATE,-600)
- TA ;EP - called from elder
- S BGPTOB=$$TOBACCO(DFN,BGPBDATE,BGPEDATE)
- S BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)
- S BGPXPTD=$$PED(DFN,BGPBDATE,BGPEDATE)
- S BGP1320=$$DENT(DFN,BGPBDATE,BGPEDATE)
- S BGPSCPT=$$CPTSM(DFN,BGPBDATE,BGPEDATE)
- S BGPN1=$S(BGPTOB]"":1,1:0)
- I BGPSDX]"" S BGPN1=1
- I BGPXPTD]"" S BGPN1=1
- I BGP1320]"" S BGPN1=1
- I BGPSCPT]"" S BGPN1=1
- S (BGPVALUE,BGPVAL)=""
- I 'BGPN1 G TAEND ;not screened so don't bother with other numerators
- S F=$P(BGPTOB,U)
- S %=""
- I BGPSDX]"",$P(BGPSDX,U,1)="305.13" S %=1
- I BGPSDX]"",$P(BGPSDX,U,1)="V15.82" S %=1
- ;BGPN2 - USER
- D
- .I F["CURRENT"!(F["CESSATION") S BGPN2=1,BGPVAL=$P(BGPTOB,U,2)_" SCREEN, USER" Q
- .I (BGPSDX]""&(%="")) S BGPN2=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN, USER" Q
- .I ($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPN2=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, USER" Q
- .I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPN2=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, USER" Q
- ;BGPN3 - SMOKER OR NOT
- D
- .I F["CURRENT SMOKER"!(F="CESSATION-SMOKER") S BGPN3=1,BGPVAL=BGPVAL_", SMOKER" Q
- .I BGPSDX]""&(%="") S BGPN3=1,BGPVAL=BGPVAL_", SMOKER" Q
- .I $P(BGPSCPT,U)="1034F"!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)=99406)!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPN3=1,BGPVAL=BGPVAL_", SMOKER" Q
- ;BGPN4 - SMOKELESS
- D
- .I F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS") S BGPN4=1,BGPVAL=BGPVAL_", SMOKELESS" Q
- .I $P(BGPSCPT,U)="1035F"!($P(BGPSCPT,U)="G8456") S BGPN4=1,BGPVAL=BGPVAL_", SMOKELESS" Q
- ;BGPN5 - ETS
- I F="SMOKER IN HOME"!(F["ENVIRON") S BGPN5=1,BGPVAL=$S(BGPVAL["SCREEN":BGPVAL_", ETS",1:$P(BGPTOB,U,2)_"SCREEN, ETS")
- I BGPN1,BGPVAL="" D
- .I BGPTOB]"" S BGPVAL=$P(BGPTOB,U,2)_" SCREEN" Q
- .I BGPSDX]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN" Q
- .I BGPSCPT]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN" Q
- .I BGPXPTD]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPXPTD,U,2))_" SCREEN" Q
- .I BGP1320]"" S BGPVAL=$$DATE^BGP0UTL($P(BGP1320,U,2))_" SCREEN" Q
- S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")
- S BGPVALUE=V_"|||"_BGPVAL
- ;
- TAEND ;now check pregnancy if necessary
- S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")
- S BGPVALUE=V_"|||"_BGPVAL
- I BGPRTYPE'=5,BGPD8,'BGPN1 D PREGSCRN
- K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPTD,BGP1320,BGP20M
- K ^TMP($J,"A")
- Q
- ;
- PREGSCRN ;
- S BGPTOB=$$TOBACCO(DFN,BGP20M,BGPEDATE)
- S BGPSDX=$$DX(DFN,BGP20M,BGPEDATE)
- S BGPXPTD=$$PED(DFN,BGP20M,BGPEDATE)
- S BGP1320=$$DENT(DFN,BGP20M,BGPEDATE)
- S BGPSCPT=$$CPTSM(DFN,BGP20M,BGPEDATE)
- S BGPN6=$S(BGPTOB]"":1,1:0)
- I BGPSDX]"" S BGPN6=1
- I BGPXPTD]"" S BGPN6=1
- I BGP1320]"" S BGPN6=1
- I BGPSCPT]"" S BGPN6=1
- S (BGPVALUE,BGPVAL)=""
- S F=$P(BGPTOB,U)
- S %=""
- I BGPSDX]"",$P(BGPSDX,U,1)="305.13" S %=1
- I BGPSDX]"",$P(BGPSDX,U,1)="V15.82" S %=1
- ;BGPN7 - USER
- D
- .I F["CURRENT"!(F["CESSATION") S BGPN7=1,BGPVAL=$P(BGPTOB,U,2)_" SCREEN, USER" Q
- .I (BGPSDX]""&(%="")) S BGPN7=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN, USER" Q
- .I ($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPN7=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, USER" Q
- .I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPN7=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, USER" Q
- ;BGPN8 - SMOKER OR NOT
- D
- .I F["CURRENT SMOKER"!(F="CESSATION-SMOKER") S BGPN8=1,BGPVAL=BGPVAL_", SMOKER" Q
- .I BGPSDX]""&(%="") S BGPN8=1,BGPVAL=BGPVAL_", SMOKER" Q
- .I $P(BGPSCPT,U)="1034F"!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)=99406)!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPN8=1,BGPVAL=BGPVAL_", SMOKER" Q
- ;BGPN9 - SMOKELESS
- D
- .I F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS") S BGPN9=1,BGPVAL=BGPVAL_", SMOKELESS" Q
- .I $P(BGPSCPT,U)="1035F"!($P(BGPSCPT,U)="G8456") S BGPN9=1,BGPVAL=BGPVAL_", SMOKELESS" Q
- ;BGPN5 - ETS
- I F="SMOKER IN HOME"!(F["ENVIRON") S BGPN10=1,BGPVAL=BGPVAL_$S(BGPVAL["SCREEN":BGPVAL_", ETS",1:$P(BGPTOB,U,2)_" SCREEN, ETS")
- S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")
- I BGPN1,BGPVAL="" D
- .I BGPTOB]"" S BGPVAL=$P(BGPTOB,U,2)_" SCREEN" Q
- .I BGPSDX]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN" Q
- .I BGPSCPT]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN" Q
- .I BGPXPTD]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPXPTD,U,2))_" SCREEN" Q
- .I BGP1320]"" S BGPVAL=$$DATE^BGP0UTL($P(BGP1320,U,2))_" SCREEN" Q
- S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")
- S BGPVALUE=V_"|||"_BGPVAL
- Q
- ;
- I023 ;EP - PHN
- K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE
- I 'BGPACTUP S BGPSTOP=1 Q
- S (BGPN1,BGPN2)=0
- S BGPVALUE=$$PHNV(DFN,BGP365,BGPEDATE,BGPHOME)
- S BGPN1=BGPVALUE
- S BGPVALUE="UP|||"_$P(BGPVALUE,U)_" all PHN; "_$P(BGPVALUE,U,2)_" home; "_$P(BGPVALUE,U,12)_" driver all; "_$P(BGPVALUE,U,13)_" driver home"
- K ^TMP($J,"A")
- Q
- PHNV(P,BDATE,EDATE,HOMELOC) ;
- S HOMELOC=$G(HOMELOC)
- K ^TMP($J,"A") S A="^TMP($J,""A"","
- S B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
- I '$D(^TMP($J,"A",1)) Q "0^0^0^0^0^0^0^0^0^0^0^0^0"
- S (X,Y)=0,C="0^0^0^0^0^0^0^0^0^0^0^0^0" F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
- .;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q
- .S (D,Y,Z)=0
- .F S D=$O(^AUPNVPRV("AD",V,D)) Q:D'=+D S Q=$P(^AUPNVPRV(D,0),U) D
- ..Q:Q=""
- ..S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$S($P(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))
- ..I % S %=$P($G(^DIC(7,+%,9999999)),U)
- ..I %'=13,%'=91 Q ;not a phn or driver
- ..S $P(C,U,1)=$P(C,U,1)+1
- ..I %=91 S $P(C,U,12)=$P(C,U,12)+1
- ..D HOME
- ..D AGE
- Q C
- ;
- HOME ;
- S HV=0
- I $$CLINIC^APCLV(V,"C")=11 S $P(C,U,2)=$P(C,U,2)+1,HV=1 S:%=91 $P(C,U,13)=$P(C,U,13)+1 Q
- Q:HOMELOC=""
- I HOMELOC=$P(^AUPNVSIT(V,0),U,6) S $P(C,U,2)=$P(C,U,2)+1,HV=1 S:%=91 $P(C,U,13)=$P(C,U,13)+1 Q
- Q
- AGE ;
- S DAYS=$$FMDIFF^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),$P(^DPT(P,0),U,3))
- S YRS=$$AGE^AUPNPAT(P,$P($P(^AUPNVSIT(V,0),U),"."))
- I DAYS<29 S $P(C,U,3)=$P(C,U,3)+1 S:HV=1 $P(C,U,4)=$P(C,U,4)+1 Q
- I DAYS>28,YRS<1 S $P(C,U,5)=$P(C,U,5)+1 S:HV=1 $P(C,U,6)=$P(C,U,6)+1 Q
- I YRS>0,YRS<65 S $P(C,U,7)=$P(C,U,7)+1 S:HV=1 $P(C,U,8)=$P(C,U,8)+1 Q
- I YRS>64 S $P(C,U,9)=$P(C,U,9)+1 S:HV=1 $P(C,U,10)=$P(C,U,10)+1 Q
- W BGPBOMB
- Q
- DENT(P,BDATE,EDATE) ;EP
- K ^TMP($J,"A")
- S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
- I '$D(^TMP($J,"A",1)) Q ""
- S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
- .Q:'$D(^AUPNVSIT(V,0))
- .Q:'$P(^AUPNVSIT(V,0),U,9)
- .Q:$P(^AUPNVSIT(V,0),U,11)
- .S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G) S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S G=1_U_$P($P(^AUPNVSIT(V,0),U),".")
- .Q
- I G=0 Q ""
- Q "ADA 1320"_U_$P(G,U,2)
- PED(P,BDATE,EDATE) ;EP
- K BGPG
- S Y="BGPG("
- S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- I '$D(BGPG) Q ""
- S (X,D)=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,"-")="TO" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-",2)="TO" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-",2)="SHS" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="305.1" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="305.10" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="305.11" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="305.12" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="305.13" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="649.00" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="649.01" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="649.02" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="649.03" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="649.04" S %=T_U_$P(BGPG(X),U) Q
- .I $P(T,"-")="V15.82" S %=T_U_$P(BGPG(X),U) Q
- Q %
- PREG(P,BDATE,EDATE,NORXCHR) ;EP
- NEW BGPDX,B,CNT,BGPD,BGPG
- S B=0,CNT=0,BGPD="" ;if there is one before time frame set this to 1
- S NORXCHR=$G(NORXCHR)
- K BGPG
- S Y="BGPG("
- S X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
- I '$D(BGPG) G PROB ;no diagnoses
- S B=0,X=0 F S X=$O(BGPG(X)) Q:X'=+X D
- .;get date
- .S D=$P(BGPG(X),U,1)
- .S C=$$CLINIC^APCLV($P(BGPG(X),U,5),"C")
- .I NORXCHR,C=39 Q
- .S C=$$PRIMPROV^APCLV($P(BGPG(X),U,5),"D")
- .I NORXCHR,C=53 Q ;no chr as primary provider
- .S BGPDX(D)="",CNT=CNT+1 I CNT=2 S BGPD=D
- .I D>$$FMADD^XLFDT(EDATE,-365) S B=1
- .Q
- I CNT>1,B G MA
- PROB ;
- I '$G(B) Q "" ;no pregnancy visit during time period ;-Lori fix in 09
- S T=$O(^ATXAX("B","BGP GPRA PREGNANCY DIAGNOSES",0))
- S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
- .Q:$P(^AUPNPROB(X,0),U,12)'="A"
- .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
- .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
- .S Y=$P(^AUPNPROB(X,0),U)
- .Q:'$$ICD^ATXCHK(Y,T,9)
- .S G=$P(^AUPNPROB(X,0),U,8)
- .Q
- I G=0,BGPD="" Q 0 ;no dxs and no problem list
- S BGPD=G
- MA ;now check for abortion or miscarriage
- ;abortion first
- K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- I $D(BGPG(1)) Q 0 ;HAD MIS/AB
- S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
- I BGPG Q 0
- S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
- S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
- .Q:$P(^AUPNPROB(X,0),U,12)'="A"
- .Q:$P(^AUPNPROB(X,0),U,8)<BGPD
- .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
- .S Y=$P(^AUPNPROB(X,0),U)
- .Q:'$$ICD^ATXCHK(Y,T,9)
- .S G=1
- .Q
- I G Q 0
- ;now check CPTs for Abortion and Miscarriage
- S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
- S %=$$CPT^BGP0DU(P,BGPD,EDATE,T,3)
- I %]"" Q 0
- S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
- S %=$$CPT^BGP0DU(P,BGPD,EDATE,T,3)
- I %]"" Q 0
- S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
- S %=$$TRAN^BGP0DU(P,BGPD,EDATE,T,3)
- I %]"" Q 0
- S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
- S %=$$TRAN^BGP0DU(P,BGPD,EDATE,T,3)
- I %]"" Q 0
- Q 1
- DX(P,BDATE,EDATE) ;EP
- K BGPG
- S BGPG(1)=$$LASTDX^BGP0UTL1(P,"BGP GPRA SMOKING DXS",BDATE,EDATE)
- I BGPG(1)]"" Q $P($$ICDDX^ICDCODE($P(BGPG(1),U,4),$P(BGPG(1),U,1)),U,2)_U_$P(BGPG(1),U,3)
- S T=$O(^ATXAX("B","BGP GPRA SMOKING DXS",0))
- S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
- .Q:$P(^AUPNPROB(X,0),U,12)'="A"
- .Q:$P(^AUPNPROB(X,0),U,3)>EDATE
- .Q:$P(^AUPNPROB(X,0),U,3)<BDATE
- .S Y=$P(^AUPNPROB(X,0),U)
- .Q:'$$ICD^ATXCHK(Y,T,9)
- .S G=$P($$ICDDX^ICDCODE(Y),U,2)_" PL"_U_$P(^AUPNPROB(X,0),U,3)
- .Q
- Q G
- TOBACCO(P,BDATE,EDATE) ;EP
- K BGPTOB,BGP
- D TOBACCO1
- I BGPTOB]"" Q BGPTOB
- D TOBACCO0
- I $D(BGPTOB) Q BGPTOB
- Q ""
- TOBACCO1 ;check for tobacco documented in health factors
- K BGPTOB S BGPTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE) K O,D,H
- Q
- TOBACCO0 ;lookup in health status
- S (X,Y)=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y) I $$VAL^XBDIQ1(9999999.64,X,.03)="TOBACCO" S Y=X
- Q:'Y
- S E=$O(^AUPNHF("AA",P,Y,0)) Q:'E
- I (9999999-E)>EDATE Q ;documented after time frame
- I (9999999-E)<BDATE Q ;documented before year
- S Y=$P(^AUTTHF(Y,0),U)
- S BGPTOB=Y_"^"_$$DATE^BGP0UTL(9999999-E)_"^"_(9999999-E)
- K Y,E,X
- Q
- ;
- LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
- S C=$O(^AUTTHF("B",C,0)) ;ien of category passed
- 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^BGP0UTL(9999999-D)_"^"_(9999999-D)
- ;
- 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 ""
- ;
- CPTSM(P,BDATE,EDATE) ;EP - did pat have TOBACCO SCREENING cpt?
- NEW X
- S X=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP TOBACCO SCREEN CPTS",0)),5)
- I X]"" Q $P(X,U,2)_U_$P(X,U,1)
- ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1034F"))
- ;I X Q "1034F"_U_$P(X,U,2)
- ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1035F"))
- ;I X Q "1035F"_U_$P(X,U,2)
- ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1036F"))
- ;I X Q "1036F"_U_$P(X,U,2)
- Q ""
- BGP0D7 ; IHS/CMI/LAB - measure 31 ;
- +1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
- I18 ;EP
- +1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPTD,BGP1320)=0
- +2 IF BGPAGEB<5
- SET BGPSTOP=1
- QUIT
- +3 IF BGPACTUP
- SET BGPD1=1
- +4 IF BGPAGEB>4
- IF BGPAGEB<14
- SET BGPD2=1
- +5 IF BGPAGEB>13
- IF BGPAGEB<18
- SET BGPD3=1
- +6 IF BGPAGEB>17
- IF BGPAGEB<25
- SET BGPD4=1
- +7 IF BGPAGEB>24
- IF BGPAGEB<45
- SET BGPD5=1
- +8 IF BGPAGEB>44
- IF BGPAGEB<65
- SET BGPD6=1
- +9 IF BGPAGEB>64
- SET BGPD7=1
- +10 IF BGPSEX="F"
- IF $$PREG(DFN,$$FMADD^XLFDT(BGPEDATE,(-(30*20))),BGPEDATE)
- SET BGPD8=1
- +11 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8)
- SET BGPSTOP=1
- QUIT
- +12 SET BGP20M=$$FMADD^XLFDT(BGPEDATE,-600)
- TA ;EP - called from elder
- +1 SET BGPTOB=$$TOBACCO(DFN,BGPBDATE,BGPEDATE)
- +2 SET BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)
- +3 SET BGPXPTD=$$PED(DFN,BGPBDATE,BGPEDATE)
- +4 SET BGP1320=$$DENT(DFN,BGPBDATE,BGPEDATE)
- +5 SET BGPSCPT=$$CPTSM(DFN,BGPBDATE,BGPEDATE)
- +6 SET BGPN1=$SELECT(BGPTOB]"":1,1:0)
- +7 IF BGPSDX]""
- SET BGPN1=1
- +8 IF BGPXPTD]""
- SET BGPN1=1
- +9 IF BGP1320]""
- SET BGPN1=1
- +10 IF BGPSCPT]""
- SET BGPN1=1
- +11 SET (BGPVALUE,BGPVAL)=""
- +12 ;not screened so don't bother with other numerators
- IF 'BGPN1
- GOTO TAEND
- +13 SET F=$PIECE(BGPTOB,U)
- +14 SET %=""
- +15 IF BGPSDX]""
- IF $PIECE(BGPSDX,U,1)="305.13"
- SET %=1
- +16 IF BGPSDX]""
- IF $PIECE(BGPSDX,U,1)="V15.82"
- SET %=1
- +17 ;BGPN2 - USER
- +18 Begin DoDot:1
- +19 IF F["CURRENT"!(F["CESSATION")
- SET BGPN2=1
- SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN, USER"
- QUIT
- +20 IF (BGPSDX]""&(%=""))
- SET BGPN2=1
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN, USER"
- QUIT
- +21 IF ($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)
- SET BGPN2=1
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
- QUIT
- +22 IF $PIECE(BGPSCPT,U)=99406!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8456")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")
- SET BGPN2=1
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
- QUIT
- End DoDot:1
- +23 ;BGPN3 - SMOKER OR NOT
- +24 Begin DoDot:1
- +25 IF F["CURRENT SMOKER"!(F="CESSATION-SMOKER")
- SET BGPN3=1
- SET BGPVAL=BGPVAL_", SMOKER"
- QUIT
- +26 IF BGPSDX]""&(%="")
- SET BGPN3=1
- SET BGPVAL=BGPVAL_", SMOKER"
- QUIT
- +27 IF $PIECE(BGPSCPT,U)="1034F"!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)!($PIECE(BGPSCPT,U)=99406)!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")
- SET BGPN3=1
- SET BGPVAL=BGPVAL_", SMOKER"
- QUIT
- End DoDot:1
- +28 ;BGPN4 - SMOKELESS
- +29 Begin DoDot:1
- +30 IF F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS")
- SET BGPN4=1
- SET BGPVAL=BGPVAL_", SMOKELESS"
- QUIT
- +31 IF $PIECE(BGPSCPT,U)="1035F"!($PIECE(BGPSCPT,U)="G8456")
- SET BGPN4=1
- SET BGPVAL=BGPVAL_", SMOKELESS"
- QUIT
- End DoDot:1
- +32 ;BGPN5 - ETS
- +33 IF F="SMOKER IN HOME"!(F["ENVIRON")
- SET BGPN5=1
- SET BGPVAL=$SELECT(BGPVAL["SCREEN":BGPVAL_", ETS",1:$PIECE(BGPTOB,U,2)_"SCREEN, ETS")
- +34 IF BGPN1
- IF BGPVAL=""
- Begin DoDot:1
- +35 IF BGPTOB]""
- SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN"
- QUIT
- +36 IF BGPSDX]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN"
- QUIT
- +37 IF BGPSCPT]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN"
- QUIT
- +38 IF BGPXPTD]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPXPTD,U,2))_" SCREEN"
- QUIT
- +39 IF BGP1320]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGP1320,U,2))_" SCREEN"
- QUIT
- End DoDot:1
- +40 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
- +41 SET BGPVALUE=V_"|||"_BGPVAL
- +42 ;
- TAEND ;now check pregnancy if necessary
- +1 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
- +2 SET BGPVALUE=V_"|||"_BGPVAL
- +3 IF BGPRTYPE'=5
- IF BGPD8
- IF 'BGPN1
- DO PREGSCRN
- +4 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPTD,BGP1320,BGP20M
- +5 KILL ^TMP($JOB,"A")
- +6 QUIT
- +7 ;
- PREGSCRN ;
- +1 SET BGPTOB=$$TOBACCO(DFN,BGP20M,BGPEDATE)
- +2 SET BGPSDX=$$DX(DFN,BGP20M,BGPEDATE)
- +3 SET BGPXPTD=$$PED(DFN,BGP20M,BGPEDATE)
- +4 SET BGP1320=$$DENT(DFN,BGP20M,BGPEDATE)
- +5 SET BGPSCPT=$$CPTSM(DFN,BGP20M,BGPEDATE)
- +6 SET BGPN6=$SELECT(BGPTOB]"":1,1:0)
- +7 IF BGPSDX]""
- SET BGPN6=1
- +8 IF BGPXPTD]""
- SET BGPN6=1
- +9 IF BGP1320]""
- SET BGPN6=1
- +10 IF BGPSCPT]""
- SET BGPN6=1
- +11 SET (BGPVALUE,BGPVAL)=""
- +12 SET F=$PIECE(BGPTOB,U)
- +13 SET %=""
- +14 IF BGPSDX]""
- IF $PIECE(BGPSDX,U,1)="305.13"
- SET %=1
- +15 IF BGPSDX]""
- IF $PIECE(BGPSDX,U,1)="V15.82"
- SET %=1
- +16 ;BGPN7 - USER
- +17 Begin DoDot:1
- +18 IF F["CURRENT"!(F["CESSATION")
- SET BGPN7=1
- SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN, USER"
- QUIT
- +19 IF (BGPSDX]""&(%=""))
- SET BGPN7=1
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN, USER"
- QUIT
- +20 IF ($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)
- SET BGPN7=1
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
- QUIT
- +21 IF $PIECE(BGPSCPT,U)=99406!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8456")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")
- SET BGPN7=1
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
- QUIT
- End DoDot:1
- +22 ;BGPN8 - SMOKER OR NOT
- +23 Begin DoDot:1
- +24 IF F["CURRENT SMOKER"!(F="CESSATION-SMOKER")
- SET BGPN8=1
- SET BGPVAL=BGPVAL_", SMOKER"
- QUIT
- +25 IF BGPSDX]""&(%="")
- SET BGPN8=1
- SET BGPVAL=BGPVAL_", SMOKER"
- QUIT
- +26 IF $PIECE(BGPSCPT,U)="1034F"!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)!($PIECE(BGPSCPT,U)=99406)!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")
- SET BGPN8=1
- SET BGPVAL=BGPVAL_", SMOKER"
- QUIT
- End DoDot:1
- +27 ;BGPN9 - SMOKELESS
- +28 Begin DoDot:1
- +29 IF F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS")
- SET BGPN9=1
- SET BGPVAL=BGPVAL_", SMOKELESS"
- QUIT
- +30 IF $PIECE(BGPSCPT,U)="1035F"!($PIECE(BGPSCPT,U)="G8456")
- SET BGPN9=1
- SET BGPVAL=BGPVAL_", SMOKELESS"
- QUIT
- End DoDot:1
- +31 ;BGPN5 - ETS
- +32 IF F="SMOKER IN HOME"!(F["ENVIRON")
- SET BGPN10=1
- SET BGPVAL=BGPVAL_$SELECT(BGPVAL["SCREEN":BGPVAL_", ETS",1:$PIECE(BGPTOB,U,2)_" SCREEN, ETS")
- +33 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
- +34 IF BGPN1
- IF BGPVAL=""
- Begin DoDot:1
- +35 IF BGPTOB]""
- SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN"
- QUIT
- +36 IF BGPSDX]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN"
- QUIT
- +37 IF BGPSCPT]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN"
- QUIT
- +38 IF BGPXPTD]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPXPTD,U,2))_" SCREEN"
- QUIT
- +39 IF BGP1320]""
- SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGP1320,U,2))_" SCREEN"
- QUIT
- End DoDot:1
- +40 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
- +41 SET BGPVALUE=V_"|||"_BGPVAL
- +42 QUIT
- +43 ;
- I023 ;EP - PHN
- +1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE
- +2 IF 'BGPACTUP
- SET BGPSTOP=1
- QUIT
- +3 SET (BGPN1,BGPN2)=0
- +4 SET BGPVALUE=$$PHNV(DFN,BGP365,BGPEDATE,BGPHOME)
- +5 SET BGPN1=BGPVALUE
- +6 SET BGPVALUE="UP|||"_$PIECE(BGPVALUE,U)_" all PHN; "_$PIECE(BGPVALUE,U,2)_" home; "_$PIECE(BGPVALUE,U,12)_" driver all; "_$PIECE(BGPVALUE,U,13)_" driver home"
- +7 KILL ^TMP($JOB,"A")
- +8 QUIT
- PHNV(P,BDATE,EDATE,HOMELOC) ;
- +1 SET HOMELOC=$GET(HOMELOC)
- +2 KILL ^TMP($JOB,"A")
- SET A="^TMP($J,""A"","
- +3 SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(B,A)
- +4 IF '$DATA(^TMP($JOB,"A",1))
- QUIT "0^0^0^0^0^0^0^0^0^0^0^0^0"
- +5 SET (X,Y)=0
- SET C="0^0^0^0^0^0^0^0^0^0^0^0^0"
- FOR
- SET X=$ORDER(^TMP($JOB,"A",X))
- IF X'=+X
- QUIT
- SET V=$PIECE(^TMP($JOB,"A",X),U,5)
- Begin DoDot:1
- +6 ;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q
- +7 SET (D,Y,Z)=0
- +8 FOR
- SET D=$ORDER(^AUPNVPRV("AD",V,D))
- IF D'=+D
- QUIT
- SET Q=$PIECE(^AUPNVPRV(D,0),U)
- Begin DoDot:2
- +9 IF Q=""
- QUIT
- +10 SET %=$$VALI^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))
- +11 IF %
- SET %=$PIECE($GET(^DIC(7,+%,9999999)),U)
- +12 ;not a phn or driver
- IF %'=13
- IF %'=91
- QUIT
- +13 SET $PIECE(C,U,1)=$PIECE(C,U,1)+1
- +14 IF %=91
- SET $PIECE(C,U,12)=$PIECE(C,U,12)+1
- +15 DO HOME
- +16 DO AGE
- End DoDot:2
- End DoDot:1
- +17 QUIT C
- +18 ;
- HOME ;
- +1 SET HV=0
- +2 IF $$CLINIC^APCLV(V,"C")=11
- SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
- SET HV=1
- IF %=91
- SET $PIECE(C,U,13)=$PIECE(C,U,13)+1
- QUIT
- +3 IF HOMELOC=""
- QUIT
- +4 IF HOMELOC=$PIECE(^AUPNVSIT(V,0),U,6)
- SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
- SET HV=1
- IF %=91
- SET $PIECE(C,U,13)=$PIECE(C,U,13)+1
- QUIT
- +5 QUIT
- AGE ;
- +1 SET DAYS=$$FMDIFF^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."),$PIECE(^DPT(P,0),U,3))
- +2 SET YRS=$$AGE^AUPNPAT(P,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
- +3 IF DAYS<29
- SET $PIECE(C,U,3)=$PIECE(C,U,3)+1
- IF HV=1
- SET $PIECE(C,U,4)=$PIECE(C,U,4)+1
- QUIT
- +4 IF DAYS>28
- IF YRS<1
- SET $PIECE(C,U,5)=$PIECE(C,U,5)+1
- IF HV=1
- SET $PIECE(C,U,6)=$PIECE(C,U,6)+1
- QUIT
- +5 IF YRS>0
- IF YRS<65
- SET $PIECE(C,U,7)=$PIECE(C,U,7)+1
- IF HV=1
- SET $PIECE(C,U,8)=$PIECE(C,U,8)+1
- QUIT
- +6 IF YRS>64
- SET $PIECE(C,U,9)=$PIECE(C,U,9)+1
- IF HV=1
- SET $PIECE(C,U,10)=$PIECE(C,U,10)+1
- QUIT
- +7 WRITE BGPBOMB
- +8 QUIT
- DENT(P,BDATE,EDATE) ;EP
- +1 KILL ^TMP($JOB,"A")
- +2 SET A="^TMP($J,""A"","
- SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(B,A)
- +3 IF '$DATA(^TMP($JOB,"A",1))
- QUIT ""
- +4 SET (X,G)=0
- FOR
- SET X=$ORDER(^TMP($JOB,"A",X))
- IF X'=+X!(G)
- QUIT
- SET V=$PIECE(^TMP($JOB,"A",X),U,5)
- Begin DoDot:1
- +5 IF '$DATA(^AUPNVSIT(V,0))
- QUIT
- +6 IF '$PIECE(^AUPNVSIT(V,0),U,9)
- QUIT
- +7 IF $PIECE(^AUPNVSIT(V,0),U,11)
- QUIT
- +8 SET Z=0
- FOR
- SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
- IF Z'=+Z!(G)
- QUIT
- SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
- IF B
- SET B=$PIECE($GET(^AUTTADA(B,0)),U)
- IF B=1320
- SET G=1_U_$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
- +9 QUIT
- End DoDot:1
- +10 IF G=0
- QUIT ""
- +11 QUIT "ADA 1320"_U_$PIECE(G,U,2)
- PED(P,BDATE,EDATE) ;EP
- +1 KILL BGPG
- +2 SET Y="BGPG("
- +3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(X,Y)
- +4 IF '$DATA(BGPG)
- QUIT ""
- +5 SET (X,D)=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,"-")="TO"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +11 IF $PIECE(T,"-",2)="TO"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +12 IF $PIECE(T,"-",2)="SHS"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +13 IF $PIECE(T,"-")="305.1"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +14 IF $PIECE(T,"-")="305.10"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +15 IF $PIECE(T,"-")="305.11"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +16 IF $PIECE(T,"-")="305.12"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +17 IF $PIECE(T,"-")="305.13"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +18 IF $PIECE(T,"-")="649.00"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +19 IF $PIECE(T,"-")="649.01"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +20 IF $PIECE(T,"-")="649.02"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +21 IF $PIECE(T,"-")="649.03"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +22 IF $PIECE(T,"-")="649.04"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- +23 IF $PIECE(T,"-")="V15.82"
- SET %=T_U_$PIECE(BGPG(X),U)
- QUIT
- End DoDot:1
- +24 QUIT %
- PREG(P,BDATE,EDATE,NORXCHR) ;EP
- +1 NEW BGPDX,B,CNT,BGPD,BGPG
- +2 ;if there is one before time frame set this to 1
- SET B=0
- SET CNT=0
- SET BGPD=""
- +3 SET NORXCHR=$GET(NORXCHR)
- +4 KILL BGPG
- +5 SET Y="BGPG("
- +6 SET X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(X,Y)
- +7 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
- +8 ;no diagnoses
- IF '$DATA(BGPG)
- GOTO PROB
- +9 SET B=0
- SET X=0
- FOR
- SET X=$ORDER(BGPG(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +10 ;get date
- +11 SET D=$PIECE(BGPG(X),U,1)
- +12 SET C=$$CLINIC^APCLV($PIECE(BGPG(X),U,5),"C")
- +13 IF NORXCHR
- IF C=39
- QUIT
- +14 SET C=$$PRIMPROV^APCLV($PIECE(BGPG(X),U,5),"D")
- +15 ;no chr as primary provider
- IF NORXCHR
- IF C=53
- QUIT
- +16 SET BGPDX(D)=""
- SET CNT=CNT+1
- IF CNT=2
- SET BGPD=D
- +17 IF D>$$FMADD^XLFDT(EDATE,-365)
- SET B=1
- +18 QUIT
- End DoDot:1
- +19 IF CNT>1
- IF B
- GOTO MA
- PROB ;
- +1 ;no pregnancy visit during time period ;-Lori fix in 09
- IF '$GET(B)
- QUIT ""
- +2 SET T=$ORDER(^ATXAX("B","BGP GPRA PREGNANCY DIAGNOSES",0))
- +3 SET (X,G)=0
- FOR
- SET X=$ORDER(^AUPNPROB("AC",P,X))
- IF X'=+X!(G)
- QUIT
- Begin DoDot:1
- +4 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
- QUIT
- +5 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
- QUIT
- +6 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
- QUIT
- +7 SET Y=$PIECE(^AUPNPROB(X,0),U)
- +8 IF '$$ICD^ATXCHK(Y,T,9)
- QUIT
- +9 SET G=$PIECE(^AUPNPROB(X,0),U,8)
- +10 QUIT
- End DoDot:1
- +11 ;no dxs and no problem list
- IF G=0
- IF BGPD=""
- QUIT 0
- +12 SET BGPD=G
- MA ;now check for abortion or miscarriage
- +1 ;abortion first
- +2 KILL BGPG
- SET Y="BGPG("
- SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(X,Y)
- +3 ;HAD MIS/AB
- IF $DATA(BGPG(1))
- QUIT 0
- +4 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
- +5 IF BGPG
- QUIT 0
- +6 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
- +7 SET (X,G)=0
- FOR
- SET X=$ORDER(^AUPNPROB("AC",P,X))
- IF X'=+X!(G)
- QUIT
- Begin DoDot:1
- +8 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
- QUIT
- +9 IF $PIECE(^AUPNPROB(X,0),U,8)<BGPD
- QUIT
- +10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
- QUIT
- +11 SET Y=$PIECE(^AUPNPROB(X,0),U)
- +12 IF '$$ICD^ATXCHK(Y,T,9)
- QUIT
- +13 SET G=1
- +14 QUIT
- End DoDot:1
- +15 IF G
- QUIT 0
- +16 ;now check CPTs for Abortion and Miscarriage
- +17 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
- +18 SET %=$$CPT^BGP0DU(P,BGPD,EDATE,T,3)
- +19 IF %]""
- QUIT 0
- +20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
- +21 SET %=$$CPT^BGP0DU(P,BGPD,EDATE,T,3)
- +22 IF %]""
- QUIT 0
- +23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
- +24 SET %=$$TRAN^BGP0DU(P,BGPD,EDATE,T,3)
- +25 IF %]""
- QUIT 0
- +26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
- +27 SET %=$$TRAN^BGP0DU(P,BGPD,EDATE,T,3)
- +28 IF %]""
- QUIT 0
- +29 QUIT 1
- DX(P,BDATE,EDATE) ;EP
- +1 KILL BGPG
- +2 SET BGPG(1)=$$LASTDX^BGP0UTL1(P,"BGP GPRA SMOKING DXS",BDATE,EDATE)
- +3 IF BGPG(1)]""
- QUIT $PIECE($$ICDDX^ICDCODE($PIECE(BGPG(1),U,4),$PIECE(BGPG(1),U,1)),U,2)_U_$PIECE(BGPG(1),U,3)
- +4 SET T=$ORDER(^ATXAX("B","BGP GPRA SMOKING DXS",0))
- +5 SET X=0
- SET G=""
- FOR
- SET X=$ORDER(^AUPNPROB("AC",P,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +6 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
- QUIT
- +7 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
- QUIT
- +8 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
- QUIT
- +9 SET Y=$PIECE(^AUPNPROB(X,0),U)
- +10 IF '$$ICD^ATXCHK(Y,T,9)
- QUIT
- +11 SET G=$PIECE($$ICDDX^ICDCODE(Y),U,2)_" PL"_U_$PIECE(^AUPNPROB(X,0),U,3)
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- TOBACCO(P,BDATE,EDATE) ;EP
- +1 KILL BGPTOB,BGP
- +2 DO TOBACCO1
- +3 IF BGPTOB]""
- QUIT BGPTOB
- +4 DO TOBACCO0
- +5 IF $DATA(BGPTOB)
- QUIT BGPTOB
- +6 QUIT ""
- TOBACCO1 ;check for tobacco documented in health factors
- +1 KILL BGPTOB
- SET BGPTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE)
- KILL O,D,H
- +2 QUIT
- TOBACCO0 ;lookup in health status
- +1 SET (X,Y)=0
- FOR
- SET X=$ORDER(^AUPNHF("AA",P,X))
- IF X'=+X!(Y)
- QUIT
- IF $$VAL^XBDIQ1(9999999.64,X,.03)="TOBACCO"
- SET Y=X
- +2 IF 'Y
- QUIT
- +3 SET E=$ORDER(^AUPNHF("AA",P,Y,0))
- IF 'E
- QUIT
- +4 ;documented after time frame
- IF (9999999-E)>EDATE
- QUIT
- +5 ;documented before year
- IF (9999999-E)<BDATE
- QUIT
- +6 SET Y=$PIECE(^AUTTHF(Y,0),U)
- +7 SET BGPTOB=Y_"^"_$$DATE^BGP0UTL(9999999-E)_"^"_(9999999-E)
- +8 KILL Y,E,X
- +9 QUIT
- +10 ;
- LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
- +1 ;ien of category passed
- 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^BGP0UTL(9999999-D)_"^"_(9999999-D)
- +14 ;
- 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 ""
- +7 ;
- CPTSM(P,BDATE,EDATE) ;EP - did pat have TOBACCO SCREENING cpt?
- +1 NEW X
- +2 SET X=$$CPT^BGP0DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP TOBACCO SCREEN CPTS",0)),5)
- +3 IF X]""
- QUIT $PIECE(X,U,2)_U_$PIECE(X,U,1)
- +4 ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1034F"))
- +5 ;I X Q "1034F"_U_$P(X,U,2)
+6 ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1035F"))
+7 ;I X Q "1035F"_U_$P(X,U,2)
+8 ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1036F"))
+9 ;I X Q "1036F"_U_$P(X,U,2)
+10 QUIT ""
