BGP0D31.m

BGP0D31 ; IHS/CMI/LAB - measure C 01 Jun 2010 12:51 PM ;

 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010

 ;

II ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPHOSP)=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,BGP365,BGPEDATE)

 I BGPN1 S BGPHOSP=$$HOSP(DFN,BGP365,BGPEDATE) I BGPHOSP S BGPN2=1

 S Z=$P(BGPN1,U,2)

 S BGPVALUE=$S(BGPD2:"AC",1:"")_"|||" I BGPN1 S BGPVALUE=BGPVALUE_Z_" "_$S(BGPHOSP:"H "_$$DATE^BGP0UTL($P(BGPHOSP,U,2)),1:"")

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T

 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^ATXCHK(%,T,9) S D=1

 .Q:'D

 .S $P(G,U)=$P(G,U)+1,$P(G,U,2)=$P(G,U,2)_" "_$$DATE^BGP0UTL($P(^TMP($J,"A",X),U))

 .Q

 I G>1 Q 1_U_"2 Dxs PCC: "_$P(G,U,2)

 ;

 NEW S,A,B,T,X,G,V,Y

 S G=""

 S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))

 S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D

 .Q:$P(^AUPNPROB(X,0),U,8)>EDATE  ;if added to pl after end of time period

 .S Y=$P(^AUPNPROB(X,0),U)

 .Q:$P(^AUPNPROB(X,0),U,12)'="A"

 .Q:'$$ICD^ATXCHK(Y,T,9)

 .Q:$P(^AUPNPROB(X,0),U,15)=""

 .Q:$P(^AUPNPROB(X,0),U,15)<2

 .S G=1_U_"Severity "_$P(^AUPNPROB(X,0),U,15)_" on PL"

 .Q

 I G Q G

 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)

 I S>1 Q 1_U_"Severity "_S_" on visit "_$$DATE^BGP0UTL(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^BGP0UTL($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^ATXCHK(%,T,9) S G=1,H=$P($P(^AUPNVSIT(V,0),U),".")

 .Q

 Q G_"^"_H

BI() ;

 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"

 K BGPG S %=P_"^LAST PROCEDURE 99.55;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_"99.55"

 K BGPG S %=P_"^LAST DX V03.82;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_"V03.82"

 ;K BGPG S %=P_"^LAST DX V03.89;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_"V03.89"

 K BGPG S %=P_"^LAST DX V06.6;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_"V06.6"

 ;S %="",E=+$$CODEN^ICPTCOD(90732),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90732"

 ;S %="",E=+$$CODEN^ICPTCOD(90669),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90669"

 ;S %="",E=+$$CODEN^ICPTCOD(90732),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90732 TRAN"

 ;S %="",E=+$$CODEN^ICPTCOD(90669),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90669 TRAN"

 ;S %="",E=+$$CODEN^ICPTCOD("G0009"),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G0009"

 ;S %="",E=+$$CODEN^ICPTCOD("G8115"),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G8115"

 ;S %="",E=+$$CODEN^ICPTCOD("G0009"),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G0009 TRAN"

 ;S %="",E=+$$CODEN^ICPTCOD("G8115"),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G8115 TRAN"

 S %=$$CPT^BGP0DU(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_$P(%,U,2)

 S %=$$TRAN^BGP0DU(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_$P(%,U,2)

 I BGPLPNU]"" Q BGPLPNU_U_1

 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)

 F BGPZ=33,100,109,133 S X=$$ANCONT(P,BGPZ,ED) Q:X]""

 I X]"" Q X_U_3

 ;NMI refusal

 S G=$$NMIREF^BGP0UTL1(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^BGP0UTL1(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^BGP0UTL1(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^BGP0UTL1(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

 I $G(FORE) Q ""

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",33,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)

 I $P(G,U)=1 I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_" Refused"_U_2

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",100,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)

 I $P(G,U)=1 I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_" Refused"_U_2

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",109,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)

 I $P(G,U)=1 I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_" Refused"_U_2

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",133,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)

 I $P(G,U)=1 I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_" Refused"_U_2

 S BGPRBEG=$$FMADD^XLFDT(ED,-365)

 S (X,G)=0,Y=$O(^AUTTIMM("C",33,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)<BGPRBEG

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_"Refusal Imm pkg"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",100,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)<BGPRBEG

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_"Refusal Imm pkg"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",133,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)<BGPRBEG

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_"Refusal Imm pkg"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",109,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:$P(^BIPC(X,0),U,4)<BGPRBEG

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G I $P(BGPLPNU,U,1)<$P(G,U,2) S BGPLPNU=$P(G,U,2)_U_"Refusal Imm pkg"_U_2

 Q BGPLPNU

 ;

ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION

 NEW X

 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_"Contraindication: Anaphylaxis"

 Q G

ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION

 NEW X

 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_"Contraindication: Anaphylaxis"

 .I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Contraindication: Neomycin Allergy"

 Q G

MMRCONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN/IMMUNE CONTRAINDICATION

 NEW X

 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_"Contraindication: Anaphylaxis"

 .I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Contraindication: Neomycin Allergy"

 .I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Contraindication: Immune Deficiency"

 .I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Contraindication: Immune Deficient"

 Q G

BGP0D31   ; IHS/CMI/LAB - measure C 01 Jun 2010 12:51 PM ;

 +1       ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010

 +2       ;

II        ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPHOSP)=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,BGP365,BGPEDATE)

 +7        IF BGPN1

               SET BGPHOSP=$$HOSP(DFN,BGP365,BGPEDATE)

               IF BGPHOSP

                   SET BGPN2=1

 +8        SET Z=$PIECE(BGPN1,U,2)

 +9        SET BGPVALUE=$SELECT(BGPD2:"AC",1:"")_"|||"

           IF BGPN1

               SET BGPVALUE=BGPVALUE_Z_" "_$SELECT(BGPHOSP:"H "_$$DATE^BGP0UTL($PIECE(BGPHOSP,U,2)),1:"")

 +10       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T

 +11       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^ATXCHK(%,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)_" "_$$DATE^BGP0UTL($PIECE(^TMP($JOB,"A",X),U))

 +16               QUIT 

               End DoDot:1

 +17       IF G>1

               QUIT 1_U_"2 Dxs PCC: "_$PIECE(G,U,2)

 +18      ;

 +19       NEW S,A,B,T,X,G,V,Y

 +20       SET G=""

 +21       SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))

 +22       SET (X,G)=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X!(G)

                   QUIT 

               Begin DoDot:1

 +23      ;if added to pl after end of time period

                   IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE

                       QUIT 

 +24               SET Y=$PIECE(^AUPNPROB(X,0),U)

 +25               IF $PIECE(^AUPNPROB(X,0),U,12)'="A"

                       QUIT 

 +26               IF '$$ICD^ATXCHK(Y,T,9)

                       QUIT 

 +27               IF $PIECE(^AUPNPROB(X,0),U,15)=""

                       QUIT 

 +28               IF $PIECE(^AUPNPROB(X,0),U,15)<2

                       QUIT 

 +29               SET G=1_U_"Severity "_$PIECE(^AUPNPROB(X,0),U,15)_" on PL"

 +30               QUIT 

               End DoDot:1

 +31       IF G

               QUIT G

 +32       SET EDATE1=9999999-EDATE-1

 +33       SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))

 +34       IF 'D

               QUIT ""

 +35      ;I D>(9999999-BDATE) Q ""

 +36       SET LAST=""

           SET E=0

           FOR 

               SET E=$ORDER(^AUPNVAST("AS",P,D,E))

               IF E'=+E

                   QUIT 

               SET LAST=E

 +37       IF 'LAST

               QUIT ""

 +38       SET S=^AUPNVAST("AS",P,D,LAST)

 +39       IF S>1

               QUIT 1_U_"Severity "_S_" on visit "_$$DATE^BGP0UTL(9999999-D)

 +40       QUIT ""

 +41      ;

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^BGP0UTL($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^ATXCHK(%,T,9)

                       SET G=1

                       SET H=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")

 +14               QUIT 

               End DoDot:1

 +15       QUIT G_"^"_H

BI()      ;

 +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       KILL BGPG

           SET %=P_"^LAST PROCEDURE 99.55;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPG(")

 +16       IF $DATA(BGPG(1))

               IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)

                   SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"99.55"

 +17       KILL BGPG

           SET %=P_"^LAST DX V03.82;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_"V03.82"

 +19      ;K BGPG S %=P_"^LAST DX V03.89;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 +20      ;I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"V03.89"

 +21       KILL BGPG

           SET %=P_"^LAST DX V06.6;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPG(")

 +22       IF $DATA(BGPG(1))

               IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)

                   SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"V06.6"

 +23      ;S %="",E=+$$CODEN^ICPTCOD(90732),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90732"

 +24      ;S %="",E=+$$CODEN^ICPTCOD(90669),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90669"

 +25      ;S %="",E=+$$CODEN^ICPTCOD(90732),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90732 TRAN"

 +26      ;S %="",E=+$$CODEN^ICPTCOD(90669),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"90669 TRAN"

 +27      ;S %="",E=+$$CODEN^ICPTCOD("G0009"),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G0009"

 +28      ;S %="",E=+$$CODEN^ICPTCOD("G8115"),%=$$CPTI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G8115"

 +29      ;S %="",E=+$$CODEN^ICPTCOD("G0009"),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G0009 TRAN"

 +30      ;S %="",E=+$$CODEN^ICPTCOD("G8115"),%=$$TRANI^BGP0DU(P,BD,ED,E) I %]"",$P(BGPLPNU,U,1)<$P(%,U,2) S BGPLPNU=$P(%,U,2)_U_"G8115 TRAN"

 +31       SET %=$$CPT^BGP0DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),5)

 +32       IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)

               SET BGPLPNU=$PIECE(%,U,1)_U_$PIECE(%,U,2)

 +33       SET %=$$TRAN^BGP0DU(P,BD,ED,$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),5)

 +34       IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)