BGP7D3 ; IHS/CMI/LAB - measure 11 17 Oct 2009 12:40 PM ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
;
I10 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S (BGPSEAL,BGPSEALD,BGPSEALR)=""
K BGPSEALS,BGPSELDS,BGPSEALR
D SEAL^BGP7D3A(DFN,BGPBDATE,BGPEDATE) ;this is for the number of sealants only
D SEALR^BGP7D3A(DFN,BGPBDATE,BGPEDATE)
S BGPN1=$P(BGPSEAL,U)+$P(BGPSEALR,U,1)
;BGPN1 is total # of sealants for sealant measure
I BGPAGEB>1,BGPAGEB<16 S BGPN2=BGPN1
I BGPAGEB>1,BGPAGEB<20,BGPN1 S BGPN7=1
I BGPAGEB>15 S BGPN3=BGPN1
I BGPAGEB>18 S BGPN4=BGPN1
S BGPD9=0 I BGPAGEB>1,BGPAGEB<16 S X=$$DENTSRV^BGP7D21(DFN,BGPBDATE,BGPEDATE) I X S BGPD9=1 ;V17.1 DEV DENOM
;S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
I101 ;
;get new sealant definition 2015 gpra dev
S BGPSEALD=""
I 'BGPN1 S BGPSEALD=$$SEALDEV^BGP7D3A(DFN,BGPBDATE,BGPEDATE)
I BGPSEALD S BGPN7=1
I BGPAGEB=2,BGPN7 S BGPN10=1
I BGPAGEB>2,BGPAGEB<6,BGPN7 S BGPN5=1
I BGPAGEB>5,BGPAGEB<10,BGPN7 S BGPN6=1
I BGPAGEB>9,BGPAGEB<13,BGPN7 S BGPN8=1
I BGPAGEB>12,BGPAGEB<16,BGPN7 S BGPN9=1
I BGPAGEB>1,BGPAGEB<16 S BGPD7=1
;I BGPAGEB>4,BGPAGEB<20 S BGPD8=1
;I 'BGPN1,'BGPD7 S BGPSTOP=1 Q
S BGPVALUE="UP"_$S(BGPD9:",DV",1:"")_"|||" ; _+BGPN1_" sealants"
I 'BGPN1,BGPD7!(BGPD8) S BGPVALUE=BGPVALUE_$P(BGPSEALD,U,2)
I BGPN1 S BGPVALUE=BGPVALUE_"; "_+BGPN1_" sealants: " D
.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^BGP7UTL(D)_" "_BGPSEALS(X,D)
.S X=0 F S X=$O(BGPSEALR(X)) Q:X'=+X S D=0 F S D=$O(BGPSEALR(X,D)) Q:D'=+D S BGPVALUE=BGPVALUE_$S(X=1:"",1:"; ")_$$DATE^BGP7UTL(D)_" "_BGPSEALR(X,D)
K BGPSEAL,BGPSEALD,BGPSEALR
Q
I11 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
NEW BGPFLUOR
I '$G(BGPACTUP) S BGPSTOP=1 Q
I BGPACTUP S BGPD1=1
S BGPFLUOR=$$TF^BGP7D3A(DFN,BGPBDATE,BGPEDATE)
S BGPN1=$P(BGPFLUOR,U)
I BGPN1>4 S BGPN1=4
I BGPAGEB>0,BGPAGEB<16 S BGPD2=1,BGPN3=$S(BGPN1:1,1:0)
I BGPAGEB>0,BGPAGEB<3 S BGPD3=1
I BGPAGEB>2,BGPAGEB<6 S BGPD4=1
I BGPAGEB>0,BGPAGEB<6 S BGPD5=1
I BGPAGEB>5,BGPAGEB<10 S BGPD6=1
I BGPAGEB>9,BGPAGEB<13 S BGPD7=1
I BGPAGEB>12,BGPAGEB<16 S BGPD8=1
S BGPD9=0 I BGPAGEB>0,BGPAGEB<16 S X=$$DENTSRV^BGP7D21(DFN,BGPBDATE,BGPEDATE) I X S BGPD9=1 ;V17.1 DEV DENOM
I111 ;
S BGPVALUE="UP|||"_+BGPN1_" topical fluoride"
I +BGPN1 S BGPVALUE=BGPVALUE_": " F X=2:1:5 I $P(BGPFLUOR,U,X)]"" S BGPVALUE=BGPVALUE_$S(X>2:", ",1:"")_$$DATE^BGP7UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)
;I BGPN2 S BGPVALUE=BGPVALUE_": "_$$DATE^BGP7UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)
S BGPVALUD="UP|||"
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^BGP7UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)
;I BGPN2 S BGPVALUD=BGPVALUD_": "_$$DATE^BGP7UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)
K ^TMP($J,"A"),BGPFLUOR
Q
I12 ;EP
NEW BGPHR,V,BGPAIM
S BGPAIM=$$AGE^BGP7D36(DFN,2,BGPBDATE)
;I BGPAIM<6 S BGPSTOP=1 Q
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPHR)=0
S BGPHR=$$HIGHR^BGP7D3A(DFN,BGPEDATE)
I BGPAGEB>49,BGPACTUP S BGPD5=1
I BGPAGEB>49,BGPAGEB<65,BGPACTUP S BGPD6=1
I BGPAGEB>64,BGPACTUP S BGPD7=1
I BGPDMD2 S BGPD4=1
I BGPAGEB>49,BGPACTCL S BGPD1=1
I BGPAGEB>49,BGPAGEB<65,BGPACTCL S BGPD2=1
I BGPAGEB>64,BGPACTCL S BGPD3=1
I BGPACTCL S BGPD8=1
I BGPAIM>5,BGPAGEB<18,BGPACTCL S BGPD9=1
I BGPAGEB>17,BGPAGEB<50,BGPACTCL S BGPD10=1
I BGPAGEB>17,BGPAGEB<50,BGPACTCL,BGPHR S BGPD11=1
I BGPACTUP S BGPD12=1
I BGPAIM>5,BGPAGEB<18,BGPACTUP S BGPD13=1
I BGPAGEB>17,BGPAGEB<50,BGPACTUP S BGPD14=1
I BGPAGEB>17,BGPAGEB<50,BGPACTUP,BGPHR S BGPD15=1
I BGPAGEB>17,BGPACTUP S BGPD16=1
I BGPAGEB>17,BGPACTCL S BGPD17=1
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14+BGPD15+BGPD16+BGPD17) S BGPSTOP=1 Q
S BGPVALUE=$$FLU(DFN,,BGPEDATE) ;set to date of flu shot
I $P(BGPVALUE,U,3)=1 S BGPN1=1
;I $P(BGPVALUE,U,3)=2 S BGPN2=1
I $P(BGPVALUE,U,3)=3 S BGPN3=1,BGPN1=1
I BGPN1 S BGPN7=1
S BGPDV=""
I BGPRTYPE=4 S BGPDV=$S(BGPACTUP:"UP",1:"") D
.I BGPACTCL S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
.I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
.I BGPHR S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")
I BGPRTYPE=1 D
.S BGPDV=$S(BGPD3!(BGPD2):"AC",1:"") I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
.S BGPVALUD=$S(BGPD8:"AC",1:"")
I BGPRTYPE=3!(BGPRTYPE=8) S BGPDV="AC"
I BGPRTYPE=7 D
.I BGPACTCL S BGPDV="AC"
.I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
.I BGPHR S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")
I BGPRTYPE'=1 S BGPVALUE=BGPDV_"|||"_$$DATE^BGP7UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)
I BGPRTYPE=1 D
.S BGPDV=BGPDV_"|||"
.S BGPVALUD=BGPVALUD_"|||"
.I BGPN7 S BGPVALUD=BGPVALUD_$$DATE^BGP7UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2),BGPVALUE=BGPDV_$$DATE^BGP7UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) Q
.S BGPVALUE=BGPDV
K BGPLFLU,BGPDV,BGPHR
Q
I13 ;EP
G I13^BGP7D3B
;
I15 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB,BGPI7DC,BGPI7DD,BGPPAP4,BGPPAP6
S BGPI7DA=0,BGPI7DB=0,BGPI7DC=0,BGPI7DD=0,BGPN1=0,BGPN2=0,BGPN3=0,BGPPAP4="",BGPN4=0,BGPPAP6="",BGPHPV=""
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6)=0
S BGPI7=$$DEN7(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
I BGPACTUP,BGPI7 S BGPI7DA=1
I BGPACTCL,BGPI7 S BGPI7DB=1
I BGPACTCL,BGPI7,BGPAGEB>23,BGPAGEE<65 S BGPI7DC=1,BGPD4=1 ;2014 GPRA DEV
I BGPACTUP,BGPI7,BGPAGEB>23,BGPAGEE<65 S BGPI7DD=1
I BGPACTCL,BGPI7,BGPAGEB>29,BGPAGEE<65 S BGPD1=1
I BGPACTCL,BGPI7,BGPAGEB>23,BGPAGEB<30 S BGPD2=1
I BGPACTUP,BGPI7,BGPAGEB>29,BGPAGEE<65 S BGPD7=1
I BGPACTUP,BGPI7,BGPAGEB>23,BGPAGEB<30 S BGPD8=1
I 'BGPI7DC,'BGPI7DD S BGPSTOP=1 Q ;not in either denom so quit
;I BGPTIME=1,BGPD4,'(BGPD1+BGPD2) W !,DFN,?10,"BGPD4=",BGPD4,?20,"BGPD2=",BGPD2,?30,"BGPD1=",BGPD1,?40,"AGEB: ",BGPAGEB,?50,"AGEE: ",BGPAGEE
S BGPPAP=$$PAP(DFN,BGPEDATE,3,1)
;S BGPPAP4=$$PAP(DFN,BGPEDATE,4,1)
S BGPN1=0 I $P(BGPPAP,U)=1 S BGPN1=1
I $P(BGPPAP,U,3)["Ref" S BGPN2=1
I BGPN1,'BGPN2 S BGPN3=1
S BGPN4=0 I $P(BGPPAP,U,1)=1 S BGPN4=1 ;PAP IN 3 YRS, NO REFUSALS
;for gpra dev, if they didn't have pap in 4 years check HPV
I 'BGPN4,(BGPD1!(BGPD7)) D
.S BGPPAP6=$$PAP(DFN,BGPEDATE,5)
.S BGPHPV=$$HPV(DFN,BGPEDATE,5)
.I BGPHPV,BGPPAP6 S BGPN5=1
I BGPN4!(BGPN5) S BGPN6=1
;I BGPTIME=1 W ?40,"BGPN4=",BGPN4,?50,"BGPN5=",?60,"BGPN6=",BGPN6
S BGPVALUE=$S(BGPI7DD:"UP",1:"")_$S(BGPI7DC:",AC",1:"")_"|||"
;I BGPRTYPE=1 S BGPVALUE=$S(BGPI7DA:"UP",1:"")_$S(BGPI7DB:",AC",1:"")_"|||" I BGPN3 S BGPVALUE=BGPVALUE_$$DATE^BGP7UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
;I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP7UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
I BGPN4 S BGPVALUE=BGPVALUE_"PAP 3 YRS: "_$$DATE^BGP7UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
I BGPN5 S BGPVALUE=BGPVALUE_" PAP&HPV 5 YRS: "_$$DATE^BGP7UTL($P(BGPPAP6,U,2))_" "_$P(BGPPAP6,U,3)_"; HPV: "_$$DATE^BGP7UTL($P(BGPHPV,U,2))_" "_$P(BGPHPV,U,3)
K BGPLPAP,BGPPAP,BGPHPV,BGPPAP4,BGPPAP6
Q
;
HPV(P,EDATE,YEARS) ;EP
NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP
S BGPC=""
S BGPLPAP=""
S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
S T=$O(^ATXAX("B","BGP HPV LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP HPV TESTS TAX",0))
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
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="HPV" S BGPC="1^"_(9999999-D)_"^Lab" Q
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="1^"_(9999999-D)_"^Lab" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC="1^"_(9999999-D)_"^Lab-loinc" Q
...Q
S BGPLPAP=BGPC
K BGP
S T="BGP HPV DXS"
S X=$$LASTDX^BGP7UTL1(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)
S T=$O(^ATXAX("B","BGP HPV CPTS",0))
I T D I X]"",$P(BGPLPAP,U,2)<$P(X,U,1) S BGPLPAP="1^"_$P(X,U)_"^CPT "_$P(X,U,2)
.S X=$$CPT^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
S T="HPV SCREEN",T=$O(^BWPN("B",T,0))
I T D I X]"",$P(BGPLPAP,U,2)<X S BGPLPAP="1^"_X_"^WH"
.S X=$$WH^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T D I X]"",$P(BGPLPAP,U,2)<X S BGPLPAP="1^"_X_"^WH"
.S X=$$PAPHPVWH(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
Q BGPLPAP
;
FLU(P,BD,ED,FORE) ;EP
G FLU^BGP7D37
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
DEN7(P,AGEB,AGEE,SEX,EDATE) ;EP
I SEX'="F" Q 0
I AGEB<24 Q 0
I AGEE>64 Q 0
I $$HYSTER(P,EDATE) Q 0
Q 1
H1(I) ;
I $P($G(^ICPT(I,0)),U,1)=90664 Q 1
I $P($G(^ICPT(I,0)),U,1)=90666 Q 1
I $P($G(^ICPT(I,0)),U,1)=90667 Q 1
I $P($G(^ICPT(I,0)),U,1)=90668 Q 1
Q ""
PAP(P,EDATE,YEARS,REFUSAL) ;EP
NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP
S BGPC=""
S BGPLPAP=""
S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
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
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...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
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="1^"_(9999999-D)_"^Lab" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC="1^"_(9999999-D)_"^Lab-loinc" Q
...Q
S BGPLPAP=BGPC
K BGP
S T="BGP PAP SMEAR DXS"
I BGPRTYPE=3 S T="BGP HEDIS PAP SMEAR DXS"
S X=$$LASTDX^BGP7UTL1(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)
;K BGP S BGP(1)=$$LASTPRC^BGP7UTL1(P,"BGP PAP PROCEDURES",BDATE,EDATE)
;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)
S T=$O(^ATXAX("B","BGP CPT PAP",0))
I T D I X]"",$P(BGPLPAP,U,2)<$P(X,U,1) S BGPLPAP="1^"_$P(X,U)_"^CPT "_$P(X,U,2)
.S X=$$CPT^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T D I X]"",$P(BGPLPAP,U,2)<X S BGPLPAP="1^"_X_"^WH"
.S X=$$WH^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
I BGPLPAP]"" Q BGPLPAP
I $G(REFUSAL) Q "" ;no Refusals counted
S T=$$REFUSAL^BGP7UTL1(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I T Q "1^"_$P(T,U,2)_"^Refused Lab"
S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
I 'BGPLT Q 0
S X=0,T="" F S X=$O(^ATXLAB(BGPLT,21,X)) Q:X'=+X!($P(T,U)=1) D
.S T=""
.S Y=$P(^ATXLAB(BGPLT,21,X,0),U)
.Q:'Y
.S T=$$REFUSAL^BGP7UTL1(P,60,Y,$$FMADD^XLFDT(EDATE,-365),EDATE)
I T Q 1_"^"_$P(T,U,2)_"^Refused Lab "
;add cpt Refusals v11.1
S T=$$CPTREFT^BGP7UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$O(^ATXAX("B","BGP CPT PAP",0)))
I T S T="1^"_$P(T,U,2)_"^Refused CPT "_$P(T,U,4) Q T
Q ""
PAPHPVWH(P,BDATE,EDATE,T,F) ;EP
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through procedures in a date range for this patient, check proc type
NEW D,X,Y,G,V,O
S (G,V)=0,I="" F S V=$O(^BWPCD("C",P,V)) Q:V="" D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.Q:$$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.;DOES HPV SAY YES?
.I '$P(^BWPCD(V,0),U,8) Q ;has to have HPV yes
.S I=$O(G(0)) I I>D Q
.S G=V,G(D)=""
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
Q ""
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
HYSTER(P,EDATE) ;EP
I '$G(P) Q ""
NEW X,T
S X=$$LASTPRC^BGP7UTL1(P,"BGP HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I X Q 1
S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
I T D I X]"" Q 1
.S X=$$WH^BGP7DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
S T=$O(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BGP7DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q
.S X=$$TRAN^BGP7DU(P,$P(^DPT(P,0),U,3),EDATE,T,3)
S X=$$LASTDX^BGP7UTL1(P,"BGP HYSTERECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
I X Q 1
;S X=$$PLTAX^BGP7DU(P,"BGP HYSTERECTOMY DXS")
;I X Q 1
S X=$$PLTAXND^BGP7DU(P,"BGP HYSTERECTOMY DXS",EDATE)
I X Q 1
S X=$$IPLSNOND^BGP7DU(P,"PXRM BGP HYSTERECTOMY DX",EDATE)
I X Q 1
Q ""
BGP7D3 ; IHS/CMI/LAB - measure 11 17 Oct 2009 12:40 PM ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+2 ;
+3 ;
I10 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET (BGPSEAL,BGPSEALD,BGPSEALR)=""
+3 KILL BGPSEALS,BGPSELDS,BGPSEALR
+4 ;this is for the number of sealants only
DO SEAL^BGP7D3A(DFN,BGPBDATE,BGPEDATE)
+5 DO SEALR^BGP7D3A(DFN,BGPBDATE,BGPEDATE)
+6 SET BGPN1=$PIECE(BGPSEAL,U)+$PIECE(BGPSEALR,U,1)
+7 ;BGPN1 is total # of sealants for sealant measure
+8 IF BGPAGEB>1
IF BGPAGEB<16
SET BGPN2=BGPN1
+9 IF BGPAGEB>1
IF BGPAGEB<20
IF BGPN1
SET BGPN7=1
+10 IF BGPAGEB>15
SET BGPN3=BGPN1
+11 IF BGPAGEB>18
SET BGPN4=BGPN1
+12 ;V17.1 DEV DENOM
SET BGPD9=0
IF BGPAGEB>1
IF BGPAGEB<16
SET X=$$DENTSRV^BGP7D21(DFN,BGPBDATE,BGPEDATE)
IF X
SET BGPD9=1
+13 ;S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
I101 ;
+1 ;get new sealant definition 2015 gpra dev
+2 SET BGPSEALD=""
+3 IF 'BGPN1
SET BGPSEALD=$$SEALDEV^BGP7D3A(DFN,BGPBDATE,BGPEDATE)
+4 IF BGPSEALD
SET BGPN7=1
+5 IF BGPAGEB=2
IF BGPN7
SET BGPN10=1
+6 IF BGPAGEB>2
IF BGPAGEB<6
IF BGPN7
SET BGPN5=1
+7 IF BGPAGEB>5
IF BGPAGEB<10
IF BGPN7
SET BGPN6=1
+8 IF BGPAGEB>9
IF BGPAGEB<13
IF BGPN7
SET BGPN8=1
+9 IF BGPAGEB>12
IF BGPAGEB<16
IF BGPN7
SET BGPN9=1
+10 IF BGPAGEB>1
IF BGPAGEB<16
SET BGPD7=1
+11 ;I BGPAGEB>4,BGPAGEB<20 S BGPD8=1
+12 ;I 'BGPN1,'BGPD7 S BGPSTOP=1 Q
+13 ; _+BGPN1_" sealants"
SET BGPVALUE="UP"_$SELECT(BGPD9:",DV",1:"")_"|||"
+14 IF 'BGPN1
IF BGPD7!(BGPD8)
SET BGPVALUE=BGPVALUE_$PIECE(BGPSEALD,U,2)
+15 IF BGPN1
SET BGPVALUE=BGPVALUE_"; "_+BGPN1_" sealants: "
Begin DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(BGPSEALS(X))
IF X'=+X
QUIT
SET D=0
FOR
SET D=$ORDER(BGPSEALS(X,D))
IF D'=+D
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(X=1:"",1:"; ")_$$DATE^BGP7UTL(D)_" "_BGPSEALS(X,D)
+17 SET X=0
FOR
SET X=$ORDER(BGPSEALR(X))
IF X'=+X
QUIT
SET D=0
FOR
SET D=$ORDER(BGPSEALR(X,D))
IF D'=+D
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(X=1:"",1:"; ")_$$DATE^BGP7UTL(D)_" "_BGPSEALR(X,D)
End DoDot:1
+18 KILL BGPSEAL,BGPSEALD,BGPSEALR
+19 QUIT
I11 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 NEW BGPFLUOR
+3 IF '$GET(BGPACTUP)
SET BGPSTOP=1
QUIT
+4 IF BGPACTUP
SET BGPD1=1
+5 SET BGPFLUOR=$$TF^BGP7D3A(DFN,BGPBDATE,BGPEDATE)
+6 SET BGPN1=$PIECE(BGPFLUOR,U)
+7 IF BGPN1>4
SET BGPN1=4
+8 IF BGPAGEB>0
IF BGPAGEB<16
SET BGPD2=1
SET BGPN3=$SELECT(BGPN1:1,1:0)
+9 IF BGPAGEB>0
IF BGPAGEB<3
SET BGPD3=1
+10 IF BGPAGEB>2
IF BGPAGEB<6
SET BGPD4=1
+11 IF BGPAGEB>0
IF BGPAGEB<6
SET BGPD5=1
+12 IF BGPAGEB>5
IF BGPAGEB<10
SET BGPD6=1
+13 IF BGPAGEB>9
IF BGPAGEB<13
SET BGPD7=1
+14 IF BGPAGEB>12
IF BGPAGEB<16
SET BGPD8=1
+15 ;V17.1 DEV DENOM
SET BGPD9=0
IF BGPAGEB>0
IF BGPAGEB<16
SET X=$$DENTSRV^BGP7D21(DFN,BGPBDATE,BGPEDATE)
IF X
SET BGPD9=1
I111 ;
+1 SET BGPVALUE="UP|||"_+BGPN1_" topical fluoride"
+2 IF +BGPN1
SET BGPVALUE=BGPVALUE_": "
FOR X=2:1:5
IF $PIECE(BGPFLUOR,U,X)]""
SET BGPVALUE=BGPVALUE_$SELECT(X>2:", ",1:"")_$$DATE^BGP7UTL($PIECE($PIECE(BGPFLUOR,U,X),"|",1))_" "_$PIECE($PIECE(BGPFLUOR,U,X),"|",2)
+3 ;I BGPN2 S BGPVALUE=BGPVALUE_": "_$$DATE^BGP7UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)
+4 SET BGPVALUD="UP|||"
+5 IF +BGPN1
SET BGPVALUD=BGPVALUD_+BGPN1_" topical fluoride"
IF +BGPN1
SET BGPVALUD=BGPVALUD_": "
FOR X=2:1:5
IF $PIECE(BGPFLUOR,U,X)]""
SET BGPVALUD=BGPVALUD_$SELECT(X>2:", ",1:"")_$$DATE^BGP7UTL($PIECE($PIECE(BGPFLUOR,U,X),"|",1))_" "_$PIECE($PIECE(BGPFLUOR,U,X),"|",2)
+6 ;I BGPN2 S BGPVALUD=BGPVALUD_": "_$$DATE^BGP7UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)
+7 KILL ^TMP($JOB,"A"),BGPFLUOR
+8 QUIT
I12 ;EP
+1 NEW BGPHR,V,BGPAIM
+2 SET BGPAIM=$$AGE^BGP7D36(DFN,2,BGPBDATE)
+3 ;I BGPAIM<6 S BGPSTOP=1 Q
+4 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPHR)=0
+5 SET BGPHR=$$HIGHR^BGP7D3A(DFN,BGPEDATE)
+6 IF BGPAGEB>49
IF BGPACTUP
SET BGPD5=1
+7 IF BGPAGEB>49
IF BGPAGEB<65
IF BGPACTUP
SET BGPD6=1
+8 IF BGPAGEB>64
IF BGPACTUP
SET BGPD7=1
+9 IF BGPDMD2
SET BGPD4=1
+10 IF BGPAGEB>49
IF BGPACTCL
SET BGPD1=1
+11 IF BGPAGEB>49
IF BGPAGEB<65
IF BGPACTCL
SET BGPD2=1
+12 IF BGPAGEB>64
IF BGPACTCL
SET BGPD3=1
+13 IF BGPACTCL
SET BGPD8=1
+14 IF BGPAIM>5
IF BGPAGEB<18
IF BGPACTCL
SET BGPD9=1
+15 IF BGPAGEB>17
IF BGPAGEB<50
IF BGPACTCL
SET BGPD10=1
+16 IF BGPAGEB>17
IF BGPAGEB<50
IF BGPACTCL
IF BGPHR
SET BGPD11=1
+17 IF BGPACTUP
SET BGPD12=1
+18 IF BGPAIM>5
IF BGPAGEB<18
IF BGPACTUP
SET BGPD13=1
+19 IF BGPAGEB>17
IF BGPAGEB<50
IF BGPACTUP
SET BGPD14=1
+20 IF BGPAGEB>17
IF BGPAGEB<50
IF BGPACTUP
IF BGPHR
SET BGPD15=1
+21 IF BGPAGEB>17
IF BGPACTUP
SET BGPD16=1
+22 IF BGPAGEB>17
IF BGPACTCL
SET BGPD17=1
+23 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14+BGPD15+BGPD16+BGPD17)
SET BGPSTOP=1
QUIT
+24 ;set to date of flu shot
SET BGPVALUE=$$FLU(DFN,,BGPEDATE)
+25 IF $PIECE(BGPVALUE,U,3)=1
SET BGPN1=1
+26 ;I $P(BGPVALUE,U,3)=2 S BGPN2=1
+27 IF $PIECE(BGPVALUE,U,3)=3
SET BGPN3=1
SET BGPN1=1
+28 IF BGPN1
SET BGPN7=1
+29 SET BGPDV=""
+30 IF BGPRTYPE=4
SET BGPDV=$SELECT(BGPACTUP:"UP",1:"")
Begin DoDot:1
+31 IF BGPACTCL
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+32 IF BGPD4
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
+33 IF BGPHR
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")
End DoDot:1
+34 IF BGPRTYPE=1
Begin DoDot:1
+35 SET BGPDV=$SELECT(BGPD3!(BGPD2):"AC",1:"")
IF BGPD4
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
+36 SET BGPVALUD=$SELECT(BGPD8:"AC",1:"")
End DoDot:1
+37 IF BGPRTYPE=3!(BGPRTYPE=8)
SET BGPDV="AC"
+38 IF BGPRTYPE=7
Begin DoDot:1
+39 IF BGPACTCL
SET BGPDV="AC"
+40 IF BGPD4
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
+41 IF BGPHR
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")
End DoDot:1
+42 IF BGPRTYPE'=1
SET BGPVALUE=BGPDV_"|||"_$$DATE^BGP7UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)
+43 IF BGPRTYPE=1
Begin DoDot:1
+44 SET BGPDV=BGPDV_"|||"
+45 SET BGPVALUD=BGPVALUD_"|||"
+46 IF BGPN7
SET BGPVALUD=BGPVALUD_$$DATE^BGP7UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)
SET BGPVALUE=BGPDV_$$DATE^BGP7UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)
QUIT
+47 SET BGPVALUE=BGPDV
End DoDot:1
+48 KILL BGPLFLU,BGPDV,BGPHR
+49 QUIT
I13 ;EP
+1 GOTO I13^BGP7D3B
+2 ;
I15 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB,BGPI7DC,BGPI7DD,BGPPAP4,BGPPAP6
+2 SET BGPI7DA=0
SET BGPI7DB=0
SET BGPI7DC=0
SET BGPI7DD=0
SET BGPN1=0
SET BGPN2=0
SET BGPN3=0
SET BGPPAP4=""
SET BGPN4=0
SET BGPPAP6=""
SET BGPHPV=""
+3 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6)=0
+4 SET BGPI7=$$DEN7(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+5 IF BGPACTUP
IF BGPI7
SET BGPI7DA=1
+6 IF BGPACTCL
IF BGPI7
SET BGPI7DB=1
+7 ;2014 GPRA DEV
IF BGPACTCL
IF BGPI7
IF BGPAGEB>23
IF BGPAGEE<65
SET BGPI7DC=1
SET BGPD4=1
+8 IF BGPACTUP
IF BGPI7
IF BGPAGEB>23
IF BGPAGEE<65
SET BGPI7DD=1
+9 IF BGPACTCL
IF BGPI7
IF BGPAGEB>29
IF BGPAGEE<65
SET BGPD1=1
+10 IF BGPACTCL
IF BGPI7
IF BGPAGEB>23
IF BGPAGEB<30
SET BGPD2=1
+11 IF BGPACTUP
IF BGPI7
IF BGPAGEB>29
IF BGPAGEE<65
SET BGPD7=1
+12 IF BGPACTUP
IF BGPI7
IF BGPAGEB>23
IF BGPAGEB<30
SET BGPD8=1
+13 ;not in either denom so quit
IF 'BGPI7DC
IF 'BGPI7DD
SET BGPSTOP=1
QUIT
+14 ;I BGPTIME=1,BGPD4,'(BGPD1+BGPD2) W !,DFN,?10,"BGPD4=",BGPD4,?20,"BGPD2=",BGPD2,?30,"BGPD1=",BGPD1,?40,"AGEB: ",BGPAGEB,?50,"AGEE: ",BGPAGEE
+15 SET BGPPAP=$$PAP(DFN,BGPEDATE,3,1)
+16 ;S BGPPAP4=$$PAP(DFN,BGPEDATE,4,1)
+17 SET BGPN1=0
IF $PIECE(BGPPAP,U)=1
SET BGPN1=1
+18 IF $PIECE(BGPPAP,U,3)["Ref"
SET BGPN2=1
+19 IF BGPN1
IF 'BGPN2
SET BGPN3=1
+20 ;PAP IN 3 YRS, NO REFUSALS
SET BGPN4=0
IF $PIECE(BGPPAP,U,1)=1
SET BGPN4=1
+21 ;for gpra dev, if they didn't have pap in 4 years check HPV
+22 IF 'BGPN4
IF (BGPD1!(BGPD7))
Begin DoDot:1
+23 SET BGPPAP6=$$PAP(DFN,BGPEDATE,5)
+24 SET BGPHPV=$$HPV(DFN,BGPEDATE,5)
+25 IF BGPHPV
IF BGPPAP6
SET BGPN5=1
End DoDot:1
+26 IF BGPN4!(BGPN5)
SET BGPN6=1
+27 ;I BGPTIME=1 W ?40,"BGPN4=",BGPN4,?50,"BGPN5=",?60,"BGPN6=",BGPN6
+28 SET BGPVALUE=$SELECT(BGPI7DD:"UP",1:"")_$SELECT(BGPI7DC:",AC",1:"")_"|||"
+29 ;I BGPRTYPE=1 S BGPVALUE=$S(BGPI7DA:"UP",1:"")_$S(BGPI7DB:",AC",1:"")_"|||" I BGPN3 S BGPVALUE=BGPVALUE_$$DATE^BGP7UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
+30 ;I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP7UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
+31 IF BGPN4
SET BGPVALUE=BGPVALUE_"PAP 3 YRS: "_$$DATE^BGP7UTL($PIECE(BGPPAP,U,2))_" "_$PIECE(BGPPAP,U,3)
+32 IF BGPN5
SET BGPVALUE=BGPVALUE_" PAP&HPV 5 YRS: "_$$DATE^BGP7UTL($PIECE(BGPPAP6,U,2))_" "_$PIECE(BGPPAP6,U,3)_"; HPV: "_$$DATE^BGP7UTL($PIECE(BGPHPV,U,2))_" "_$PIECE(BGPHPV,U,3)
+33 KILL BGPLPAP,BGPPAP,BGPHPV,BGPPAP4,BGPPAP6
+34 QUIT
+35 ;
HPV(P,EDATE,YEARS) ;EP
+1 NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP
+2 SET BGPC=""
+3 SET BGPLPAP=""
+4 SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+5 SET T=$ORDER(^ATXAX("B","BGP HPV LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","BGP HPV TESTS TAX",0))
+7 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC]"")
QUIT
Begin DoDot:1
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 SET Z=$PIECE(^AUPNVLAB(X,0),U)
SET Z=$PIECE($GET(^LAB(60,Z,0)),U)
IF Z="HPV"
SET BGPC="1^"_(9999999-D)_"^Lab"
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="1^"_(9999999-D)_"^Lab"
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET BGPC="1^"_(9999999-D)_"^Lab-loinc"
QUIT
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 SET BGPLPAP=BGPC
+19 KILL BGP
+20 SET T="BGP HPV DXS"
+21 SET X=$$LASTDX^BGP7UTL1(P,T,BDATE,EDATE)
IF X
IF $PIECE(BGPLPAP,U,2)<$PIECE(X,U,3)
SET BGPLPAP="1^"_$PIECE(X,U,3)_"^POV "_$PIECE(X,U,2)
+22 SET T=$ORDER(^ATXAX("B","BGP HPV CPTS",0))
+23 IF T
Begin DoDot:1
+24 SET X=$$CPT^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
IF X]""
QUIT
+25 SET X=$$TRAN^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLPAP,U,2)<$PIECE(X,U,1)
SET BGPLPAP="1^"_$PIECE(X,U)_"^CPT "_$PIECE(X,U,2)
+26 SET T="HPV SCREEN"
SET T=$ORDER(^BWPN("B",T,0))
+27 IF T
Begin DoDot:1
+28 SET X=$$WH^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
End DoDot:1
IF X]""
IF $PIECE(BGPLPAP,U,2)<X
SET BGPLPAP="1^"_X_"^WH"
+29 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+30 IF T
Begin DoDot:1
+31 SET X=$$PAPHPVWH(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
End DoDot:1
IF X]""
IF $PIECE(BGPLPAP,U,2)<X
SET BGPLPAP="1^"_X_"^WH"
+32 QUIT BGPLPAP
+33 ;
FLU(P,BD,ED,FORE) ;EP
+1 GOTO FLU^BGP7D37
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
DEN7(P,AGEB,AGEE,SEX,EDATE) ;EP
+1 IF SEX'="F"
QUIT 0
+2 IF AGEB<24
QUIT 0
+3 IF AGEE>64
QUIT 0
+4 IF $$HYSTER(P,EDATE)
QUIT 0
+5 QUIT 1
H1(I) ;
+1 IF $PIECE($GET(^ICPT(I,0)),U,1)=90664
QUIT 1
+2 IF $PIECE($GET(^ICPT(I,0)),U,1)=90666
QUIT 1
+3 IF $PIECE($GET(^ICPT(I,0)),U,1)=90667
QUIT 1
+4 IF $PIECE($GET(^ICPT(I,0)),U,1)=90668
QUIT 1
+5 QUIT ""
PAP(P,EDATE,YEARS,REFUSAL) ;EP
+1 NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP
+2 SET BGPC=""
+3 SET BGPLPAP=""
+4 SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+5 SET T=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+7 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC]"")
QUIT
Begin DoDot:1
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 SET Z=$PIECE(^AUPNVLAB(X,0),U)
SET Z=$PIECE($GET(^LAB(60,Z,0)),U)
IF Z="PAP SMEAR"
SET BGPC="1^"_(9999999-D)_"^Lab"
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="1^"_(9999999-D)_"^Lab"
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET BGPC="1^"_(9999999-D)_"^Lab-loinc"
QUIT
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 SET BGPLPAP=BGPC
+19 KILL BGP
+20 SET T="BGP PAP SMEAR DXS"
+21 IF BGPRTYPE=3
SET T="BGP HEDIS PAP SMEAR DXS"
+22 SET X=$$LASTDX^BGP7UTL1(P,T,BDATE,EDATE)
IF X
IF $PIECE(BGPLPAP,U,2)<$PIECE(X,U,3)
SET BGPLPAP="1^"_$PIECE(X,U,3)_"^POV "_$PIECE(X,U,2)
+23 ;K BGP S BGP(1)=$$LASTPRC^BGP7UTL1(P,"BGP PAP PROCEDURES",BDATE,EDATE)
+24 ;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)
+25 SET T=$ORDER(^ATXAX("B","BGP CPT PAP",0))
+26 IF T
Begin DoDot:1
+27 SET X=$$CPT^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
IF X]""
QUIT
+28 SET X=$$TRAN^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLPAP,U,2)<$PIECE(X,U,1)
SET BGPLPAP="1^"_$PIECE(X,U)_"^CPT "_$PIECE(X,U,2)
+29 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+30 IF T
Begin DoDot:1
+31 SET X=$$WH^BGP7DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
End DoDot:1
IF X]""
IF $PIECE(BGPLPAP,U,2)<X
SET BGPLPAP="1^"_X_"^WH"
+32 IF BGPLPAP]""
QUIT BGPLPAP
+33 ;no Refusals counted
IF $GET(REFUSAL)
QUIT ""
+34 SET T=$$REFUSAL^BGP7UTL1(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+35 IF T
QUIT "1^"_$PIECE(T,U,2)_"^Refused Lab"
+36 SET BGPLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+37 IF 'BGPLT
QUIT 0
+38 SET X=0
SET T=""
FOR
SET X=$ORDER(^ATXLAB(BGPLT,21,X))
IF X'=+X!($PIECE(T,U)=1)
QUIT
Begin DoDot:1
+39 SET T=""
+40 SET Y=$PIECE(^ATXLAB(BGPLT,21,X,0),U)
+41 IF 'Y
QUIT
+42 SET T=$$REFUSAL^BGP7UTL1(P,60,Y,$$FMADD^XLFDT(EDATE,-365),EDATE)
End DoDot:1
+43 IF T
QUIT 1_"^"_$PIECE(T,U,2)_"^Refused Lab "
+44 ;add cpt Refusals v11.1
+45 SET T=$$CPTREFT^BGP7UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$ORDER(^ATXAX("B","BGP CPT PAP",0)))
+46 IF T
SET T="1^"_$PIECE(T,U,2)_"^Refused CPT "_$PIECE(T,U,4)
QUIT T
+47 QUIT ""
PAPHPVWH(P,BDATE,EDATE,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through procedures in a date range for this patient, check proc type
+7 NEW D,X,Y,G,V,O
+8 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+9 IF '$DATA(^BWPCD(V,0))
QUIT
+10 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+11 IF $$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
QUIT
+12 SET D=$PIECE(^BWPCD(V,0),U,12)
+13 IF D<BDATE
QUIT
+14 IF D>EDATE
QUIT
+15 ;DOES HPV SAY YES?
+16 ;has to have HPV yes
IF '$PIECE(^BWPCD(V,0),U,8)
QUIT
+17 SET I=$ORDER(G(0))
IF I>D
QUIT
+18 SET G=V
SET G(D)=""
+19 QUIT
End DoDot:1
+20 IF 'G
QUIT ""
+21 IF F=1
QUIT $SELECT(G:1,1:"")
+22 IF F=2
QUIT G
+23 IF F=3
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT D
+24 IF F=4
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT $$FMTE^XLFDT(D)
+25 QUIT ""
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
HYSTER(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW X,T
+3 SET X=$$LASTPRC^BGP7UTL1(P,"BGP HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+4 IF X
QUIT 1
+5 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+6 IF T
Begin DoDot:1
+7 SET X=$$WH^BGP7DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
End DoDot:1
IF X]""
QUIT 1
+8 SET T=$ORDER(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
+9 IF T
Begin DoDot:1
+10 SET X=$$CPT^BGP7DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
IF X]""
QUIT
+11 SET X=$$TRAN^BGP7DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
End DoDot:1
IF X]""
QUIT 1
+12 SET X=$$LASTDX^BGP7UTL1(P,"BGP HYSTERECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)
+13 IF X
QUIT 1
+14 ;S X=$$PLTAX^BGP7DU(P,"BGP HYSTERECTOMY DXS")
+15 ;I X Q 1
+16 SET X=$$PLTAXND^BGP7DU(P,"BGP HYSTERECTOMY DXS",EDATE)
+17 IF X
QUIT 1
+18 SET X=$$IPLSNOND^BGP7DU(P,"PXRM BGP HYSTERECTOMY DX",EDATE)
+19 IF X
QUIT 1
+20 QUIT ""
