BGP6ALG1 ; IHS/CMI/LAB - measure AHR.A ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
;
BETA ;EP - BETA BLOCKER CONTRAINDICATION/NMI REFUSAL
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW BGPC,BGPG,BGPY,Y,E,X,N,Z,T
S BGPC=0
BETAPOV ;
K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
.I N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF CARD RHYTH",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.Q
I BGPC>0 Q 1_U_BGPY(BGPC)
K BGPG S BGPC=0 S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I BGPC>0 Q 1_U_BGPY(BGPC)
;PL
S BGPC=0
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP6UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP6UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9)),N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP6UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I BGPC>0 Q 1_U_BGPY(BGPC)
;allergy
S BGPC=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["BETA BLOCK" S BGPC=BGPC+1,BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP6UTL($P(^GMR(120.8,X,0),U,4))_" "_N
I BGPC>0 Q 1_U_BGPY(BGPC)
Q ""
;
ASA ;EP aspirin allergy
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW BGPG,G,X,N,Z,Y,T,I,E
K BGPG
S G=""
S X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPG(X),U,4)
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S G=1_U_$$DATE^BGP6UTL($P(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF SALICYLATES",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.Q
I G Q G
S G=""
K BGPG S BGPG=$$LASTDX^BGP6UTL1(P,"BGP ADV EFF SALICYLATES 10",$$DOB^AUPNPAT(P),EDATE)
I BGPG S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG,U,3))_" ["_$P(BGPG,U,2)_"]"
I G Q G
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPG(X),U,4)
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S G=1_U_$$DATE^BGP6UTL($P(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N
.Q
I G Q G
;problem list
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP6UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP6UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9)),N["ASPIRIN"!(N["ASA") S G=1_U_$$DATE^BGP6UTL($P(^AUPNPROB(X,0),U,8))_" Problem List code "_$$VAL^XBDIQ1(9000011,X,.01)_" "_N
.Q
I G Q G
;allergy tracking
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ASPIRIN" S G=1_U_$$DATE^BGP6UTL($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
Q G
;
;
ACEI ;EP - ACE ALLERGY
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I
S G=""
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
.I N["ACEI"!(N["ACE I") S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.Q
I G Q G
S G=""
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ADV EFF ANTIHYPER 10;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"]"
I G Q G
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ACEI"!(N["ACE I") S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I G Q G
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP6UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;added after discharge date
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP6UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9)),N["ACEI"!(N["ACE I") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP6UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N Q
.I $$ICD^BGP6UTL2(I,$O(^ATXAX("B","BGP ADV EFF ANTIHYPER 10",0)),9) S G=1_U_"PROBLEM LIST: "_$$DATE^BGP6UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "
.Q
I G Q G
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after discharge date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ACEI"!(N["ACE INHIBITOR") S G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP6UTL($P(^GMR(120.8,X,0),U,4))_" "_N
I G Q G
Q ""
ARB ;EP - ARB ALLERGIES
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I,D,B
S G=""
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
.I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN ARB",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.Q
I G Q G
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I G Q G
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP6UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;added after discharge date
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP6UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9)),N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP6UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I G Q G
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP6UTL($P(^GMR(120.8,X,0),U,4))_" "_N
Q G
;
;
RESAL(Y) ;
NEW V,ULN
S V=+$P(Y,U,2),ULN=$P(Y,U,3)
I ULN="" Q ""
I V>(ULN*3) Q 1
Q ""
RESCK(Y) ;
NEW V,ULN
S V=+$P(^AUPNVLAB(X,0),U,4)
I V>10000 Q 1
S ULN=$P($G(^AUPNVLAB(X,11)),U,5)
I ULN="" Q 0
I V>(ULN*10) Q 1
Q 0
BGP6ALG1 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
+3 ;
BETA ;EP - BETA BLOCKER CONTRAINDICATION/NMI REFUSAL
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 NEW BGPC,BGPG,BGPY,Y,E,X,N,Z,T
+5 SET BGPC=0
BETAPOV ;
+1 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+2 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+3 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+4 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+5 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARD RHYTH",0))
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+9 QUIT
End DoDot:1
+10 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+11 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+12 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+13 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+14 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+15 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+16 ;PL
+17 SET BGPC=0
+18 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+19 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP6UTL2(I),U,2)
+21 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+22 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+23 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+24 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+25 IF $$ICD^BGP6UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9))
IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP6UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+26 QUIT
End DoDot:1
+27 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+28 ;allergy
+29 SET BGPC=0
+30 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+31 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+32 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+33 IF N["BETA BLOCK"
SET BGPC=BGPC+1
SET BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP6UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+34 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+35 QUIT ""
+36 ;
ASA ;EP aspirin allergy
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 NEW BGPG,G,X,N,Z,Y,T,I,E
+5 KILL BGPG
+6 SET G=""
+7 SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+8 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BGPG(X),U,4)
+10 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+11 IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N
QUIT
+12 SET T=$ORDER(^ATXAX("B","BGP ADV EFF SALICYLATES",0))
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+14 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+15 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+16 QUIT
End DoDot:1
+17 IF G
QUIT G
+18 SET G=""
+19 KILL BGPG
SET BGPG=$$LASTDX^BGP6UTL1(P,"BGP ADV EFF SALICYLATES 10",$$DOB^AUPNPAT(P),EDATE)
+20 IF BGPG
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG,U,3))_" ["_$PIECE(BGPG,U,2)_"]"
+21 IF G
QUIT G
+22 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+23 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+24 SET Y=+$PIECE(BGPG(X),U,4)
+25 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+26 IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N
+27 QUIT
End DoDot:1
+28 IF G
QUIT G
+29 ;problem list
+30 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+31 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+32 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP6UTL2(I),U,2)
+33 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+34 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+35 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+36 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+37 IF $$ICD^BGP6UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9))
IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP6UTL($PIECE(^AUPNPROB(X,0),U,8))_" Problem List code "_$$VAL^XBDIQ1(9000011,X,.01)_" "_N
+38 QUIT
End DoDot:1
+39 IF G
QUIT G
+40 ;allergy tracking
+41 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+42 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+43 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+44 IF N["ASPIRIN"
SET G=1_U_$$DATE^BGP6UTL($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+45 QUIT G
+46 ;
+47 ;
ACEI ;EP - ACE ALLERGY
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I
+5 SET G=""
+6 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+8 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+9 IF N["ACEI"!(N["ACE I")
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+10 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+12 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+14 QUIT
End DoDot:1
+15 IF G
QUIT G
+16 SET G=""
+17 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ADV EFF ANTIHYPER 10;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+18 IF $DATA(BGPG(1))
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"]"
+19 IF G
QUIT G
+20 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+21 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+22 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+23 IF N["ACEI"!(N["ACE I")
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+24 IF G
QUIT G
+25 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+26 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+27 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP6UTL2(I),U,2)
+28 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+29 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+30 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+31 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+32 IF $$ICD^BGP6UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9))
IF N["ACEI"!(N["ACE I")
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP6UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
QUIT
+33 IF $$ICD^BGP6UTL2(I,$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPER 10",0)),9)
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP6UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "
+34 QUIT
End DoDot:1
+35 IF G
QUIT G
+36 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+37 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+38 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+39 IF N["ACEI"!(N["ACE INHIBITOR")
SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP6UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+40 IF G
QUIT G
+41 QUIT ""
ARB ;EP - ARB ALLERGIES
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I,D,B
+5 SET G=""
+6 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+8 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+9 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+10 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN ARB",0))
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+12 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+14 QUIT
End DoDot:1
+15 IF G
QUIT G
+16 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+17 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+18 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+19 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+20 IF G
QUIT G
+21 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+22 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+23 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP6UTL2(I),U,2)
+24 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+25 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+26 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+27 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+28 IF $$ICD^BGP6UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9))
IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP6UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+29 QUIT
End DoDot:1
+30 IF G
QUIT G
+31 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+32 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+33 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+34 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP6UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+35 QUIT G
+36 ;
+37 ;
RESAL(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(Y,U,2)
SET ULN=$PIECE(Y,U,3)
+3 IF ULN=""
QUIT ""
+4 IF V>(ULN*3)
QUIT 1
+5 QUIT ""
RESCK(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(^AUPNVLAB(X,0),U,4)
+3 IF V>10000
QUIT 1
+4 SET ULN=$PIECE($GET(^AUPNVLAB(X,11)),U,5)
+5 IF ULN=""
QUIT 0
+6 IF V>(ULN*10)
QUIT 1
+7 QUIT 0
