BGP4D31 ; IHS/CMI/LAB - measure C 01 Jun 2014 12:51 PM ; 01 Nov 2013 6:34 PM
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
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^BGP4UTL($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^BGP4UTL2(%,T,9) S G=1,H=$P($P(^AUPNVSIT(V,0),U),".")
.Q
I G Q 1_U_"ER/UC:"_$$DATE^BGP1UTL(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^BGP4UTL2(%,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^BGP4UTL($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=""
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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:'$$ICD^BGP4UTL2(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^BGP4UTL(9999999-D)
Q ""
;
SEV(P,BDATE,EDATE) ;EP
NEW S,A,B,T,X,G,V,Y
S G=""
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
.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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:'$$ICD^BGP4UTL2(Y,T,9)
.Q:$P(^AUPNPROB(X,0),U,15)=""
.S G(9999999-$P(^AUPNPROB(X,0),U,3))=$P(^AUPNPROB(X,0),U,15)
.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^BGP4UTL(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^BGP4UTL($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^BGP4UTL2(%,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"
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^BGP4DU(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^BGP4DU(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 S X=$$ANCONT(P,BGPZ,ED) Q:X]""
I X]"" Q X_U_3
;NMI Refusal
S G=$$NMIREF^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(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
Q ""
;
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_"Contra 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_"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
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
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
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"
Q G
BGP4D31 ; IHS/CMI/LAB - measure C 01 Jun 2014 12:51 PM ; 01 Nov 2013 6:34 PM
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+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^BGP4UTL($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^BGP4UTL2(%,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^BGP1UTL(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^BGP4UTL2(%,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^BGP4UTL($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=""
+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)="D"
QUIT
+26 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+27 IF '$$ICD^BGP4UTL2(Y,T,9)
QUIT
+28 IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+29 IF $PIECE(^AUPNPROB(X,0),U,15)<2
QUIT
+30 SET G=1_U_"Severity "_$PIECE(^AUPNPROB(X,0),U,15)_" on PL"
+31 QUIT
End DoDot:1
+32 IF G
QUIT G
+33 SET EDATE1=9999999-EDATE-1
+34 SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))
+35 IF 'D
QUIT ""
+36 ;I D>(9999999-BDATE) Q ""
+37 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+38 IF 'LAST
QUIT ""
+39 SET S=^AUPNVAST("AS",P,D,LAST)
+40 IF S>1
QUIT 1_U_"Severity "_S_" on visit "_$$DATE^BGP4UTL(9999999-D)
+41 QUIT ""
+42 ;
SEV(P,BDATE,EDATE) ;EP
+1 NEW S,A,B,T,X,G,V,Y
+2 SET G=""
+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,8)>EDATE
QUIT
+6 SET Y=$PIECE(^AUPNPROB(X,0),U)
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 IF '$$ICD^BGP4UTL2(Y,T,9)
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+11 SET G(9999999-$PIECE(^AUPNPROB(X,0),U,3))=$PIECE(^AUPNPROB(X,0),U,15)
+12 QUIT
End DoDot:1
+13 SET X=$ORDER(G(0))
IF X
QUIT G(X)
+14 SET EDATE1=9999999-EDATE-1
+15 SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))
+16 IF 'D
QUIT ""
+17 ;I D>(9999999-BDATE) Q ""
+18 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+19 IF 'LAST
QUIT ""
+20 SET S=^AUPNVAST("AS",P,D,LAST)
+21 QUIT S
+22 ;I S>1 Q 1_U_"Severity "_S_" on visit "_$$DATE^BGP4UTL(9999999-D)
+23 ;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^BGP4UTL($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^BGP4UTL2(%,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 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^BGP4DU(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^BGP4DU(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
SET X=$$ANCONT(P,BGPZ,ED)
IF X]""
QUIT
+26 IF X]""
QUIT X_U_3
+27 ;NMI Refusal
+28 SET G=$$NMIREF^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(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^BGP4UTL1(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 QUIT ""
+37 ;
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION
+1 NEW X
+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
+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
+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
+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
+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)="Egg Allergy"
SET G=D_U_"Contra: Egg Allergy"
End DoDot:1
+12 QUIT G
