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)
SET BGPLPNU=$PIECE(%,U,1)_U_$PIECE(%,U,2)
+35 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+36 ;NOW CHECK FOR CONTRAINDICATION (NEW IN 8.0)
+37 FOR BGPZ=33,100,109,133
SET X=$$ANCONT(P,BGPZ,ED)
IF X]""
QUIT
+38 IF X]""
QUIT X_U_3
+39 ;NMI refusal
+40 SET G=$$NMIREF^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",33,0)),$$DOB^AUPNPAT(P),ED)
+41 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+42 SET G=$$NMIREF^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P),ED)
+43 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+44 SET G=$$NMIREF^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P),ED)
+45 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+46 SET G=$$NMIREF^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",133,0)),$$DOB^AUPNPAT(P),ED)
+47 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+48 IF $GET(FORE)
QUIT ""
+49 SET G=$$REFUSAL^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",33,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)
+50 IF $PIECE(G,U)=1
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_" Refused"_U_2
+51 SET G=$$REFUSAL^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",100,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)
+52 IF $PIECE(G,U)=1
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_" Refused"_U_2
+53 SET G=$$REFUSAL^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",109,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)
+54 IF $PIECE(G,U)=1
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_" Refused"_U_2
+55 SET G=$$REFUSAL^BGP0UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",133,0)),$$FMTE^XLFDT($$FMADD^XLFDT(ED,-365)),EDATE)
+56 IF $PIECE(G,U)=1
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_" Refused"_U_2
+57 SET BGPRBEG=$$FMADD^XLFDT(ED,-365)
+58 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",33,0))
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)<BGPRBEG
QUIT
+66 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+67 SET G=1
End DoDot:1
+68 IF G
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_"Refusal Imm pkg"_U_2
+69 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",100,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)<BGPRBEG
QUIT
+77 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+78 SET G=1
End DoDot:1
+79 IF G
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_"Refusal Imm pkg"_U_2
+80 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",133,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)<BGPRBEG
QUIT
+88 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+89 SET G=1
End DoDot:1
+90 IF G
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_"Refusal Imm pkg"_U_2
+91 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",109,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+92 SET R=$PIECE(^BIPC(X,0),U,3)
+93 IF R=""
QUIT
+94 IF '$DATA(^BICONT(R,0))
QUIT
+95 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+96 SET D=$PIECE(^BIPC(X,0),U,4)
+97 IF $PIECE(^BIPC(X,0),U,4)<BGPRBEG
QUIT
+98 IF D=""
QUIT
+99 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+100 SET G=1
End DoDot:1
+101 IF G
IF $PIECE(BGPLPNU,U,1)<$PIECE(G,U,2)
SET BGPLPNU=$PIECE(G,U,2)_U_"Refusal Imm pkg"_U_2
+102 QUIT BGPLPNU
+103 ;
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_"Contraindication: 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_"Contraindication: Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Contraindication: Neomycin Allergy"
End DoDot:1
+12 QUIT G
MMRCONT(P,C,ED) ;EP - ANALPHYLAXIS/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_"Contraindication: Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Contraindication: Neomycin Allergy"
+12 IF $PIECE(^BICONT(R,0),U,1)="Immune Deficiency"
SET G=D_U_"Contraindication: Immune Deficiency"
+13 IF $PIECE(^BICONT(R,0),U,1)["Immune Deficient"
SET G=D_U_"Contraindication: Immune Deficient"
End DoDot:1
+14 QUIT G
