BGP8D31 ;IHS/CMI/LAB - MEASURE LOGIC;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
II ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPHOSP,BGPSEV,BGPNER)=0
I 'BGPACTUP S BGPSTOP=1 Q
I BGPACTUP S BGPD1=1
I BGPACTCL S BGPD2=1
I 'BGPD2 S BGPSTOP=1 Q
S BGPN1=$$V2ASTH(DFN,BGPBDATE,BGPEDATE)
I BGPN1 S BGPHOSP=$$HOSP(DFN,BGPBDATE,BGPEDATE) I BGPHOSP S BGPN2=1
S BGPNER=$$ERURG(DFN,BGPBDATE,BGPEDATE)
I $P(BGPNER,U,1) S BGPN3=1
S BGPSEV=$$SEV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPSEV=1 S BGPN4=1
I BGPSEV=2 S BGPN5=1
I BGPSEV=3 S BGPN6=1
I BGPSEV=4 S BGPN7=1
I BGPSEV="" S BGPN8=1
S Z=$P(BGPN1,U,2)
S BGPVALUE=$S(BGPD2:"AC",1:"")_"|||" I BGPN1 S BGPVALUE=BGPVALUE_Z_$S(BGPHOSP:"; Hospital: "_$$DATE^BGP8UTL($P(BGPHOSP,U,2)),1:"")_$S(BGPN3:"; "_$P(BGPNER,U,2),1:"")_$S(BGPSEV:"; Severity: "_BGPSEV,1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q
ERURG(P,BDATE,EDATE) ;EP
NEW A,E,T,X,G,V,D
I '$G(P) Q ""
I '$D(^AUPNVSIT("AC",P)) Q ""
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
I 'T Q ""
S X=0,G=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"AORS"'[$P(^AUPNVSIT(V,0),U,7)
.S C=$$CLINIC^APCLV(V,"C")
.I C'=30,C'=80 Q ;er and urgent only
.S %=$$PRIMPOV^APCLV(V,"I") I $$ICD^BGP8UTL2(%,T,9) S G=1,H=$P($P(^AUPNVSIT(V,0),U),".")
.Q
I G Q 1_U_"ER/UC:"_$$DATE^BGP8UTL(H)
Q ""
V2ASTH(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
I '$D(^AUPNVSIT("AC",P)) Q ""
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
I 'T Q ""
S X=0,G=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G>1) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^BGP8UTL2(%,T,9) S D=1
.Q:'D
.S $P(G,U)=$P(G,U)+1,$P(G,U,2)=$P(G,U,2)_$S(G>1:", ",1:" ")_$$DATE^BGP8UTL($P(^TMP($J,"A",X),U))
.Q
I G>1 Q 1_U_"2 Dx PCC:"_$P(G,U,2)
;
NEW S,A,B,T,X,G,V,Y
S G=$$ASSEV^BGP8D22(P,EDATE)
I G Q G
Q ""
;
SEV(P,BDATE,EDATE) ;EP
NEW S,A,B,T,X,G,V,Y,OUT,SNT
S SNT="PXRM ASTHMA"
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.I $P(^AUPNPROB(X,0),U,13)="" Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end of time period
.Q:$P(^AUPNPROB(X,0),U,13)>EDATE ;doo
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.;Q:$P(^AUPNPROB(X,0),U,15)="" ;no severity
.I $$ICD^BGP8UTL2(Y,T,9) G SEVS
.S S=$$VALI^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SNT,S)) G SEVS
.Q
SEVS .I $P(^AUPNPROB(X,0),U,15)]"" S G(9999999-$P(^AUPNPROB(X,0),U,3))=$P(^AUPNPROB(X,0),U,15) Q
.S Y=0 F S Y=$O(^AUPNPROB(X,13,Y)) Q:Y'=+Y D
..I $P($G(^AUPNPROB(X,13,Y,0)),U,1)>0,$P($G(^AUPNPROB(X,13,Y,0)),U,1)<5 S G(9999999-$P(^AUPNPROB(X,0),U,3))=$P(^AUPNPROB(X,13,Y,0),U,1) Q
.Q
S X=$O(G(0)) I X Q G(X)
S EDATE1=9999999-EDATE-1
S D=$O(^AUPNVAST("AS",P,EDATE1))
I 'D Q ""
;I D>(9999999-BDATE) Q ""
S LAST="",E=0 F S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E S LAST=E
I 'LAST Q ""
S S=^AUPNVAST("AS",P,D,LAST)
Q S
;I S>1 Q 1_U_"Severity "_S_" on visit "_$$DATE^BGP8UTL(9999999-D)
;Q ""
LAST(P,BDATE,EDATE) ;EP last asthma dx
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP ASTHMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q $$DATE^BGP8UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)
Q ""
HOSP(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
I '$D(^AUPNVSIT("AC",P)) Q ""
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
I 'T Q ""
S (X,G,H)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:$P(^AUPNVSIT(V,0),U,7)'="H"
.S %=$$PRIMPOV^APCLV(V,"I") I $$ICD^BGP8UTL2(%,T,9) S G=1,H=$P($P(^AUPNVSIT(V,0),U),".")
.Q
Q G_"^"_H
BI() ;EP
Q $S($O(^AUTTIMM(0))>100:1,1:0)
PNEU(P,BDATE,EDATE,FORE) ;EP
K BGPG
S BGPLPNU=""
S BD=BDATE
S ED=EDATE
S EDATE=$$FMTE^XLFDT(EDATE)
S BDATE=$$FMTE^XLFDT(BDATE)
S X=P_"^LAST IMM "_$S($$BI:33,1:19)_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) S BGPLPNU=$P(BGPG(1),U)_U_"Imm 33"
S X=P_"^LAST IMM 100;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 100"
S X=P_"^LAST IMM 109;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 109"
S X=P_"^LAST IMM 133;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 133"
S X=P_"^LAST IMM 152;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 152"
K BGPG S %=P_"^LAST DX [BGP PNEUMO IZ DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"POV "_$P(BGPG(1),U,2)
S %=$$CPT^BGP8DU(P,BD,ED,$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
S %=$$TRAN^BGP8DU(P,BD,ED,$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
I BGPLPNU]"" Q BGPLPNU_U_1
;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
F BGPZ=33,100,109,133,152 S X=$$ANCONT(P,BGPZ,ED) Q:X]""
I X]"" Q X_U_3
;NMI Refusal
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",33,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",133,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",152,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),"N")
I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3
Q ""
;
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION
NEW X,Y,R,G,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)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
Q G
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION
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)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Contra: Neomycin Allergy"
.I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Contra: Immune Deficiency"
Q G
MMRCONT(P,C,ED) ;EP - ANApHYLAXIS/NEOMYCIN/IMMUNE CONTRAINDICATION
NEW X,Y,G,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)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Contra: Neomycin Allergy"
.I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Contra: Immune Deficiency"
.;I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Contra: Immune Deficient"
Q G
ANIMCONT(P,C,ED) ;EP - ANApHYLAXIS/IMMUNE CONTRAINDICATION
NEW X,Y,R,D,G
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)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Contra: Immune Deficiency"
.;I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Contra: Immune Deficient"
Q G
ANEGCONT(P,C,ED) ;EP - ANALPHYLAXIS/EGG CONTRAINDICATION
NEW X,Y,G,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)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
.;I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Contra: Egg Allergy" REMOVED V18
Q G
PAPHPV(P,EDATE,YEARS) ;EP - PAP AND HPV ON THE SAME DAY
NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP,BGPAPAP,BGPG,BGPAHPV
;CHECK WH FOR PAP SMEAR WITH HPV SET TO YES
S BGPLPAP=""
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^BGP8D3(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
;GATHER UP ALL PAP SMEARS BY DATE
;BGPAPAP(INVERSE DATE)=1^INTERNAL DATE^VALUE
S BGPC=""
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) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X 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 BGPAPAP(D)="1^"_(9999999-D)_"^Lab" Q
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPAPAP(D)="1^"_(9999999-D)_"^Lab" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPAPAP(D)="1^"_(9999999-D)_"^Lab-loinc" Q
...Q
K BGPG
S X=P_"^ALL DX [BGP PAP SMEAR DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPAPAP(9999999-$P(BGPG(X),U,1))="1^"_$P(BGPG(X),U,1)_"^POV "_$P(BGPG(X),U,2)
S T=$O(^ATXAX("B","BGP CPT PAP",0))
;ADD IN ALL CPT CODES
K BGPG
D ALLCPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CPT PAP",0)),"BGPG")
;reorder by date
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPAPAP(9999999-$P(BGPG(X),U,1))="1^"_$P(BGPG(X),U,1)_"CPT "_$P(BGPG(X),U,2)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
;ADD IN ALL WH PAP SMEAR
;go through procedures in a date range for this patient, check proc type
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
.S BGPAPAP(9999999-D)="1^"_D_"^"_"WH PAP SMEAR"
;GATHER UP ALL HPV TESTS
HPV ;
S BGPC=""
K BGPAHPV
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) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPAHPV(D)="1^"_(9999999-D)_"^Lab" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPAHPV(D)="1^"_(9999999-D)_"^Lab-loinc" Q
...Q
K BGPG
S X=P_"^ALL DX [BGP HPV DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPAHPV(9999999-$P(BGPG(X),U,1))="1^"_$P(BGPG(X),U,1)_"^POV "_$P(BGPG(X),U,2)
S T=$O(^ATXAX("B","BGP HPV CPTS",0))
;ADD IN ALL CPT CODES
K BGPG
D ALLCPT^BGP8DU(P,BDATE,EDATE,T,"BGPG")
;reorder by date
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPAHPV(9999999-$P(BGPG(X),U,1))="1^"_$P(BGPG(X),U,1)_"CPT "_$P(BGPG(X),U,2)
S T="HPV SCREEN",T=$O(^BWPN("B",T,0))
;ADD IN ALL WH HV SCREENS
;go through procedures in a date range for this patient, check proc type
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
.S BGPAHPV(9999999-D)="1^"_D_"^"_"WH HPV SCREEN"
;LOOP ALL PAPS AND SEE IF HPV ON SAME DAY, IF SO CHECK AGAINST BGPLPAP AND IF LATER QUIT
S D=0 F S D=$O(BGPAPAP(D)) Q:D'=+D D
.I $D(BGPAHPV(D)),$P(BGPAPAP(D),U,2)>$P(BGPLPAP,U,2) S BGPLPAP="1^PAP&HPV 5YRS SAME DAY ^"_$$DATE^BGP8UTL($P(BGPAPAP(D),U,2))
Q BGPLPAP
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 ""
BGP8D31 ;IHS/CMI/LAB - MEASURE LOGIC;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
II ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPHOSP,BGPSEV,BGPNER)=0
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 IF BGPACTUP
SET BGPD1=1
+4 IF BGPACTCL
SET BGPD2=1
+5 IF 'BGPD2
SET BGPSTOP=1
QUIT
+6 SET BGPN1=$$V2ASTH(DFN,BGPBDATE,BGPEDATE)
+7 IF BGPN1
SET BGPHOSP=$$HOSP(DFN,BGPBDATE,BGPEDATE)
IF BGPHOSP
SET BGPN2=1
+8 SET BGPNER=$$ERURG(DFN,BGPBDATE,BGPEDATE)
+9 IF $PIECE(BGPNER,U,1)
SET BGPN3=1
+10 SET BGPSEV=$$SEV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+11 IF BGPSEV=1
SET BGPN4=1
+12 IF BGPSEV=2
SET BGPN5=1
+13 IF BGPSEV=3
SET BGPN6=1
+14 IF BGPSEV=4
SET BGPN7=1
+15 IF BGPSEV=""
SET BGPN8=1
+16 SET Z=$PIECE(BGPN1,U,2)
+17 SET BGPVALUE=$SELECT(BGPD2:"AC",1:"")_"|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_Z_$SELECT(BGPHOSP:"; Hospital: "_$$DATE^BGP8UTL($PIECE(BGPHOSP,U,2)),1:"")_$SELECT(BGPN3:"; "_$PIECE(BGPNER,U,2),1:"")_$SELECT(BGPSEV:"; Severity: "_BGPSEV,1:"")
+18 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+19 QUIT
ERURG(P,BDATE,EDATE) ;EP
+1 NEW A,E,T,X,G,V,D
+2 IF '$GET(P)
QUIT ""
+3 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+7 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+8 IF 'T
QUIT ""
+9 SET X=0
SET G=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 IF "AORS"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 SET C=$$CLINIC^APCLV(V,"C")
+15 ;er and urgent only
IF C'=30
IF C'=80
QUIT
+16 SET %=$$PRIMPOV^APCLV(V,"I")
IF $$ICD^BGP8UTL2(%,T,9)
SET G=1
SET H=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+17 QUIT
End DoDot:1
+18 IF G
QUIT 1_U_"ER/UC:"_$$DATE^BGP8UTL(H)
+19 QUIT ""
V2ASTH(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+6 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+7 IF 'T
QUIT ""
+8 SET X=0
SET G=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G>1)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+12 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+13 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^BGP8UTL2(%,T,9)
SET D=1
+14 IF 'D
QUIT
+15 SET $PIECE(G,U)=$PIECE(G,U)+1
SET $PIECE(G,U,2)=$PIECE(G,U,2)_$SELECT(G>1:", ",1:" ")_$$DATE^BGP8UTL($PIECE(^TMP($JOB,"A",X),U))
+16 QUIT
End DoDot:1
+17 IF G>1
QUIT 1_U_"2 Dx PCC:"_$PIECE(G,U,2)
+18 ;
+19 NEW S,A,B,T,X,G,V,Y
+20 SET G=$$ASSEV^BGP8D22(P,EDATE)
+21 IF G
QUIT G
+22 QUIT ""
+23 ;
SEV(P,BDATE,EDATE) ;EP
+1 NEW S,A,B,T,X,G,V,Y,OUT,SNT
+2 SET SNT="PXRM ASTHMA"
+3 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;if added to pl after end of time period
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+6 ;doo
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 ;Q:$P(^AUPNPROB(X,0),U,15)="" ;no severity
+11 IF $$ICD^BGP8UTL2(Y,T,9)
GOTO SEVS
+12 SET S=$$VALI^XBDIQ1(9000011,X,80001)
+13 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SNT,S))
GOTO SEVS
+14 QUIT
SEVS IF $PIECE(^AUPNPROB(X,0),U,15)]""
SET G(9999999-$PIECE(^AUPNPROB(X,0),U,3))=$PIECE(^AUPNPROB(X,0),U,15)
QUIT
+1 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB(X,13,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+2 IF $PIECE($GET(^AUPNPROB(X,13,Y,0)),U,1)>0
IF $PIECE($GET(^AUPNPROB(X,13,Y,0)),U,1)<5
SET G(9999999-$PIECE(^AUPNPROB(X,0),U,3))=$PIECE(^AUPNPROB(X,13,Y,0),U,1)
QUIT
End DoDot:2
+3 QUIT
End DoDot:1
+4 SET X=$ORDER(G(0))
IF X
QUIT G(X)
+5 SET EDATE1=9999999-EDATE-1
+6 SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))
+7 IF 'D
QUIT ""
+8 ;I D>(9999999-BDATE) Q ""
+9 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+10 IF 'LAST
QUIT ""
+11 SET S=^AUPNVAST("AS",P,D,LAST)
+12 QUIT S
+13 ;I S>1 Q 1_U_"Severity "_S_" on visit "_$$DATE^BGP8UTL(9999999-D)
+14 ;Q ""
LAST(P,BDATE,EDATE) ;EP last asthma dx
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP ASTHMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
QUIT $$DATE^BGP8UTL($PIECE(BGPG(1),U))_" "_$PIECE(BGPG(1),U,2)
+5 QUIT ""
HOSP(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+6 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+7 IF 'T
QUIT ""
+8 SET (X,G,H)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
QUIT
+13 SET %=$$PRIMPOV^APCLV(V,"I")
IF $$ICD^BGP8UTL2(%,T,9)
SET G=1
SET H=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+14 QUIT
End DoDot:1
+15 QUIT G_"^"_H
BI() ;EP
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
PNEU(P,BDATE,EDATE,FORE) ;EP
+1 KILL BGPG
+2 SET BGPLPNU=""
+3 SET BD=BDATE
+4 SET ED=EDATE
+5 SET EDATE=$$FMTE^XLFDT(EDATE)
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
+7 SET X=P_"^LAST IMM "_$SELECT($$BI:33,1:19)_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+8 IF $DATA(BGPG(1))
SET BGPLPNU=$PIECE(BGPG(1),U)_U_"Imm 33"
+9 SET X=P_"^LAST IMM 100;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+10 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 100"
+11 SET X=P_"^LAST IMM 109;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+12 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 109"
+13 SET X=P_"^LAST IMM 133;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+14 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 133"
+15 SET X=P_"^LAST IMM 152;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+16 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 152"
+17 KILL BGPG
SET %=P_"^LAST DX [BGP PNEUMO IZ DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+18 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"POV "_$PIECE(BGPG(1),U,2)
+19 SET %=$$CPT^BGP8DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),5)
+20 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+21 SET %=$$TRAN^BGP8DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),5)
+22 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+23 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+24 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+25 FOR BGPZ=33,100,109,133,152
SET X=$$ANCONT(P,BGPZ,ED)
IF X]""
QUIT
+26 IF X]""
QUIT X_U_3
+27 ;NMI Refusal
+28 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",33,0)),$$DOB^AUPNPAT(P),ED)
+29 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+30 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",100,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^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",109,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^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",133,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^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",152,0)),$$DOB^AUPNPAT(P),ED)
+37 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+38 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),"N")
+39 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+40 QUIT ""
+41 ;
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION
+1 NEW X,Y,R,G,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 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra Anaphylaxis"
End DoDot:1
+11 QUIT G
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION
+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 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Contra: Neomycin Allergy"
+12 IF $PIECE(^BICONT(R,0),U,1)="Immune Deficiency"
SET G=D_U_"Contra: Immune Deficiency"
End DoDot:1
+13 QUIT G
MMRCONT(P,C,ED) ;EP - ANApHYLAXIS/NEOMYCIN/IMMUNE CONTRAINDICATION
+1 NEW X,Y,G,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 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Contra: Neomycin Allergy"
+12 IF $PIECE(^BICONT(R,0),U,1)="Immune Deficiency"
SET G=D_U_"Contra: Immune Deficiency"
+13 ;I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Contra: Immune Deficient"
End DoDot:1
+14 QUIT G
ANIMCONT(P,C,ED) ;EP - ANApHYLAXIS/IMMUNE CONTRAINDICATION
+1 NEW X,Y,R,D,G
+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 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Immune Deficiency"
SET G=D_U_"Contra: Immune Deficiency"
+12 ;I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Contra: Immune Deficient"
End DoDot:1
+13 QUIT G
ANEGCONT(P,C,ED) ;EP - ANALPHYLAXIS/EGG CONTRAINDICATION
+1 NEW X,Y,G,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 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra Anaphylaxis"
+11 ;I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Contra: Egg Allergy" REMOVED V18
End DoDot:1
+12 QUIT G
PAPHPV(P,EDATE,YEARS) ;EP - PAP AND HPV ON THE SAME DAY
+1 NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP,BGPAPAP,BGPG,BGPAHPV
+2 ;CHECK WH FOR PAP SMEAR WITH HPV SET TO YES
+3 SET BGPLPAP=""
+4 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+5 IF T
Begin DoDot:1
+6 SET X=$$PAPHPVWH^BGP8D3(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"
+7 ;GATHER UP ALL PAP SMEARS BY DATE
+8 ;BGPAPAP(INVERSE DATE)=1^INTERNAL DATE^VALUE
+9 SET BGPC=""
+10 SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+11 SET T=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+12 SET BGPLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+13 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)
QUIT
Begin DoDot:1
+14 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+17 SET Z=$PIECE(^AUPNVLAB(X,0),U)
SET Z=$PIECE($GET(^LAB(60,Z,0)),U)
IF Z="PAP SMEAR"
SET BGPAPAP(D)="1^"_(9999999-D)_"^Lab"
QUIT
+18 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPAPAP(D)="1^"_(9999999-D)_"^Lab"
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC(J,T)
QUIT
+22 SET BGPAPAP(D)="1^"_(9999999-D)_"^Lab-loinc"
QUIT
+23 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+24 KILL BGPG
+25 SET X=P_"^ALL DX [BGP PAP SMEAR DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+26 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPAPAP(9999999-$PIECE(BGPG(X),U,1))="1^"_$PIECE(BGPG(X),U,1)_"^POV "_$PIECE(BGPG(X),U,2)
+27 SET T=$ORDER(^ATXAX("B","BGP CPT PAP",0))
+28 ;ADD IN ALL CPT CODES
+29 KILL BGPG
+30 DO ALLCPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CPT PAP",0)),"BGPG")
+31 ;reorder by date
+32 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPAPAP(9999999-$PIECE(BGPG(X),U,1))="1^"_$PIECE(BGPG(X),U,1)_"CPT "_$PIECE(BGPG(X),U,2)
+33 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+34 ;ADD IN ALL WH PAP SMEAR
+35 ;go through procedures in a date range for this patient, check proc type
+36 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+37 IF '$DATA(^BWPCD(V,0))
QUIT
+38 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+39 IF $$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
QUIT
+40 SET D=$PIECE(^BWPCD(V,0),U,12)
+41 IF D<BDATE
QUIT
+42 IF D>EDATE
QUIT
+43 SET BGPAPAP(9999999-D)="1^"_D_"^"_"WH PAP SMEAR"
End DoDot:1
+44 ;GATHER UP ALL HPV TESTS
HPV ;
+1 SET BGPC=""
+2 KILL BGPAHPV
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+4 SET T=$ORDER(^ATXAX("B","BGP HPV LOINC CODES",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","BGP HPV TESTS TAX",0))
+6 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)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPAHPV(D)="1^"_(9999999-D)_"^Lab"
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,T)
QUIT
+14 SET BGPAHPV(D)="1^"_(9999999-D)_"^Lab-loinc"
QUIT
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 KILL BGPG
+17 SET X=P_"^ALL DX [BGP HPV DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+18 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPAHPV(9999999-$PIECE(BGPG(X),U,1))="1^"_$PIECE(BGPG(X),U,1)_"^POV "_$PIECE(BGPG(X),U,2)
+19 SET T=$ORDER(^ATXAX("B","BGP HPV CPTS",0))
+20 ;ADD IN ALL CPT CODES
+21 KILL BGPG
+22 DO ALLCPT^BGP8DU(P,BDATE,EDATE,T,"BGPG")
+23 ;reorder by date
+24 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPAHPV(9999999-$PIECE(BGPG(X),U,1))="1^"_$PIECE(BGPG(X),U,1)_"CPT "_$PIECE(BGPG(X),U,2)
+25 SET T="HPV SCREEN"
SET T=$ORDER(^BWPN("B",T,0))
+26 ;ADD IN ALL WH HV SCREENS
+27 ;go through procedures in a date range for this patient, check proc type
+28 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+29 IF '$DATA(^BWPCD(V,0))
QUIT
+30 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+31 IF $$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
QUIT
+32 SET D=$PIECE(^BWPCD(V,0),U,12)
+33 IF D<BDATE
QUIT
+34 IF D>EDATE
QUIT
+35 SET BGPAHPV(9999999-D)="1^"_D_"^"_"WH HPV SCREEN"
End DoDot:1
+36 ;LOOP ALL PAPS AND SEE IF HPV ON SAME DAY, IF SO CHECK AGAINST BGPLPAP AND IF LATER QUIT
+37 SET D=0
FOR
SET D=$ORDER(BGPAPAP(D))
IF D'=+D
QUIT
Begin DoDot:1
+38 IF $DATA(BGPAHPV(D))
IF $PIECE(BGPAPAP(D),U,2)>$PIECE(BGPLPAP,U,2)
SET BGPLPAP="1^PAP&HPV 5YRS SAME DAY ^"_$$DATE^BGP8UTL($PIECE(BGPAPAP(D),U,2))
End DoDot:1
+39 QUIT BGPLPAP
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 ""
