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

BGP9EL3.m

Go to the documentation of this file.
BGP9EL3 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2008 1:44 PM ;
 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
 ;
I9 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 S BGPVALUE=$$FLU^BGP9D3(DFN,,BGPEDATE) ;set to date of flu shot
 I BGPVALUE]"" S BGPN1=1
 I $P(BGPVALUE,U,3)=2 S BGPN2=1
 I $P(BGPVALUE,U,3)=3 S BGPN3=1
 S BGPVALUE="AC"_"|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T
 K BGPX,BGPY,BGPC,BGPG
 Q
I10 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D PN^BGP9D3
 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
 K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
 Q
I11 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q
 I $$MAS^BGP9D4(DFN,BGPEDATE) S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 S BGPMAM=$$MAM^BGP9D4(DFN,BGPEDATE,2)
 S BGPN1=0 I $P(BGPMAM,U)=1 S BGPN1=1
 S BGPN2=0 I $P(BGPMAM,U,3)["ref" S BGPN2=1
 S BGPVALUE="AC"_"|||"_$$DATE^BGP9UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3)
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
 K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPMAM
 Q
I12 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 I $$CRC^BGP9D61(DFN,BGPEDATE) S BGPSTOP=1 Q  ;has colorectal cancer
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D CRCP^BGP9D61
 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
 K BGPX,BGPY,BGPC,BGPG
 Q
 ;
I13 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D TA^BGP9D7
 S BGPVALUE=BGPVALUE_$S(BGPN1:";SCREENED",1:"")_$S(BGPN2:";USER",1:"")_$S(BGPN3:";SMOKER",1:"")_$S(BGPN4:";SMOKELESS",1:"")
 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPND,BGP1320
 K BGPX,BGPY,BGPC,BGPG
 Q
I14 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 S BGPDVREF=""
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 I BGPSEX'="F" S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D DV^BGP9D5
 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
 Q
 ;
I15 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D DEPEP^BGP9D25
 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
 Q
I16 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I BGPAGEB>74 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 S BGPBMI=$$BMI^BGP9D6(DFN,BGPEDATE,BGPAGEE),BGPN1=$S(BGPBMI]"":1,1:0)
 S BGPN2=$$OW^BGP9D6(DFN,BGPBMI,BGPAGEE)
 S BGPN3=$$OB^BGP9D6(DFN,BGPBMI,BGPAGEE)
 I BGPN2!(BGPN3) S BGPN4=1
 I 'BGPN1 S BGPREF=$$REF^BGP9D6(DFN,BGP365,BGPEDATE,BGPAGEB) I $P(BGPREF,U)=1 S BGPN5=1
 I BGPN5 S BGPN1=1
 S BGPVALUE="AC"
 S BGPVALUE=BGPVALUE_"|||"_$S(BGPBMI]"":$$SB^BGP9PDL1($J($P(BGPBMI,U),6,2)),1:"")_" "_$S(BGPN2:"OW",1:"")_" "_$S(BGPN3:"OB",1:"")
 I BGPN5 S BGPVALUE=BGPVALUE_"ref "_$P(BGPREF,U,2)_" "_$$DATE^BGP9UTL($P(BGPREF,U,3))_" "_$P(BGPREF,U,5)_" "_$$DATE^BGP9UTL($P(BGPREF,U,6))
 K X,Y,Z,%,A,B,C,D,E,F,G,H,BDATE,EDATE,P,V,S,F,T,BGPBMI
 K BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
 Q
I17 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D BPCV^BGP9D41
 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
 K X,Y,Z
 Q
I19 ;EP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q
 I 'BGPACTCL S BGPSTOP=1 Q
 S BGPFRAC=$$FRACTURE(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))
 I '$P(BGPFRAC,U) S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 S BGPISD=$P(BGPFRAC,U,2),BGPISV=$P(BGPFRAC,U,3),BGPISV=$P(BGPFRAC,U,4)
 S BGPBMD=""
 I $P(BGPFRAC,U,3)="H" S BGPBMD=$$TXBMD^BGP9EL4(DFN,$P($P(^AUPNVSIT(BGPISV,0),U),"."),$$DSCHDATE^APCLV(BGPISV,"I"),1)
 I $P(BGPFRAC,U,3)'="H" S BGPBMD=$$TXBMD^BGP9EL4(DFN,BGPISD,$$FMADD^XLFDT(BGPISD,180))
 I $P(BGPBMD,U) S BGPN1=1
 S BGPVALUE="AC "
 S Y=""
 F X=5,6,7 S V=$P(BGPFRAC,U,X) I V]"" S:Y]"" Y=Y_";" S Y=Y_V
 S BGPVALUE=BGPVALUE_"Fracture: "_Y_" on "_$$DATE^BGP9UTL($P(BGPFRAC,U,2))_"|||"_$P(BGPBMD,U,2)
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,FBD,FED
 Q
IELDFSA ;EP
 D IELDFSA^BGP9EL31
 Q
IELDASA ;EP
 D IELDASA^BGP9EL31
 Q
IELDPHA ;EP - PHN
 D IELDPHA^BGP9EL31
 Q
IRAO ;EP
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP="" Q
 I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP="" Q
 I 'BGPACTCL S BGPSTOP="" Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 S T=$O(^ATXAX("B","BGP OSTEOPOROSIS DXS",0))
 I 'T W BGPBOMB Q
 I $$LASTDX^BGP9UTL1(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSTOP=1 Q  ;had osteoporosis dx
 S BGPPAP=$$OSTEOSCR^BGP9D42(DFN,$$FMADD^XLFDT(BGPBDATE,-(365*2)),BGPEDATE)
 I BGPPAP S BGPN1=1
 I $P(BGPPAP,U)=3 S BGPN2=1
 S BGPVALUE="AC"
 S BGPVALUE=BGPVALUE_"|||"_$P(BGPPAP,U,2)_" "_$$DATE^BGP9UTL($P(BGPPAP,U,3))_$S($P(BGPPAP,U,1)=3:" (refused)",1:"")
 K BGPPAP,X
 Q
 ;
IRAA ;EP
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
 I 'BGPACTCL S BGPSTOP=1 Q
 I BGPAGEB<55 S BGPSTOP=1 Q
 D IRAA^BGP9D82
 Q
FRACTURE(P,BDATE,EDATE) ;EP
 S (X,I,Y,T)=0
 K BGPG,BGPV S BGPGO=""
 S Y="BGPG("
 S X=P_"^FIRST DX [BGP FRACTURE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
 I $D(BGPG(1)) D
 .S BGPV($P(BGPG(1),U),$P(BGPG(1),U,5))="DX: "_$P(BGPG(1),U,2)
 .S BGPGO=1
 K BGPG
 S T=$O(^ATXAX("B","BGP FRACTURE CPTS",0))
 S X=0 F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X  D
 .S I=$P($G(^AUPNVCPT(X,0)),U) Q:I=""
 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""
 .Q:'$$ICD^ATXCHK(I,T,1)
 .S V=$P(^AUPNVCPT(X,0),U,3)
 .Q:V=""
 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
 .Q:D<BDATE
 .Q:D>EDATE
 .I '$D(BGPV(D,V)) S BGPV(D,V)=""
 .S $P(BGPV(D,V),U,2)="CPT: "_C
 ;
 ;TRAN
 S T=$O(^ATXAX("B","BGP FRACTURE CPTS",0))
 S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D
 .S I=$P($G(^AUPNVTC(X,0)),U,7) Q:I=""
 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""
 .Q:'$$ICD^ATXCHK(I,T,1)
 .S V=$P(^AUPNVTC(X,0),U,3)
 .Q:V=""
 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
 .Q:D<BDATE
 .Q:D>EDATE
 .I '$D(BGPV(D,V)) S BGPV(D,V)=""
 .S $P(BGPV(D,V),U,2)="TRAN: "_C
 K BGPG S Y="BGPG("
 S BGPG=$$FIRSTPRC^BGP9UTL1(P,"BGP FRACTURE PROCEDURES",BDATE,EDATE)
 I $P(BGPG,U)=1 D
 .S D=$P(BGPG,U,3)
 .S V=$P(BGPG,U,5),V=$P($G(^AUPNVPRC(V,0)),U,3)
 .Q:'V
 .I '$D(BGPV(D,V)) S BGPV(D,V)=""
 .S $P(BGPV(D,V),U,3)="PROC: "_$P(BGPG,U,2)
 S BGPISD=$O(BGPV(0))
 I BGPISD="" Q ""
 S BGPISV=$O(BGPV(BGPISD,0))
 S BGPIST=$P(^AUPNVSIT(BGPISV,0),U,7) I BGPIST="H" S X=$$DSCHDATE^APCLV(BGPISV,"I") D
 .Q:X=""
 .Q:X=BGPISD
 .S BGPV(X,BGPISV)=BGPV(BGPISD,BGPISV)
 .K BGPV(BGPISD,BGPISV)
 .S BGPISD=X
 I BGPISD="" Q ""
 ;n
 ;
 S BGPX=$$TXBMD^BGP9EL4(P,$$FMADD^XLFDT(BGPISD,-365),$$FMADD^XLFDT(BGPISD,-1)) I $P(BGPX,U) S $P(BGPV(BGPISD,BGPISV),U,5)=$P(BGPX,U,2) Q ""
 ;if outpatient exclude if any fracture in 60 days prior to index start date
 I BGPIST'="H",$$FRACT(P,$$FMADD^XLFDT(BGPISD,-60),$$FMADD^XLFDT(BGPISD,-1)) S $P(BGPV(BGPISD,BGPISV),U,5)="excl: prior fx" Q ""
 I BGPIST="H" S D=$P($P(^AUPNVSIT(BGPISV,0),U),".") I $$FRACT(P,$$FMADD^XLFDT(D,-60),$$FMADD^XLFDT(D,-1)) S $P(BGPV(BGPISD,BGPISV),U,5)="excl: prior fx" Q ""
 Q 1_U_BGPISD_U_BGPISV_U_BGPIST_U_BGPV(BGPISD,BGPISV)
 ;
FRACT(P,FBD,FED) ;
 S (X,I,Y,T)=0
 K BGPG S BGPGO=""
 S Y="BGPG("
 S X=P_"^FIRST DX [BGP FRACTURE DXS;DURING "_$$FMTE^XLFDT(FBD)_"-"_$$FMTE^XLFDT(FED) S E=$$START1^APCLDF(X,Y)
 I $D(BGPG(1)) Q 1
 K BGPG
 S BGPG=0
 S T=$O(^ATXAX("B","BGP FRACTURE CPTS",0))
 S X=0 F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X!(BGPG)  D
 .S I=$P($G(^AUPNVCPT(X,0)),U) Q:I=""
 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""
 .Q:'$$ICD^ATXCHK(I,T,1)
 .S V=$P(^AUPNVCPT(X,0),U,3)
 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
 .Q:D<FBD
 .Q:D>FED
 .S BGPG=1
 I BGPG Q 1
 ;
 S T=$O(^ATXAX("B","BGP FRACTURE CPTS",0))
 S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X!(BGPG)  D
 .S I=$P($G(^AUPNVTC(X,0)),U,7) Q:I=""
 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""
 .Q:'$$ICD^ATXCHK(I,T,1)
 .S V=$P(^AUPNVTC(X,0),U,3)
 .Q:V=""
 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
 .Q:D<FBD
 .Q:D>FED
 .S BGPG=1
 I BGPG Q 1
 ;
 S BGPG=$$FIRSTPRC^BGP9UTL1(P,"BGP FRACTURE PROCEDURES",FBD,FED)
 I $P(BGPG,U)=1 Q 1
 Q ""