BGP2EL3 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
I9 ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=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^BGP2D3(DFN,,BGPEDATE) ;set to date of flu shot
I BGPVALUE]"" S BGPN1=1 ;FLU SHOT
I $P(BGPVALUE,U,3)=2 S BGPN2=1 ;REFUSAL
I $P(BGPVALUE,U,3)=3 S BGPN3=1,BGPN1=1 ;CONTRAINDICATION
I BGPN1,'BGPN2 S BGPN7=1
S BGPVALUE="AC"_"|||"_$$DATE^BGP2UTL($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,BGPN6,BGPN7,BGPN8)=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^BGP2D3
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,BGPN6,BGPN7,BGPN8,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 $$MAS^BGP2D4(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^BGP2D4(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
I BGPN1,'BGPN2 S BGPN3=1
S BGPVALUE="AC"_"|||"_$$DATE^BGP2UTL($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,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=0
I BGPAGEB<55 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q
I $$CRC^BGP2D61(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^BGP2D61
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,BGPN6,BGPN7,BGPN8,BGPN6)=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^BGP2D7
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,BGPXPWD,BGP1320
K BGPX,BGPY,BGPC,BGPG
Q
I14 ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=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^BGP2D5
S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
Q
;
I15 ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11)=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^BGP2D25
S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
Q
I16 ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8)=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^BGP2D6(DFN,BGPEDATE,BGPAGEE),BGPN1=$S(BGPBMI]"":1,1:0)
S BGPN2=$$OW^BGP2D6(DFN,BGPBMI,BGPAGEE)
S BGPN3=$$OB^BGP2D6(DFN,BGPBMI,BGPAGEE)
I BGPN2!(BGPN3) S BGPN4=1
I 'BGPN1 S BGPREF=$$REF^BGP2D6(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^BGP2PDL1($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^BGP2UTL($P(BGPREF,U,3))_" "_$P(BGPREF,U,5)_" "_$$DATE^BGP2UTL($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,BGPN8,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^BGP2D41
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,BGPN8,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,-182),$$FMADD^XLFDT(BGPBDATE,182))
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^BGP2EL4(DFN,$P($P(^AUPNVSIT(BGPISV,0),U),"."),$$DSCHDATE^APCLV(BGPISV,"I"),1)
I $P(BGPFRAC,U,3)'="H" S BGPBMD=$$TXBMD^BGP2EL4(DFN,BGPISD,$$FMADD^XLFDT(BGPISD,182))
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^BGP2UTL($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^BGP2EL31
Q
IELDASA ;EP
D IELDASA^BGP2EL31
Q
IELDPHA ;EP - PHN
D IELDPHA^BGP2EL31
Q
IRAO ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,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^BGP2UTL1(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSTOP=1 Q ;had osteoporosis dx
S BGPPAP=$$OSTEOSCR^BGP2D42(DFN,$$FMADD^XLFDT(BGPBDATE,-(365*2)),BGPEDATE)
I BGPPAP S BGPN1=1
I 'BGPN1 S BGPPAP=$$OSTEOREF^BGP2D42(DFN,BGPBDATE,BGPEDATE) I BGPPAP S BGPN2=1 ;Refusal
S BGPVALUE="AC"
S BGPVALUE=BGPVALUE_"|||"_$$DATE^BGP2UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3) ;$P(BGPPAP,U,2)_" "_$$DATE^BGP2UTL($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,BGPN7,BGPN8,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^BGP2D82
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^BGP2UTL1(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^BGP2EL4(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^BGP2UTL1(P,"BGP FRACTURE PROCEDURES",FBD,FED)
I $P(BGPG,U)=1 Q 1
Q ""
BGP2EL3 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
I9 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=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^BGP2D3(DFN,,BGPEDATE)
+11 ;FLU SHOT
IF BGPVALUE]""
SET BGPN1=1
+12 ;REFUSAL
IF $PIECE(BGPVALUE,U,3)=2
SET BGPN2=1
+13 ;CONTRAINDICATION
IF $PIECE(BGPVALUE,U,3)=3
SET BGPN3=1
SET BGPN1=1
+14 IF BGPN1
IF 'BGPN2
SET BGPN7=1
+15 SET BGPVALUE="AC"_"|||"_$$DATE^BGP2UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)
+16 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T
+17 KILL BGPX,BGPY,BGPC,BGPG
+18 QUIT
I10 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8)=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^BGP2D3
+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,BGPN6,BGPN7,BGPN8,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 $$MAS^BGP2D4(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^BGP2D4(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 IF BGPN1
IF 'BGPN2
SET BGPN3=1
+16 SET BGPVALUE="AC"_"|||"_$$DATE^BGP2UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)
+17 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
+18 KILL BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPMAM
+19 QUIT
I12 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 ;has colorectal cancer
IF $$CRC^BGP2D61(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^BGP2D61
+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,BGPN6,BGPN7,BGPN8,BGPN6)=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^BGP2D7
+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,BGPXPWD,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,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=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^BGP2D5
+13 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+14 QUIT
+15 ;
I15 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11)=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^BGP2D25
+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,BGPN6,BGPN7,BGPN8)=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^BGP2D6(DFN,BGPEDATE,BGPAGEE)
SET BGPN1=$SELECT(BGPBMI]"":1,1:0)
+12 SET BGPN2=$$OW^BGP2D6(DFN,BGPBMI,BGPAGEE)
+13 SET BGPN3=$$OB^BGP2D6(DFN,BGPBMI,BGPAGEE)
+14 IF BGPN2!(BGPN3)
SET BGPN4=1
+15 IF 'BGPN1
SET BGPREF=$$REF^BGP2D6(DFN,BGP365,BGPEDATE,BGPAGEB)
IF $PIECE(BGPREF,U)=1
SET BGPN5=1
+16 ;I BGPN5 S BGPN1=1
+17 SET BGPVALUE="AC"
+18 SET BGPVALUE=BGPVALUE_"|||"_$SELECT(BGPBMI]"":$$SB^BGP2PDL1($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^BGP2UTL($PIECE(BGPREF,U,3))_" "_$PIECE(BGPREF,U,5)_" "_$$DATE^BGP2UTL($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,BGPN8,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^BGP2D41
+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,BGPN8,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,-182),$$FMADD^XLFDT(BGPBDATE,182))
+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^BGP2EL4(DFN,$PIECE($PIECE(^AUPNVSIT(BGPISV,0),U),"."),$$DSCHDATE^APCLV(BGPISV,"I"),1)
+17 IF $PIECE(BGPFRAC,U,3)'="H"
SET BGPBMD=$$TXBMD^BGP2EL4(DFN,BGPISD,$$FMADD^XLFDT(BGPISD,182))
+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^BGP2UTL($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^BGP2EL31
+2 QUIT
IELDASA ;EP
+1 DO IELDASA^BGP2EL31
+2 QUIT
IELDPHA ;EP - PHN
+1 DO IELDPHA^BGP2EL31
+2 QUIT
IRAO ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,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^BGP2UTL1(DFN,"BGP OSTEOPOROSIS DXS",$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
SET BGPSTOP=1
QUIT
+13 SET BGPPAP=$$OSTEOSCR^BGP2D42(DFN,$$FMADD^XLFDT(BGPBDATE,-(365*2)),BGPEDATE)
+14 IF BGPPAP
SET BGPN1=1
+15 ;Refusal
IF 'BGPN1
SET BGPPAP=$$OSTEOREF^BGP2D42(DFN,BGPBDATE,BGPEDATE)
IF BGPPAP
SET BGPN2=1
+16 SET BGPVALUE="AC"
+17 ;$P(BGPPAP,U,2)_" "_$$DATE^BGP2UTL($P(BGPPAP,U,3))_$S($P(BGPPAP,U,1)=3:" (Refused)",1:"")
SET BGPVALUE=BGPVALUE_"|||"_$$DATE^BGP2UTL($PIECE(BGPPAP,U,2))_" "_$PIECE(BGPPAP,U,3)
+18 KILL BGPPAP,X
+19 QUIT
+20 ;
IRAA ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,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^BGP2D82
+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^BGP2UTL1(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^BGP2EL4(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^BGP2UTL1(P,"BGP FRACTURE PROCEDURES",FBD,FED)
+34 IF $PIECE(BGPG,U)=1
QUIT 1
+35 QUIT ""
