BGP9D3 ; IHS/CMI/LAB - measure 11 17 Oct 2007 12:40 PM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;
I10 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6)=0
S BGPSEAL=$$SEAL(DFN,BGP365,BGPEDATE)
I $P(BGPSEAL,U,2)]"" S BGPN5=$P(BGPSEAL,U,1),BGPN1=$P(BGPSEAL,U,1) G I101
S BGPN1=$P(BGPSEAL,U)
I BGPAGEB<12 S BGPN2=BGPN1
I BGPAGEB>11,BGPAGEB<19 S BGPN3=BGPN1
I BGPAGEB>18 S BGPN4=BGPN1
S BGPN6=BGPN1
I101 ;
S BGPVALUE="UP|||"_BGPN1_$S($P(BGPSEAL,U,3)]"":" "_$P(BGPSEAL,U,3),1:" sealants ")
K BGPSEAL
Q
I11 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3)=0
S BGPFLUOR=$$TF(DFN,BGP365,BGPEDATE)
S BGPN1=$P(BGPFLUOR,U)
I $P(BGPFLUOR,U,3)]"" S BGPN2=1,BGPD2=1
I BGPN1>0 S BGPD1=1
I BGPN1>4 S BGPN1=4
I BGPD1,'BGPD2 S BGPD3=1
S BGPVALUE="UP|||"_BGPN1_$S($P(BGPFLUOR,U,3)]"":" "_$P(BGPFLUOR,U,3),1:" topical fluoride ")
K ^TMP($J,"A"),BGPFLUOR
Q
I12 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
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 '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7) S BGPSTOP=1 Q
S BGPVALUE=$$FLU(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
I BGPN1,'BGPN2 S BGPN7=1
S BGPDV=""
I BGPRTYPE=4 S BGPDV=$S(BGPD5:"UP",1:"") D
.I BGPD1 S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
.I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
I BGPRTYPE=1 S BGPDV=$S(BGPD3!(BGPD2):"AC",1:"") I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":";AD",1:"AD")
I BGPRTYPE=3!(BGPRTYPE=8) S BGPDV="AC"
I BGPRTYPE=7 S BGPDV="AD"
S BGPVALUE=BGPDV_"|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)
K BGPLFLU,BGPDV
Q
I13 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3)=0
I BGPAGEB>64,BGPACTUP S BGPD3=1
I BGPDMD2 S BGPD2=1
I BGPAGEB>64,BGPACTCL S BGPD1=1
I '(BGPD1+BGPD2+BGPD3) S BGPSTOP=1 Q
I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q
PN ;EP - called from elder
S BGPVALUE=$$PNEU^BGP9D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;set to date of PNEU shot
I BGPVALUE]"" S BGPN1=1
I $P(BGPVALUE,U,3)=2 S BGPN2=1
I $P(BGPVALUE,U,3)=3 S BGPN3=1
I BGPN1,'BGPN2 S BGPN7=1
S BGPVAL=$$PNEU^BGP9D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
I BGPVAL]"" S BGPN4=1
I $P(BGPVAL,U,3)=2 S BGPN5=1
I $P(BGPVAL,U,3)=3 S BGPN6=1
S BGPDV=""
I BGPRTYPE=4 S BGPDV=$S(BGPD3:"UP",1:"") D
.I BGPD1 S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")
.I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
I BGPRTYPE=1 S BGPDV=$S(BGPD1:"AC",1:"") I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")
I BGPRTYPE=7 S BGPDV="AD"
I BGPRTYPE=3!(BGPRTYPE=5) S BGPVALUE="AC"_"|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) I 1
E S BGPVALUE=BGPDV_"|||"_$$DATE^BGP9UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)_$S(BGPVALUE]"":" (ever)",1:"")_" "_$$DATE^BGP9UTL($P(BGPVAL,U,1))_" "_$P(BGPVAL,U,2)_$S(BGPVAL]"":" (past 5 yrs)",1:"")
K BGPLPNU
Q
I15 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB
S BGPI7DA=0,BGPI7DB=0,BGPI7DC=0,BGPN1=0,BGPN2=0,BGPN3=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
I 'BGPI7DA,'BGPI7DB,'BGPI7DC S BGPSTOP=1 Q ;not in either denom so quit
S BGPPAP=$$PAP(DFN,BGPEDATE,3)
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
I BGPRTYPE'=3 S BGPVALUE=$S(BGPI7DA:"UP",1:"")_$S(BGPI7DB:",AC",1:"")_"|||"_$$DATE^BGP9UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP9UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)
K BGPLPAP
Q
;
SEAL(P,BDATE,EDATE) ;
K BGPG,BGPX S BGPC=0
S %=P_"^ALL ADA 1351;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X D
.S V=+$P(BGPG(X),U,4)
.S T=$P($G(^AUPNVDEN(V,0)),U,4)
.S:T=""!(T=0) T=1
.S S=$P(^AUPNVDEN(V,0),U,5)
.I S]"" S BGPX(S)=$G(BGPX(S))+T
.I S="" S BGPX("NO OS")=$G(BGPX("NO OS"))+T
.Q
S X="" F S X=$O(BGPX(X)) Q:X="" S BGPC=BGPC+$S(BGPX(X)>2:2,1:BGPX(X))
I BGPC Q BGPC
;now gather up refusals - one per patient
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","1351",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused ADA 1351"
Q ""
TF(P,BDATE,EDATE) ;
K BGPG S BGPC=0
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPC>3) S V=$P(^TMP($J,"A",X),U,5) D
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y!(G>0)!(BGPC>3) D
..S A=$P($G(^AUPNVDEN(Y,0)),U) I A S A=$P($G(^AUTTADA(A,0)),U) D
...I A=1201!(A=1203)!(A=1204)!(A=1205)!(A=1206) S T=$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1 S BGPC=BGPC+T,G=G+1
...Q
.Q:G
.S Y=0,G=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) D
..S A=$P($G(^AUPNVPOV(Y,0)),U) I A S A=$P($$ICDDX^ICDCODE(A),U,2) D
...I A="V07.31" S BGPC=BGPC+1,G=1
...Q
I BGPC Q BGPC
;one refusal per patient
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","1201",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused ADA 1201"
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","1203",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused ADA 1203"
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","1204",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused ADA 1204"
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","1205",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused ADA 1205"
S G=$$REFUSAL^BGP9UTL1(P,9999999.31,$O(^AUTTADA("B","1206",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused ADA 1206"
Q ""
FLU(P,BD,ED) ;EP
K BGPG
S BGPLFLU=""
I $G(BD)="" S BD=$$FMADD^XLFDT(ED,-365)
S EDATE=$$FMTE^XLFDT(ED),BDATE=$$FMTE^XLFDT(BD)
S X=P_"^LAST IMM 88;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 88"
S X=P_"^LAST IMM 111;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 111"
S X=P_"^LAST IMM 15;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 15"
S X=P_"^LAST IMM 16;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 16"
S BGPG=$$LASTPRCI^BGP9UTL1(P,"99.52",BDATE,EDATE)
I $P(BGPG,U,1)=1,$P(BGPLFLU,U)<$P(BGPG,U,3) S BGPLFLU=$P(BGPG,U,3)_U_"99.52"
K BGPG S %=P_"^LAST DX V04.8;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"V04.8"
K BGPG S %=P_"^LAST DX V04.81;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"V04.81"
K BGPG S %=P_"^LAST DX V06.6;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"V06.6"
S T=$O(^ATXAX("B","BGP CPT FLU",0))
I T D I X]"" I $P(BGPLFLU,U)<X S BGPLFLU=$P(X,U)_U_"CPT "_$P(X,U,2)
.S X=$$CPT^BGP9DU(P,,ED,T,5) I X]"" Q
.S X=$$TRAN^BGP9DU(P,,ED,T,5)
I BGPLFLU]"" Q BGPLFLU_U_1
;contraindication new in 8.0
F BGPZ=15,16,88,111 S X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED) Q:X]""
I X]"" Q X_U_3
;NMI refusal
S G=$$NMIREF^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",88,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",111,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",15,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",16,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
;refusal
S G=$$REFUSAL^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",88,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",111,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",15,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP9UTL1(P,9999999.14,$O(^AUTTIMM("C",16,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",88,0)) F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",111,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",15,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",16,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
Q ""
FLCONT(P,C,BD,ED) ;EP
NEW X,G,Y,R,D
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Contraindication: Egg Allergy"
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Contraindication: Anaphylaxis"
Q G
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
DEN7(P,AGEB,AGEE,SEX,EDATE) ;EP
I SEX'="F" Q 0
I AGEB<21 Q 0
I AGEE>64 Q 0
I $$HYSTER(P,EDATE) Q 0
Q 1
PAP(P,EDATE,YEARS) ;EP
K BGPC
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^BGP9UTL1(P,T,BDATE,EDATE) I X,$P(BGPLPAP,U,2)<$P(X,U,3) S BGPLPAP="1^"_$P(X,U,3)_"^"_$P(X,U,2)
K BGP S %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
I $D(BGP(1)),$P(BGPLPAP,U,2)<$P(BGP(1),U,1) S BGPLPAP="1^"_$P(BGP(1),U)_"^91.46"
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)_"^"_$P(X,U,2)
.S X=$$CPT^BGP9DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP9DU(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^BGP9DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
I BGPLPAP]"" Q BGPLPAP
S T=$$REFUSAL^BGP9UTL1(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I T Q "1^"_$P(T,U,2)_"^ref"
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^BGP9UTL1(P,60,Y,$$FMADD^XLFDT(EDATE,-365),EDATE)
I T Q 1_"^"_$P(T,U,2)_"^ref"
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 ""
S X=$$LASTPRC^BGP9UTL1(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^BGP9DU(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^BGP9DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q
.S X=$$TRAN^BGP9DU(P,$P(^DPT(P,0),U,3),EDATE,T,3)
S X=$$LASTDXI^BGP9UTL1(P,618.5,$$DOB^AUPNPAT(P),EDATE,1)
I X Q 1
Q ""
BGP9D3 ; IHS/CMI/LAB - measure 11 17 Oct 2007 12:40 PM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
+3 ;
I10 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6)=0
+2 SET BGPSEAL=$$SEAL(DFN,BGP365,BGPEDATE)
+3 IF $PIECE(BGPSEAL,U,2)]""
SET BGPN5=$PIECE(BGPSEAL,U,1)
SET BGPN1=$PIECE(BGPSEAL,U,1)
GOTO I101
+4 SET BGPN1=$PIECE(BGPSEAL,U)
+5 IF BGPAGEB<12
SET BGPN2=BGPN1
+6 IF BGPAGEB>11
IF BGPAGEB<19
SET BGPN3=BGPN1
+7 IF BGPAGEB>18
SET BGPN4=BGPN1
+8 SET BGPN6=BGPN1
I101 ;
+1 SET BGPVALUE="UP|||"_BGPN1_$SELECT($PIECE(BGPSEAL,U,3)]"":" "_$PIECE(BGPSEAL,U,3),1:" sealants ")
+2 KILL BGPSEAL
+3 QUIT
I11 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3)=0
+2 SET BGPFLUOR=$$TF(DFN,BGP365,BGPEDATE)
+3 SET BGPN1=$PIECE(BGPFLUOR,U)
+4 IF $PIECE(BGPFLUOR,U,3)]""
SET BGPN2=1
SET BGPD2=1
+5 IF BGPN1>0
SET BGPD1=1
+6 IF BGPN1>4
SET BGPN1=4
+7 IF BGPD1
IF 'BGPD2
SET BGPD3=1
+8 SET BGPVALUE="UP|||"_BGPN1_$SELECT($PIECE(BGPFLUOR,U,3)]"":" "_$PIECE(BGPFLUOR,U,3),1:" topical fluoride ")
+9 KILL ^TMP($JOB,"A"),BGPFLUOR
+10 QUIT
I12 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
+2 IF BGPAGEB>49
IF BGPACTUP
SET BGPD5=1
+3 IF BGPAGEB>49
IF BGPAGEB<65
IF BGPACTUP
SET BGPD6=1
+4 IF BGPAGEB>64
IF BGPACTUP
SET BGPD7=1
+5 IF BGPDMD2
SET BGPD4=1
+6 IF BGPAGEB>49
IF BGPACTCL
SET BGPD1=1
+7 IF BGPAGEB>49
IF BGPAGEB<65
IF BGPACTCL
SET BGPD2=1
+8 IF BGPAGEB>64
IF BGPACTCL
SET BGPD3=1
+9 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7)
SET BGPSTOP=1
QUIT
+10 ;set to date of flu shot
SET BGPVALUE=$$FLU(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 IF BGPN1
IF 'BGPN2
SET BGPN7=1
+15 SET BGPDV=""
+16 IF BGPRTYPE=4
SET BGPDV=$SELECT(BGPD5:"UP",1:"")
Begin DoDot:1
+17 IF BGPD1
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+18 IF BGPD4
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
End DoDot:1
+19 IF BGPRTYPE=1
SET BGPDV=$SELECT(BGPD3!(BGPD2):"AC",1:"")
IF BGPD4
SET BGPDV=BGPDV_$SELECT(BGPDV]"":";AD",1:"AD")
+20 IF BGPRTYPE=3!(BGPRTYPE=8)
SET BGPDV="AC"
+21 IF BGPRTYPE=7
SET BGPDV="AD"
+22 SET BGPVALUE=BGPDV_"|||"_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)
+23 KILL BGPLFLU,BGPDV
+24 QUIT
I13 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3)=0
+2 IF BGPAGEB>64
IF BGPACTUP
SET BGPD3=1
+3 IF BGPDMD2
SET BGPD2=1
+4 IF BGPAGEB>64
IF BGPACTCL
SET BGPD1=1
+5 IF '(BGPD1+BGPD2+BGPD3)
SET BGPSTOP=1
QUIT
+6 IF BGPRTYPE=3
IF 'BGPD1
SET BGPSTOP=1
QUIT
PN ;EP - called from elder
+1 ;set to date of PNEU shot
SET BGPVALUE=$$PNEU^BGP9D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+2 IF BGPVALUE]""
SET BGPN1=1
+3 IF $PIECE(BGPVALUE,U,3)=2
SET BGPN2=1
+4 IF $PIECE(BGPVALUE,U,3)=3
SET BGPN3=1
+5 IF BGPN1
IF 'BGPN2
SET BGPN7=1
+6 SET BGPVAL=$$PNEU^BGP9D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
+7 IF BGPVAL]""
SET BGPN4=1
+8 IF $PIECE(BGPVAL,U,3)=2
SET BGPN5=1
+9 IF $PIECE(BGPVAL,U,3)=3
SET BGPN6=1
+10 SET BGPDV=""
+11 IF BGPRTYPE=4
SET BGPDV=$SELECT(BGPD3:"UP",1:"")
Begin DoDot:1
+12 IF BGPD1
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")
+13 IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
End DoDot:1
+14 IF BGPRTYPE=1
SET BGPDV=$SELECT(BGPD1:"AC",1:"")
IF BGPD2
SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")
+15 IF BGPRTYPE=7
SET BGPDV="AD"
+16 IF BGPRTYPE=3!(BGPRTYPE=5)
SET BGPVALUE="AC"_"|||"_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)
IF 1
+17 IF '$TEST
SET BGPVALUE=BGPDV_"|||"_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)_$SELECT(BGPVALUE]"":" (ever)",1:"")_" "_$$DATE^BGP9UTL($PIECE(BGPVAL,U,1))_" "_$PIECE(BGPVAL,U,2)_$SELECT(BGPVAL]"":" (past 5 yrs)",1:"")
+18 KILL BGPLPNU
+19 QUIT
I15 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB
+2 SET BGPI7DA=0
SET BGPI7DB=0
SET BGPI7DC=0
SET BGPN1=0
SET BGPN2=0
SET BGPN3=0
+3 SET BGPI7=$$DEN7(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+4 IF BGPACTUP
IF BGPI7
SET BGPI7DA=1
+5 IF BGPACTCL
IF BGPI7
SET BGPI7DB=1
+6 IF BGPACTCL
IF BGPI7
IF BGPAGEB>23
IF BGPAGEE<65
SET BGPI7DC=1
+7 ;not in either denom so quit
IF 'BGPI7DA
IF 'BGPI7DB
IF 'BGPI7DC
SET BGPSTOP=1
QUIT
+8 SET BGPPAP=$$PAP(DFN,BGPEDATE,3)
+9 SET BGPN1=0
IF $PIECE(BGPPAP,U)=1
SET BGPN1=1
+10 IF $PIECE(BGPPAP,U,3)="ref"
SET BGPN2=1
+11 IF BGPN1
IF 'BGPN2
SET BGPN3=1
+12 IF BGPRTYPE'=3
SET BGPVALUE=$SELECT(BGPI7DA:"UP",1:"")_$SELECT(BGPI7DB:",AC",1:"")_"|||"_$$DATE^BGP9UTL($PIECE(BGPPAP,U,2))_" "_$PIECE(BGPPAP,U,3)
+13 IF BGPRTYPE=3
SET BGPVALUE="AC|||"_$$DATE^BGP9UTL($PIECE(BGPPAP,U,2))_" "_$PIECE(BGPPAP,U,3)
+14 KILL BGPLPAP
+15 QUIT
+16 ;
SEAL(P,BDATE,EDATE) ;
+1 KILL BGPG,BGPX
SET BGPC=0
+2 SET %=P_"^ALL ADA 1351;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET V=+$PIECE(BGPG(X),U,4)
+5 SET T=$PIECE($GET(^AUPNVDEN(V,0)),U,4)
+6 IF T=""!(T=0)
SET T=1
+7 SET S=$PIECE(^AUPNVDEN(V,0),U,5)
+8 IF S]""
SET BGPX(S)=$GET(BGPX(S))+T
+9 IF S=""
SET BGPX("NO OS")=$GET(BGPX("NO OS"))+T
+10 QUIT
End DoDot:1
+11 SET X=""
FOR
SET X=$ORDER(BGPX(X))
IF X=""
QUIT
SET BGPC=BGPC+$SELECT(BGPX(X)>2:2,1:BGPX(X))
+12 IF BGPC
QUIT BGPC
+13 ;now gather up refusals - one per patient
+14 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","1351",0)),BDATE,EDATE)
+15 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused ADA 1351"
+16 QUIT ""
TF(P,BDATE,EDATE) ;
+1 KILL BGPG
SET BGPC=0
+2 KILL ^TMP($JOB,"A")
+3 SET A="^TMP($J,""A"","
+4 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+5 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPC>3)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y!(G>0)!(BGPC>3)
QUIT
Begin DoDot:2
+7 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
IF A
SET A=$PIECE($GET(^AUTTADA(A,0)),U)
Begin DoDot:3
+8 IF A=1201!(A=1203)!(A=1204)!(A=1205)!(A=1206)
SET T=$PIECE($GET(^AUPNVDEN(Y,0)),U,4)
IF T=""!(T=0)
SET T=1
SET BGPC=BGPC+T
SET G=G+1
+9 QUIT
End DoDot:3
End DoDot:2
+10 IF G
QUIT
+11 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+12 SET A=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF A
SET A=$PIECE($$ICDDX^ICDCODE(A),U,2)
Begin DoDot:3
+13 IF A="V07.31"
SET BGPC=BGPC+1
SET G=1
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF BGPC
QUIT BGPC
+16 ;one refusal per patient
+17 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","1201",0)),BDATE,EDATE)
+18 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused ADA 1201"
+19 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","1203",0)),BDATE,EDATE)
+20 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused ADA 1203"
+21 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","1204",0)),BDATE,EDATE)
+22 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused ADA 1204"
+23 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","1205",0)),BDATE,EDATE)
+24 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused ADA 1205"
+25 SET G=$$REFUSAL^BGP9UTL1(P,9999999.31,$ORDER(^AUTTADA("B","1206",0)),BDATE,EDATE)
+26 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused ADA 1206"
+27 QUIT ""
FLU(P,BD,ED) ;EP
+1 KILL BGPG
+2 SET BGPLFLU=""
+3 IF $GET(BD)=""
SET BD=$$FMADD^XLFDT(ED,-365)
+4 SET EDATE=$$FMTE^XLFDT(ED)
SET BDATE=$$FMTE^XLFDT(BD)
+5 SET X=P_"^LAST IMM 88;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+6 IF $DATA(BGPG(1))
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 88"
+7 SET X=P_"^LAST IMM 111;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 111"
+9 SET X=P_"^LAST IMM 15;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+10 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 15"
+11 SET X=P_"^LAST IMM 16;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+12 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 16"
+13 SET BGPG=$$LASTPRCI^BGP9UTL1(P,"99.52",BDATE,EDATE)
+14 IF $PIECE(BGPG,U,1)=1
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG,U,3)
SET BGPLFLU=$PIECE(BGPG,U,3)_U_"99.52"
+15 KILL BGPG
SET %=P_"^LAST DX V04.8;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+16 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_"V04.8"
+17 KILL BGPG
SET %=P_"^LAST DX V04.81;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+18 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_"V04.81"
+19 KILL BGPG
SET %=P_"^LAST DX V06.6;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_"V06.6"
+21 SET T=$ORDER(^ATXAX("B","BGP CPT FLU",0))
+22 IF T
Begin DoDot:1
+23 SET X=$$CPT^BGP9DU(P,,ED,T,5)
IF X]""
QUIT
+24 SET X=$$TRAN^BGP9DU(P,,ED,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLFLU,U)<X
SET BGPLFLU=$PIECE(X,U)_U_"CPT "_$PIECE(X,U,2)
+25 IF BGPLFLU]""
QUIT BGPLFLU_U_1
+26 ;contraindication new in 8.0
+27 FOR BGPZ=15,16,88,111
SET X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED)
IF X]""
QUIT
+28 IF X]""
QUIT X_U_3
+29 ;NMI refusal
+30 SET G=$$NMIREF^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",88,0)),$$DOB^AUPNPAT(P),ED)
+31 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+32 SET G=$$NMIREF^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",111,0)),$$DOB^AUPNPAT(P),ED)
+33 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+34 SET G=$$NMIREF^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",15,0)),$$DOB^AUPNPAT(P),ED)
+35 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+36 SET G=$$NMIREF^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",16,0)),$$DOB^AUPNPAT(P),ED)
+37 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+38 ;refusal
+39 SET G=$$REFUSAL^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",88,0)),$$FMADD^XLFDT(ED,-365),ED)
+40 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+41 SET G=$$REFUSAL^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",111,0)),$$FMADD^XLFDT(ED,-365),ED)
+42 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+43 SET G=$$REFUSAL^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",15,0)),$$FMADD^XLFDT(ED,-365),ED)
+44 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+45 SET G=$$REFUSAL^BGP9UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",16,0)),$$FMADD^XLFDT(ED,-365),ED)
+46 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+47 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",88,0))
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+48 SET R=$PIECE(^BIPC(X,0),U,3)
+49 IF R=""
QUIT
+50 IF '$DATA(^BICONT(R,0))
QUIT
+51 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+52 SET D=$PIECE(^BIPC(X,0),U,4)
+53 IF D=""
QUIT
+54 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+55 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+56 SET G=1
End DoDot:1
+57 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+58 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",111,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+59 SET R=$PIECE(^BIPC(X,0),U,3)
+60 IF R=""
QUIT
+61 IF '$DATA(^BICONT(R,0))
QUIT
+62 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+63 SET D=$PIECE(^BIPC(X,0),U,4)
+64 IF D=""
QUIT
+65 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+66 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+67 SET G=1
End DoDot:1
+68 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+69 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",15,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+70 SET R=$PIECE(^BIPC(X,0),U,3)
+71 IF R=""
QUIT
+72 IF '$DATA(^BICONT(R,0))
QUIT
+73 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+74 SET D=$PIECE(^BIPC(X,0),U,4)
+75 IF D=""
QUIT
+76 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+77 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+78 SET G=1
End DoDot:1
+79 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+80 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",16,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+81 SET R=$PIECE(^BIPC(X,0),U,3)
+82 IF R=""
QUIT
+83 IF '$DATA(^BICONT(R,0))
QUIT
+84 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+85 SET D=$PIECE(^BIPC(X,0),U,4)
+86 IF D=""
QUIT
+87 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+88 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+89 SET G=1
End DoDot:1
+90 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+91 QUIT ""
FLCONT(P,C,BD,ED) ;EP
+1 NEW X,G,Y,R,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Egg Allergy"
SET G=D_U_"Contraindication: Egg Allergy"
+11 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contraindication: Anaphylaxis"
End DoDot:1
+12 QUIT G
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<21
QUIT 0
+3 IF AGEE>64
QUIT 0
+4 IF $$HYSTER(P,EDATE)
QUIT 0
+5 QUIT 1
PAP(P,EDATE,YEARS) ;EP
+1 KILL BGPC
+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^BGP9UTL1(P,T,BDATE,EDATE)
IF X
IF $PIECE(BGPLPAP,U,2)<$PIECE(X,U,3)
SET BGPLPAP="1^"_$PIECE(X,U,3)_"^"_$PIECE(X,U,2)
+23 KILL BGP
SET %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGP(")
+24 IF $DATA(BGP(1))
IF $PIECE(BGPLPAP,U,2)<$PIECE(BGP(1),U,1)
SET BGPLPAP="1^"_$PIECE(BGP(1),U)_"^91.46"
+25 SET T=$ORDER(^ATXAX("B","BGP CPT PAP",0))
+26 IF T
Begin DoDot:1
+27 SET X=$$CPT^BGP9DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)
IF X]""
QUIT
+28 SET X=$$TRAN^BGP9DU(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)_"^"_$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^BGP9DU(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 SET T=$$REFUSAL^BGP9UTL1(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+34 IF T
QUIT "1^"_$PIECE(T,U,2)_"^ref"
+35 SET BGPLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+36 IF 'BGPLT
QUIT 0
+37 SET X=0
SET T=""
FOR
SET X=$ORDER(^ATXLAB(BGPLT,21,X))
IF X'=+X!($PIECE(T,U)=1)
QUIT
Begin DoDot:1
+38 SET T=""
+39 SET Y=$PIECE(^ATXLAB(BGPLT,21,X,0),U)
+40 IF 'Y
QUIT
+41 SET T=$$REFUSAL^BGP9UTL1(P,60,Y,$$FMADD^XLFDT(EDATE,-365),EDATE)
End DoDot:1
+42 IF T
QUIT 1_"^"_$PIECE(T,U,2)_"^ref"
+43 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 SET X=$$LASTPRC^BGP9UTL1(P,"BGP HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+3 IF X
QUIT 1
+4 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+5 IF T
Begin DoDot:1
+6 SET X=$$WH^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
End DoDot:1
IF X]""
QUIT 1
+7 SET T=$ORDER(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
+8 IF T
Begin DoDot:1
+9 SET X=$$CPT^BGP9DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
IF X]""
QUIT
+10 SET X=$$TRAN^BGP9DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
End DoDot:1
IF X]""
QUIT 1
+11 SET X=$$LASTDXI^BGP9UTL1(P,618.5,$$DOB^AUPNPAT(P),EDATE,1)
+12 IF X
QUIT 1
+13 QUIT ""
