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 ""
BGP9EL3 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2008 1:44 PM ;
+1 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
+2 ;
I9 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 ;set to date of flu shot
SET BGPVALUE=$$FLU^BGP9D3(DFN,,BGPEDATE)
+11 IF BGPVALUE]""
SET BGPN1=1
+12 IF $PIECE(BGPVALUE,U,3)=2
SET BGPN2=1
+13 IF $PIECE(BGPVALUE,U,3)=3
SET BGPN3=1
+14 SET BGPVALUE="AC"_"|||"_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)
+15 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T
+16 KILL BGPX,BGPY,BGPC,BGPG
+17 QUIT
I10 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 DO PN^BGP9D3
+11 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+12 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
+13 KILL BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
+14 QUIT
I11 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET BGPSTOP=1
QUIT
+6 IF $$MAS^BGP9D4(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+7 SET BGPD1=1
+8 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+9 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+10 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+11 IF BGPAGEB>84
SET BGPD5=1
+12 SET BGPMAM=$$MAM^BGP9D4(DFN,BGPEDATE,2)
+13 SET BGPN1=0
IF $PIECE(BGPMAM,U)=1
SET BGPN1=1
+14 SET BGPN2=0
IF $PIECE(BGPMAM,U,3)["ref"
SET BGPN2=1
+15 SET BGPVALUE="AC"_"|||"_$$DATE^BGP9UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+16 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
+17 KILL BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPMAM
+18 QUIT
I12 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 ;has colorectal cancer
IF $$CRC^BGP9D61(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+6 SET BGPD1=1
+7 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+8 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+9 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+10 IF BGPAGEB>84
SET BGPD5=1
+11 DO CRCP^BGP9D61
+12 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+13 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
+14 KILL BGPX,BGPY,BGPC,BGPG
+15 QUIT
+16 ;
I13 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 DO TA^BGP9D7
+11 SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:";SCREENED",1:"")_$SELECT(BGPN2:";USER",1:"")_$SELECT(BGPN3:";SMOKER",1:"")_$SELECT(BGPN4:";SMOKELESS",1:"")
+12 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+13 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPND,BGP1320
+14 KILL BGPX,BGPY,BGPC,BGPG
+15 QUIT
I14 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+3 SET BGPDVREF=""
+4 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+5 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+6 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+7 SET BGPD1=1
+8 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+9 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+10 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+11 IF BGPAGEB>84
SET BGPD5=1
+12 DO DV^BGP9D5
+13 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+14 QUIT
+15 ;
I15 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 DO DEPEP^BGP9D25
+11 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+12 QUIT
I16 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB>74
SET BGPSTOP=1
QUIT
+5 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+6 SET BGPD1=1
+7 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+8 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+9 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+10 IF BGPAGEB>84
SET BGPD5=1
+11 SET BGPBMI=$$BMI^BGP9D6(DFN,BGPEDATE,BGPAGEE)
SET BGPN1=$SELECT(BGPBMI]"":1,1:0)
+12 SET BGPN2=$$OW^BGP9D6(DFN,BGPBMI,BGPAGEE)
+13 SET BGPN3=$$OB^BGP9D6(DFN,BGPBMI,BGPAGEE)
+14 IF BGPN2!(BGPN3)
SET BGPN4=1
+15 IF 'BGPN1
SET BGPREF=$$REF^BGP9D6(DFN,BGP365,BGPEDATE,BGPAGEB)
IF $PIECE(BGPREF,U)=1
SET BGPN5=1
+16 IF BGPN5
SET BGPN1=1
+17 SET BGPVALUE="AC"
+18 SET BGPVALUE=BGPVALUE_"|||"_$SELECT(BGPBMI]"":$$SB^BGP9PDL1($JUSTIFY($PIECE(BGPBMI,U),6,2)),1:"")_" "_$SELECT(BGPN2:"OW",1:"")_" "_$SELECT(BGPN3:"OB",1:"")
+19 IF BGPN5
SET BGPVALUE=BGPVALUE_"ref "_$PIECE(BGPREF,U,2)_" "_$$DATE^BGP9UTL($PIECE(BGPREF,U,3))_" "_$PIECE(BGPREF,U,5)_" "_$$DATE^BGP9UTL($PIECE(BGPREF,U,6))
+20 KILL X,Y,Z,%,A,B,C,D,E,F,G,H,BDATE,EDATE,P,V,S,F,T,BGPBMI
+21 KILL BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
+22 QUIT
I17 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 DO BPCV^BGP9D41
+11 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+12 KILL X,Y,Z
+13 QUIT
I19 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET BGPSTOP=1
QUIT
+6 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+7 SET BGPFRAC=$$FRACTURE(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))
+8 IF '$PIECE(BGPFRAC,U)
SET BGPSTOP=1
QUIT
+9 SET BGPD1=1
+10 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+11 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+12 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+13 IF BGPAGEB>84
SET BGPD5=1
+14 SET BGPISD=$PIECE(BGPFRAC,U,2)
SET BGPISV=$PIECE(BGPFRAC,U,3)
SET BGPISV=$PIECE(BGPFRAC,U,4)
+15 SET BGPBMD=""
+16 IF $PIECE(BGPFRAC,U,3)="H"
SET BGPBMD=$$TXBMD^BGP9EL4(DFN,$PIECE($PIECE(^AUPNVSIT(BGPISV,0),U),"."),$$DSCHDATE^APCLV(BGPISV,"I"),1)
+17 IF $PIECE(BGPFRAC,U,3)'="H"
SET BGPBMD=$$TXBMD^BGP9EL4(DFN,BGPISD,$$FMADD^XLFDT(BGPISD,180))
+18 IF $PIECE(BGPBMD,U)
SET BGPN1=1
+19 SET BGPVALUE="AC "
+20 SET Y=""
+21 FOR X=5,6,7
SET V=$PIECE(BGPFRAC,U,X)
IF V]""
IF Y]""
SET Y=Y_";"
SET Y=Y_V
+22 SET BGPVALUE=BGPVALUE_"Fracture: "_Y_" on "_$$DATE^BGP9UTL($PIECE(BGPFRAC,U,2))_"|||"_$PIECE(BGPBMD,U,2)
+23 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,FBD,FED
+24 QUIT
IELDFSA ;EP
+1 DO IELDFSA^BGP9EL31
+2 QUIT
IELDASA ;EP
+1 DO IELDASA^BGP9EL31
+2 QUIT
IELDPHA ;EP - PHN
+1 DO IELDPHA^BGP9EL31
+2 QUIT
IRAO ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 IF BGPAGEB<55
SET BGPSTOP=""
QUIT
+3 IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET BGPSTOP=""
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=""
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 SET T=$ORDER(^ATXAX("B","BGP OSTEOPOROSIS DXS",0))
+11 IF 'T
WRITE BGPBOMB
QUIT
+12 ;had osteoporosis dx
IF $$LASTDX^BGP9UTL1(DFN,"BGP OSTEOPOROSIS DXS",$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
SET BGPSTOP=1
QUIT
+13 SET BGPPAP=$$OSTEOSCR^BGP9D42(DFN,$$FMADD^XLFDT(BGPBDATE,-(365*2)),BGPEDATE)
+14 IF BGPPAP
SET BGPN1=1
+15 IF $PIECE(BGPPAP,U)=3
SET BGPN2=1
+16 SET BGPVALUE="AC"
+17 SET BGPVALUE=BGPVALUE_"|||"_$PIECE(BGPPAP,U,2)_" "_$$DATE^BGP9UTL($PIECE(BGPPAP,U,3))_$SELECT($PIECE(BGPPAP,U,1)=3:" (refused)",1:"")
+18 KILL BGPPAP,X
+19 QUIT
+20 ;
IRAA ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
+2 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 DO IRAA^BGP9D82
+5 QUIT
FRACTURE(P,BDATE,EDATE) ;EP
+1 SET (X,I,Y,T)=0
+2 KILL BGPG,BGPV
SET BGPGO=""
+3 SET Y="BGPG("
+4 SET X=P_"^FIRST DX [BGP FRACTURE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(BGPG(1))
Begin DoDot:1
+6 SET BGPV($PIECE(BGPG(1),U),$PIECE(BGPG(1),U,5))="DX: "_$PIECE(BGPG(1),U,2)
+7 SET BGPGO=1
End DoDot:1
+8 KILL BGPG
+9 SET T=$ORDER(^ATXAX("B","BGP FRACTURE CPTS",0))
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 SET I=$PIECE($GET(^AUPNVCPT(X,0)),U)
IF I=""
QUIT
+12 SET C=$PIECE($$CPT^ICPTCOD(I),U,2)
IF C=""
QUIT
+13 IF '$$ICD^ATXCHK(I,T,1)
QUIT
+14 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
+15 IF V=""
QUIT
+16 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+17 IF D<BDATE
QUIT
+18 IF D>EDATE
QUIT
+19 IF '$DATA(BGPV(D,V))
SET BGPV(D,V)=""
+20 SET $PIECE(BGPV(D,V),U,2)="CPT: "_C
End DoDot:1
+21 ;
+22 ;TRAN
+23 SET T=$ORDER(^ATXAX("B","BGP FRACTURE CPTS",0))
+24 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+25 SET I=$PIECE($GET(^AUPNVTC(X,0)),U,7)
IF I=""
QUIT
+26 SET C=$PIECE($$CPT^ICPTCOD(I),U,2)
IF C=""
QUIT
+27 IF '$$ICD^ATXCHK(I,T,1)
QUIT
+28 SET V=$PIECE(^AUPNVTC(X,0),U,3)
+29 IF V=""
QUIT
+30 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+31 IF D<BDATE
QUIT
+32 IF D>EDATE
QUIT
+33 IF '$DATA(BGPV(D,V))
SET BGPV(D,V)=""
+34 SET $PIECE(BGPV(D,V),U,2)="TRAN: "_C
End DoDot:1
+35 KILL BGPG
SET Y="BGPG("
+36 SET BGPG=$$FIRSTPRC^BGP9UTL1(P,"BGP FRACTURE PROCEDURES",BDATE,EDATE)
+37 IF $PIECE(BGPG,U)=1
Begin DoDot:1
+38 SET D=$PIECE(BGPG,U,3)
+39 SET V=$PIECE(BGPG,U,5)
SET V=$PIECE($GET(^AUPNVPRC(V,0)),U,3)
+40 IF 'V
QUIT
+41 IF '$DATA(BGPV(D,V))
SET BGPV(D,V)=""
+42 SET $PIECE(BGPV(D,V),U,3)="PROC: "_$PIECE(BGPG,U,2)
End DoDot:1
+43 SET BGPISD=$ORDER(BGPV(0))
+44 IF BGPISD=""
QUIT ""
+45 SET BGPISV=$ORDER(BGPV(BGPISD,0))
+46 SET BGPIST=$PIECE(^AUPNVSIT(BGPISV,0),U,7)
IF BGPIST="H"
SET X=$$DSCHDATE^APCLV(BGPISV,"I")
Begin DoDot:1
+47 IF X=""
QUIT
+48 IF X=BGPISD
QUIT
+49 SET BGPV(X,BGPISV)=BGPV(BGPISD,BGPISV)
+50 KILL BGPV(BGPISD,BGPISV)
+51 SET BGPISD=X
End DoDot:1
+52 IF BGPISD=""
QUIT ""
+53 ;n
+54 ;
+55 SET BGPX=$$TXBMD^BGP9EL4(P,$$FMADD^XLFDT(BGPISD,-365),$$FMADD^XLFDT(BGPISD,-1))
IF $PIECE(BGPX,U)
SET $PIECE(BGPV(BGPISD,BGPISV),U,5)=$PIECE(BGPX,U,2)
QUIT ""
+56 ;if outpatient exclude if any fracture in 60 days prior to index start date
+57 IF BGPIST'="H"
IF $$FRACT(P,$$FMADD^XLFDT(BGPISD,-60),$$FMADD^XLFDT(BGPISD,-1))
SET $PIECE(BGPV(BGPISD,BGPISV),U,5)="excl: prior fx"
QUIT ""
+58 IF BGPIST="H"
SET D=$PIECE($PIECE(^AUPNVSIT(BGPISV,0),U),".")
IF $$FRACT(P,$$FMADD^XLFDT(D,-60),$$FMADD^XLFDT(D,-1))
SET $PIECE(BGPV(BGPISD,BGPISV),U,5)="excl: prior fx"
QUIT ""
+59 QUIT 1_U_BGPISD_U_BGPISV_U_BGPIST_U_BGPV(BGPISD,BGPISV)
+60 ;
FRACT(P,FBD,FED) ;
+1 SET (X,I,Y,T)=0
+2 KILL BGPG
SET BGPGO=""
+3 SET Y="BGPG("
+4 SET X=P_"^FIRST DX [BGP FRACTURE DXS;DURING "_$$FMTE^XLFDT(FBD)_"-"_$$FMTE^XLFDT(FED)
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(BGPG(1))
QUIT 1
+6 KILL BGPG
+7 SET BGPG=0
+8 SET T=$ORDER(^ATXAX("B","BGP FRACTURE CPTS",0))
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X!(BGPG)
QUIT
Begin DoDot:1
+10 SET I=$PIECE($GET(^AUPNVCPT(X,0)),U)
IF I=""
QUIT
+11 SET C=$PIECE($$CPT^ICPTCOD(I),U,2)
IF C=""
QUIT
+12 IF '$$ICD^ATXCHK(I,T,1)
QUIT
+13 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
+14 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+15 IF D<FBD
QUIT
+16 IF D>FED
QUIT
+17 SET BGPG=1
End DoDot:1
+18 IF BGPG
QUIT 1
+19 ;
+20 SET T=$ORDER(^ATXAX("B","BGP FRACTURE CPTS",0))
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X!(BGPG)
QUIT
Begin DoDot:1
+22 SET I=$PIECE($GET(^AUPNVTC(X,0)),U,7)
IF I=""
QUIT
+23 SET C=$PIECE($$CPT^ICPTCOD(I),U,2)
IF C=""
QUIT
+24 IF '$$ICD^ATXCHK(I,T,1)
QUIT
+25 SET V=$PIECE(^AUPNVTC(X,0),U,3)
+26 IF V=""
QUIT
+27 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+28 IF D<FBD
QUIT
+29 IF D>FED
QUIT
+30 SET BGPG=1
End DoDot:1
+31 IF BGPG
QUIT 1
+32 ;
+33 SET BGPG=$$FIRSTPRC^BGP9UTL1(P,"BGP FRACTURE PROCEDURES",FBD,FED)
+34 IF $PIECE(BGPG,U)=1
QUIT 1
+35 QUIT ""
