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

BGP0EL3.m

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

 Q ""