BGP8D31.m

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 ""