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

BGP2D3.m

Go to the documentation of this file. 
  1. BGP2D3 ; IHS/CMI/LAB - measure 11 17 Oct 2009 12:40 PM ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1.  ;
  1.  ;
  1. I10 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
  1.  S (BGPSEAL,BGPSEALD)=""
  1.  K BGPSEALS,BGPSELDS
  1.  D SEAL^BGP2D3A(DFN,BGPBDATE,BGPEDATE)
  1.  I $P(BGPSEAL,U,2)]"" S BGPN5=$P(BGPSEAL,U,1) G I101
  1.  S BGPN1=$P(BGPSEAL,U)
  1.  I BGPAGEB<12 S BGPN2=BGPN1
  1.  I BGPAGEB>11,BGPAGEB<19 S BGPN3=BGPN1
  1.  I BGPAGEB>18 S BGPN4=BGPN1
  1. I101 ;
  1.  ;get new sealant definition 2012 gpra dev
  1.  I BGPAGEB>5,BGPAGEB<16 S BGPD7=1 S BGPSEALD=$$SEALDEV^BGP2D3A(DFN,BGPBDATE,BGPEDATE) I BGPSEALD S BGPN7=1
  1.  S BGPVALUE="UP|||"_+BGPN1_" sealants"
  1.  I 'BGPN1,BGPN5 S BGPVALUE=BGPVALUE_": "_$$DATE^BGP2UTL($P(BGPSEAL,U,2))_" "_$P(BGPSEAL,U,3)
  1.  I BGPN1 S BGPVALUE=BGPVALUE_": " S X=0 F  S X=$O(BGPSEALS(X)) Q:X'=+X  S D=0 F  S D=$O(BGPSEALS(X,D)) Q:D'=+D  S BGPVALUE=BGPVALUE_$S(X=1:"",1:"; ")_$$DATE^BGP2UTL(D)_" "_BGPSEALS(X,D)
  1.  I BGPD7 S BGPVALUD=$S(BGPD7:"UP",1:"")_"|||" I BGPN7 S BGPVALUD=BGPVALUD_$P(BGPSEALD,U,2)
  1.  K BGPSEAL,BGPSEALD
  1.  Q
  1. I11 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2)=0
  1.  I '$G(BGPACTUP) S BGPSTOP=1 Q
  1.  I BGPACTUP S BGPD1=1
  1.  I BGPAGEB>1,BGPAGEB<16 S BGPD2=1
  1.  S BGPFLUOR=$$TF^BGP2D3A(DFN,BGPBDATE,BGPEDATE)
  1.  I $P(BGPFLUOR,U,3)["Refused" S BGPN2=1 G I111
  1.  S BGPN1=$P(BGPFLUOR,U)
  1.  I BGPN1>4 S BGPN1=4
  1.  I BGPAGEB>1,BGPAGEB<16 S BGPD2=1,BGPN3=$S(BGPN1:1,1:0)
  1.  ;I BGPD1,'BGPD2 S BGPD3=1
  1. I111 ;
  1.  S BGPVALUE="UP|||"_+BGPN1_" topical fluoride"
  1.  I +BGPN1 S BGPVALUE=BGPVALUE_": " F X=2:1:5 I $P(BGPFLUOR,U,X)]"" S BGPVALUE=BGPVALUE_$S(X>2:", ",1:"")_$$DATE^BGP2UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)
  1.  I BGPN2 S BGPVALUE=BGPVALUE_": "_$$DATE^BGP2UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)
  1.  S BGPVALUD="UP|||"
  1.  I +BGPN1 S BGPVALUD=BGPVALUD_+BGPN1_" topical fluoride" I +BGPN1 S BGPVALUD=BGPVALUD_": " F X=2:1:5 I $P(BGPFLUOR,U,X)]"" S BGPVALUD=BGPVALUD_$S(X>2:", ",1:"")_$$DATE^BGP2UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)
  1.  I BGPN2 S BGPVALUD=BGPVALUD_": "_$$DATE^BGP2UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)
  1.  K ^TMP($J,"A"),BGPFLUOR
  1.  Q
  1. I12 ;EP
  1.  NEW BGPHR,V
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPHR)=0
  1.  S BGPHR=$$HIGHR^BGP2D3A(DFN,BGPEDATE)
  1.  I BGPAGEB>49,BGPACTUP S BGPD5=1
  1.  I BGPAGEB>49,BGPAGEB<65,BGPACTUP S BGPD6=1
  1.  I BGPAGEB>64,BGPACTUP S BGPD7=1
  1.  I BGPDMD2 S BGPD4=1
  1.  I BGPAGEB>49,BGPACTCL S BGPD1=1
  1.  I BGPAGEB>49,BGPAGEB<65,BGPACTCL S BGPD2=1
  1.  I BGPAGEB>64,BGPACTCL S BGPD3=1
  1.  I BGPACTCL S BGPD8=1
  1.  I BGPAGEB<18,BGPACTCL S BGPD9=1
  1.  I BGPAGEB>17,BGPAGEB<50,BGPACTCL S BGPD10=1
  1.  I BGPAGEB>17,BGPAGEB<50,BGPACTCL,BGPHR S BGPD11=1
  1.  I BGPACTUP S BGPD12=1
  1.  I BGPAGEB<18,BGPACTUP S BGPD13=1
  1.  I BGPAGEB>17,BGPAGEB<50,BGPACTUP S BGPD14=1
  1.  I BGPAGEB>17,BGPAGEB<50,BGPACTUP,BGPHR S BGPD15=1
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14+BGPD15) S BGPSTOP=1 Q
  1.  S BGPVALUE=$$FLU(DFN,,BGPEDATE) ;set to date of flu shot
  1.  I $P(BGPVALUE,U,3)=1 S BGPN1=1
  1.  I $P(BGPVALUE,U,3)=2 S BGPN2=1
  1.  I $P(BGPVALUE,U,3)=3 S BGPN3=1,BGPN1=1
  1.  I BGPN1,'BGPN2 S BGPN7=1
  1.  S BGPDV=""
  1.  I BGPRTYPE=4 S BGPDV=$S(BGPACTUP:"UP",1:"") D
  1.  .I BGPACTCL S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
  1.  .I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1.  .I BGPHR S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")
  1.  I BGPRTYPE=1 S BGPDV=$S(BGPD3!(BGPD2):"AC",1:"") I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1.  I BGPRTYPE=3!(BGPRTYPE=8) S BGPDV="AC"
  1.  I BGPRTYPE=7 D
  1.  .I BGPACTCL S BGPDV="AC"
  1.  .I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1.  .I BGPHR S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")
  1.  I BGPRTYPE'=1 S BGPVALUE=BGPDV_"|||"_$$DATE^BGP2UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)
  1.  I BGPRTYPE=1 D
  1.  .S BGPDV=BGPDV_"|||"
  1.  .I BGPN7 S BGPVALUE=BGPDV_$$DATE^BGP2UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) Q
  1.  .S BGPVALUE=BGPDV
  1.  K BGPLFLU,BGPDV,BGPHR
  1.  Q
  1. I13 ;EP
  1.  NEW BGPTDAP,BGPTD
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  I BGPAGEB>64,BGPACTUP S BGPD3=1
  1.  I BGPDMD2 S BGPD2=1
  1.  I BGPAGEB>64,BGPACTCL S BGPD1=1
  1.  I BGPAGEB>17,BGPAGEB<65,BGPACTCL,$$HIGHRP^BGP2D3A(DFN,BGPEDATE) S BGPD4=1
  1.  I BGPAGEB>17,BGPAGEB<65,BGPACTUP,$$HIGHRP^BGP2D3A(DFN,BGPEDATE) S BGPD5=1
  1.  I BGPAGEB>17,BGPAGEB<65,BGPACTCL S BGPD6=1
  1.  I BGPAGEB>17,BGPAGEB<65,BGPACTUP S BGPD7=1
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7) S BGPSTOP=1 Q
  1.  I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q
  1. PN ;EP - called from elder
  1.  S BGPVALUE=$$PNEU^BGP2D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;set to date of PNEU shot
  1.  ;I BGPVALUE]"" S BGPN1=1
  1.  I $P(BGPVALUE,U,3)=1!($P(BGPVALUE,U,3)=3) S BGPN1=1
  1.  I $P(BGPVALUE,U,3)=2 S BGPN2=1  ;REF
  1.  I $P(BGPVALUE,U,3)=3 S BGPN3=1  ;NMI
  1.  S BGPVAL=$$PNEU^BGP2D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
  1.  I $P(BGPVAL,U,3)=1!($P(BGPVAL,U,3)=3) S BGPN4=1  ;HAD IN PAST 5 YEARS SO "UP TO DATE"
  1.  I $P(BGPVAL,U,3)=2 S BGPN5=1
  1.  I $P(BGPVAL,U,3)=3 S BGPN6=1
  1.  S BGPN7=0,BGPA65="" I BGPAGEB>65 S BGPA65=$$PNEU^BGP2D31(DFN,$$FMADD^XLFDT($$DOB^AUPNPAT(DFN),+(65*365)),BGPEDATE) I $P(BGPA65,U,3)=1!($P(BGPA65,U,3)=3) S BGPN4=1,BGPN7=1 ;over 65 and had one after 65
  1.  I BGPAGEB<65,BGPN1 S BGPN4=1  ;anyone under and had 1 ever
  1.  ;GPRA DEVELOPMENTAL
  1.  S BGPN8=0
  1.  I BGPAGEB<66,BGPN1 S BGPN8=1
  1.  I BGPAGEB>65,BGPN1,(BGPN4+BGPN7) S BGPN8=1  ;IF UNDER 66 HAD 1 EVER, IF OVER 65 HAD ONE IN PAST 5 YEARS OR AFTER AGE 65
  1.  S BGPDV=""
  1.  I BGPRTYPE=1 S BGPDV="" D
  1.  .I BGPD1 S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
  1.  .I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1.  .I BGPN1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP2UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]""&($P(BGPVALH,U,2)'["Ref"):" (ever)",1:"") Q
  1.  .S BGPVALUE=BGPDV_"|||"
  1.  I BGPRTYPE=4 D
  1.  .S BGPDV="UP"
  1.  .I BGPD6!(BGPD1) S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
  1.  .I BGPD4!(BGPD5) S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")
  1.  .;I BGPD3 S BGPDV=BGPDV_$S(BGPDV]"":",UP >64",1:"UP >64")
  1.  .;I BGPD7 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64",1:"UP 18-64")
  1.  .;I BGPD5 S BGPDV=BGPDV_$S(BGPDV]"":",UP 18-64HR",1:"UP 18-64HR")
  1.  .I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1.  I BGPRTYPE=7 S BGPDV=$S(BGPD6:"AC",1:"") S:BGPD4 BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR") S:BGPD2 BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
  1.  I BGPRTYPE=3!(BGPRTYPE=5) S BGPVALUE="AC"_"|||"_$$DATE^BGP2UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) I 1
  1.  E  D
  1.  .I BGPRTYPE'=1 S BGPVALH=BGPVALUE,BGPVALUE=BGPDV_"|||" I BGPVALH]"" S BGPVALUE=BGPVALUE_"Pneumo: "_$$DATE^BGP2UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]""&($P(BGPVALH,U,2)'["Ref"):" (ever)",1:"")_" "_$S(BGPN8:" (up-to-date)",1:"")
  1.  .S BGPVALUD="AC"_"|||"
  1.  .I BGPN4 S BGPVALUD=BGPVALUD_"Pneumo: "_$$DATE^BGP2UTL($P(BGPVALH,U,1))_" "_$P(BGPVALH,U,2)_$S(BGPVALH]""&($P(BGPVALH,U,2)'["Ref"):" (ever)",1:"")_" "
  1.  .S BGPVALUD=BGPVALUD_$S(BGPN8:"(up-to-date)",1:"")
  1. TD ;new tdap and td stuff for v11.1
  1.  S BGPTDAP=$$DTAP^BGP2D3A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPTDAP S BGPN9=1
  1.  S BGPTD=$$DTAPTD^BGP2D3A(DFN,$$FMADD^XLFDT(BGPEDATE,-(10*365)),BGPEDATE)
  1.  I BGPTD S BGPN10=1
  1.  I BGPRTYPE=1 G TDE
  1.  I BGPTDAP S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"
  1.  ;I BGPTDAP,'BGPTD S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP: "_$P(BGPTDAP,U,2)_" (ever)"
  1.  I BGPTD S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:""),BGPVALUE=BGPVALUE_"TDAP/TD: "_$P(BGPTD,U,2)_" (past 10 yrs)"
  1.  ;I BGPTD S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"TDAP/TD PAST 10 YRS: "_$P(BGPTD,U,2)
  1. TDE K BGPLPNU,BGPVAL,BGPA65,BGPVALH
  1.  Q
  1. I15 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB,BGPI7DC,BGPPAP4
  1.  S BGPI7DA=0,BGPI7DB=0,BGPI7DC=0,BGPN1=0,BGPN2=0,BGPN3=0,BGPPAP4=""
  1.  S BGPI7=$$DEN7(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
  1.  I BGPACTUP,BGPI7 S BGPI7DA=1
  1.  I BGPACTCL,BGPI7 S BGPI7DB=1
  1.  I BGPACTCL,BGPI7,BGPAGEB>24,BGPAGEE<65 S BGPI7DC=1  ;2012 GPRA DEV
  1.  I 'BGPI7DA,'BGPI7DB,'BGPI7DC S BGPSTOP=1 Q  ;not in either denom so quit
  1.  S BGPPAP=$$PAP(DFN,BGPEDATE,3)
  1.  S BGPPAP4=$$PAP(DFN,BGPEDATE,4,1)
  1.  S BGPN1=0 I $P(BGPPAP,U)=1 S BGPN1=1
  1.  I $P(BGPPAP,U,3)["Ref" S BGPN2=1
  1.  I BGPN1,'BGPN2 S BGPN3=1
  1.  S BGPN4=0 I $P(BGPPAP4,U,1)=1,$P(BGPPAP4,U,3)'["Ref" S BGPN4=1  ;PAP IN 4 YRS, NO REFUSALS
  1.  I BGPRTYPE'=3,BGPRTYPE'=1 S BGPVALUE=$S(BGPI7DA:"UP",1:"")_$S(BGPI7DB:",AC",1:"")_"|||"_$$DATE^BGP2UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
  1.  I BGPRTYPE=1 S BGPVALUE=$S(BGPI7DA:"UP",1:"")_$S(BGPI7DB:",AC",1:"")_"|||" I BGPN3 S BGPVALUE=BGPVALUE_$$DATE^BGP2UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
  1.  I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP2UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
  1.  S BGPVALUD="AC|||" I BGPN4 S BGPVALUD=BGPVALUD_$$DATE^BGP2UTL($P(BGPPAP4,U,2))_" "_$P(BGPPAP4,U,3)
  1.  K BGPLPAP
  1.  Q
  1.  ;
  1. FLU(P,BD,ED,FORE) ;EP
  1.  G FLU^BGP2D37
  1. BI() ;
  1.  Q $S($O(^AUTTIMM(0))>100:1,1:0)
  1. DEN7(P,AGEB,AGEE,SEX,EDATE) ;EP
  1.  I SEX'="F" Q 0
  1.  I AGEB<21 Q 0
  1.  I AGEE>64 Q 0
  1.  I $$HYSTER(P,EDATE) Q 0
  1.  Q 1
  1. H1(I) ;
  1.  I $P($G(^ICPT(I,0)),U,1)=90664 Q 1
  1.  I $P($G(^ICPT(I,0)),U,1)=90666 Q 1
  1.  I $P($G(^ICPT(I,0)),U,1)=90667 Q 1
  1.  I $P($G(^ICPT(I,0)),U,1)=90668 Q 1
  1.  Q ""
  1. PAP(P,EDATE,YEARS,REFUSAL) ;EP
  1.  NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP
  1.  S BGPC=""
  1.  S BGPLPAP=""
  1.  S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
  1.  S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"")  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"")  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="PAP SMEAR" S BGPC="1^"_(9999999-D)_"^Lab" Q
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="1^"_(9999999-D)_"^Lab" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BGPC="1^"_(9999999-D)_"^Lab-loinc" Q
  1.  ...Q
  1.  S BGPLPAP=BGPC
  1.  K BGP
  1.  S T="BGP PAP SMEAR DXS"
  1.  I BGPRTYPE=3 S T="BGP HEDIS PAP SMEAR DXS"
  1.  S X=$$LASTDX^BGP2UTL1(P,T,BDATE,EDATE) I X,$P(BGPLPAP,U,2)<$P(X,U,3) S BGPLPAP="1^"_$P(X,U,3)_"^POV "_$P(X,U,2)
  1.  K BGP S BGP(1)=$$LASTPRC^BGP2UTL1(P,"BGP PAP PROCEDURES",BDATE,EDATE)
  1.  I $D(BGP(1)),$P(BGPLPAP,U,2)<$P(BGP(1),U,3) S BGPLPAP="1^"_$P(BGP(1),U,3)_"^PROC "_$P(BGP(1),U,2)
  1.  S T=$O(^ATXAX("B","BGP CPT PAP",0))
  1.  I T D  I X]"",$P(BGPLPAP,U,2)<$P(X,U,1) S BGPLPAP="1^"_$P(X,U)_"^CPT "_$P(X,U,2)
  1.  .S X=$$CPT^BGP2DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP2DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
  1.  S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
  1.  I T D  I X]"",$P(BGPLPAP,U,2)<X S BGPLPAP="1^"_X_"^WH"
  1.  .S X=$$WH^BGP2DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
  1.  I BGPLPAP]"" Q BGPLPAP
  1.  I $G(REFUSAL) Q ""  ;no Refusals counted
  1.  S T=$$REFUSAL^BGP2UTL1(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
  1.  I T Q "1^"_$P(T,U,2)_"^Refused Lab"
  1.  S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
  1.  I 'BGPLT Q 0
  1.  S X=0,T="" F  S X=$O(^ATXLAB(BGPLT,21,X)) Q:X'=+X!($P(T,U)=1)  D
  1.  .S T=""
  1.  .S Y=$P(^ATXLAB(BGPLT,21,X,0),U)
  1.  .Q:'Y
  1.  .S T=$$REFUSAL^BGP2UTL1(P,60,Y,$$FMADD^XLFDT(EDATE,-365),EDATE)
  1.  I T Q 1_"^"_$P(T,U,2)_"^Refused Lab "
  1.  ;add cpt Refusals v11.1
  1.  S T=$$CPTREFT^BGP2UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$O(^ATXAX("B","BGP CPT PAP",0)))
  1.  I T S T="1^"_$P(T,U,2)_"^Refused CPT "_$P(T,U,4) Q T
  1.  Q ""
  1. LOINC(A,B) ;
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1. HYSTER(P,EDATE) ;EP 
  1.  I '$G(P) Q ""
  1.  NEW X,T
  1.  S X=$$LASTPRC^BGP2UTL1(P,"BGP HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
  1.  I X Q 1
  1.  S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
  1.  I T D  I X]"" Q 1
  1.  .S X=$$WH^BGP2DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
  1.  S T=$O(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
  1.  I T D  I X]"" Q 1
  1.  .S X=$$CPT^BGP2DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q
  1.  .S X=$$TRAN^BGP2DU(P,$P(^DPT(P,0),U,3),EDATE,T,3)
  1.  S X=$$LASTDX^BGP2UTL1(P,"BGP HYSTERECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
  1.  I X Q 1
  1.  Q ""