BGP1CU1 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM 30 Oct 2009 11:26 AM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
ASAALLEG(P,BDATE,EDATE) ;EP does patient have an aspirin allergy documented on or before EDATE
;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
NEW BGPG,G,X,N,Z,Y,T,I
K BGPG
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
S G=""
S X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;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!(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^BGP1UTL($P(BGPG(X),U))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01) Q
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E935.3" S G=1_U_$$DATE^BGP1UTL($P(BGPG(X),U,1))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" w/E935.3 " Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E935.3" S G=1_U_$$DATE^BGP1UTL($P(BGPG(X),U,1))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" w/E935.3 " Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E935.3" S G=1_U_$$DATE^BGP1UTL($P(BGPG(X),U,1))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" w/E935.3 " Q
.Q
I G Q G ;found pov with ecode or narrative
K BGPG S Y="BGPG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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^BGP1UTL($P(BGPG(X),U))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)
.Q
I G Q G
;now check problem list for these codes
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^ICDCODE(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;added after discharge date
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ASPIRIN"!(N["ASA") S G=1_U_$$DATE^BGP1UTL($P(^AUPNPROB(X,0),U,8))_" Problem List "_$$VAL^XBDIQ1(9000011,X,.01) Q
I G Q G
;now check 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),".")<BDATE
.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["ASPIRIN" S G=1_U_$$DATE^BGP1UTL($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking "_N
Q G
;
ACEALLEG(P,BDATE,EDATE) ;EP
NEW ED,BD,BGPG,G,X,Y,Z,N
S G=""
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S G=1_U_"POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.6] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S G=1_U_"POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.6] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S G=1_U_"POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.6] "_N Q
.Q
I G Q G
K BGPG S Y="BGPG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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^BGP1UTL($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^ICDCODE(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;added after discharge date
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ACEI"!(N["ACE I") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP1UTL($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),".")<BDATE
.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^BGP1UTL($P(^GMR(120.8,X,0),U,4))_" "_N
Q G
;
ARBALLEG(P,BDATE,EDATE) ;EP
NEW ED,BD,BGPG,G,X,Y,Z,N
S G=""
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S G=1_U_"POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.6] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S G=1_U_"POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.6] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S G=1_U_"POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.6] "_N Q
.Q
I G Q G
K BGPG S Y="BGPG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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^BGP1UTL($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^ICDCODE(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;added after discharge date
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP1UTL($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),".")<BDATE
.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["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP1UTL($P(^GMR(120.8,X,0),U,4))_" "_N
Q G
;
SAORSTEN(P,BDATE,EDATE) ;EP
NEW BGPG,Y,E,X
K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP CMS AORTIC STENOSIS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_"POV: "_$$DATE^BGP1UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
Q ""
;
WARRX(P,BDATE,EDATE,EXP,BGPY) ;EP
;get active warfarin rx before date of adm
NEW BGPC,X,Y,Z,E
S BGPC=0
K BGPY
D GETMEDS^BGP1CU(P,BDATE,EDATE,"BGP CMS WARFARIN MEDS","BGP CMS WARFARIN MEDS NDC","BGP CMS WARFARIN MEDS CLASS",EXP,EDATE,"WARFARIN",0)
Q
;
NMIDRUG(P,BDATE,EDATE,BGPY,TAX,C) ;EP ;nmi in refusal file for aspirin or cpt/tran
;array returned is BGPY
NEW T,Z,Y,D,N
I $G(C)="" S C=0
S T=$O(^ATXAX("B",TAX,0))
I T="" Q
S X=0 F S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X D
.Q:'$D(^ATXAX(T,21,"B",X)) ;not an aspirin
.S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
..S Y=9999999-D I Y<BDATE Q ;documented before bdate
..I Y>EDATE Q ;documented after discharge
..S N=0 F S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N D
...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
...S C=C+1,BGPY(C)="NMI Refusal of: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP1UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
I TAX'["ASPIRIN" Q
;now check for CPT code G8008
S X=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8008"))
I X S C=C+1,BGPY(C)="CPT G8008: "_$$DATE^BGP1UTL($P(X,U,2))
S X=$$TRANI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8008"))
I X S C=C+1,BGPY(C)="CPT (tran code) G8008: "_$$DATE^BGP1UTL($P(X,U,2))
Q
;
LASTMED(P,BDATE,EDATE,T,T1,T2) ;EP - last rx prescription for taxonomy T
K BGPY
S T=$G(T)
S T1=$G(T1)
S T2=$G(T2)
D GETMEDS^BGP1CU(P,BDATE,EDATE,T,T1,T2,0,"","",0,1)
I '$D(BGPY) Q ""
Q BGPY
;
LASTASPC(P,BDATE,EDATE) ;EP - last G8006
NEW X
S X=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8006"))
I X="" Q ""
Q "G8006 "_$$DATE^BGP1UTL($P(X,U,2))
;
ALLALG1(P,EDATE,DSCH,BGPY) ;EP
S DSCH=$S(DSCH:DSCH,1:DT)
NEW ED,BD,BGPG,BGPC,X,Y,Z,N
K BGPY
S BGPC=0
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:'X D
.S I=$P($$ICDDX^ICDCODE($P(^AUPNPROB(X,0),U)),U,2)
.S Z=$$PROBACHK(I,X)
.Q:Z=0
.S D=$P(^AUPNPROB(X,0),U,8)
.Q:D>EDATE
.I Z=2 D Q
..S BGPC=BGPC+1,BGPY(BGPC)="NO ALLERGY NOTED ON "_$$DATE^BGP1UTL(D)
.S N=$P(^AUTNPOV(+$P(^AUPNPROB(X,0),U,5),0),U,1)
.I N="" S N="???"
.S BGPC=BGPC+1,BGPY(BGPC)="["_I_"] "_N_" "_$$DATE^BGP1UTL(D)
.Q
K BGPG
S X=P_"^ALL DX [BGP CMS ALLERGY POV DXS;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 D
.S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($P(BGPG(X),U,1))_" ["_$P(BGPG(X),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(X),U,4),.04)
.Q
Q
ALLALGA1(P,EDATE,BGPY) ;EP - all allergies from the allergy tracking system
;
;now check allergy tracking
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 ;entered after END date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.S BGPC=BGPC+1,BGPY(BGPC)=N_" "_$$DATE^BGP1UTL($P(^GMR(120.8,X,0),U,4))
Q
PROBACHK(I,X) ;checking for allergy codes
I I="693.0" Q 1
I I="693.2" Q 1
I I="995.0" Q 1
I I=995.2 Q 1
I (+I'<999.4),(+I'>999.8) Q 1
I I?1"V14."1E Q 1
I I="692.5" Q 1
I I="693.1" Q 1
I I["V15.0" Q 1
I $E(I,1,3)=692,I'="692.9" Q 1
I I="693.8" Q 1
I I="693.9" Q 1
I I="989.5" Q 1
I I="989.82" Q 1
I I="995.3" Q 1
I I["995.2" Q 1
I $P(^AUPNPROB(X,0),U,5)="" Q 0
S N=$P(^AUTNPOV($P(^AUPNPROB(X,0),U,5),0),U)
I I="799.9"!(I="V82.9"),N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") Q 2
Q 0
IVUD(P,BD,ED,TAX,BGPY,TAXN,TAXC) ;EP
;p - patient
;bd - beg date
;ed - ending date
;BGPY - return array
;tax - taxonomy ien
NEW C,X,E,D,S,I,A,B,F,Z,V,BGPE
K BGPY,BGPE
S TAX=$G(TAX),TAXN=$G(TAXN),TAXC=$G(TAXC)
S C=0
S X=0 F S X=$O(^PS(55,P,5,X)) Q:X'=+X D
.S E=$P($P($G(^PS(55,P,5,X,2)),U,2),".",1)
.Q:E>ED
.Q:E<BD
.S D="",G="",Z=0 F S Z=$O(^PS(55,P,5,X,1,Z)) Q:Z'=+Z D
..S D=$P(^PS(55,P,5,X,1,Z,0),U)
..Q:D=""
..Q:'$D(^PSDRUG(D,0))
..I '$$WTD(D,TAX,TAXN,TAXC) Q
..S G=G_$S(G]"":"; ",1:"")_$P(^PSDRUG(D,0),U)
.S S=$P(^PS(55,P,5,X,0),U,9),S=$$EXTSET^XBFUNC(55.06,28,S)
.S A=$$FMTE^XLFDT($P($G(^PS(55,P,5,X,2)),U,2),2)
.S B=$$FMTE^XLFDT($P($G(^PS(55,P,5,X,2)),U,4),2)
.S F=$$FMTE^XLFDT($P($G(^PS(55,P,5,X,2)),U,3),2)
.I G]"" S C=C+1,BGPE((9999999-E),C)="Unit Dose: "_G_" Date: "_$$DATE^BGP1UTL(E)_" Status: "_S_" Start: "_A_" Stop: "_B_" Previous Stop: "_F
.Q
S X=0 F S X=$O(^PS(55,P,"IV",X)) Q:X'=+X D
.S E=$P(^PS(55,P,"IV",X,0),U,2),E=$P(E,".")
.Q:E>ED
.Q:E<BD
.S D="",G="",Z=0 F S Z=$O(^PS(55,P,"IV",X,"AD",Z)) Q:Z'=+Z D
..S D=$P(^PS(55,P,"IV",X,"AD",Z,0),U)
..Q:D=""
..S D=$P($G(^PS(52.6,D,0)),U,2)
..I D="" Q
..I '$$WTD(D,TAX,TAXN,TAXC) Q
..S G=G_$S(G]"":"; ",1:"")_$P(^PSDRUG(D,0),U)
.S S=$P(^PS(55,P,"IV",X,0),U,17),S=$$EXTSET^XBFUNC(55.01,100,S)
.S A=$$FMTE^XLFDT($P($G(^PS(55,P,"IV",X,0)),U,2),2)
.S B=$$FMTE^XLFDT($P($G(^PS(55,P,"IV",X,0)),U,3),2)
.S F=$$FMTE^XLFDT($P($G(^PS(55,P,"IV",X,2)),U,7),2)
.I G]"" S C=C+1,BGPE((9999999-E),C)="IV: "_G_" Date: "_$$DATE^BGP1UTL(E)_" Status: "_S_" Start: "_A_" Stop: "_B_" Previous Stop: "_F
.Q
S (D,C,A)=0 F S D=$O(BGPE(D)) Q:D'=+D S C=0 F S C=$O(BGPE(D,C)) Q:C'=+C S A=A+1,BGPY(A)=BGPE(D,C)
Q
WTD(D,TD,TN,TC) ;
S TD=$G(TD)
S TN=$G(TN)
S TC=$G(TC)
NEW V
I 'TD,'TN,'TC Q 1 ;no taxonomies so quit
I TD,$D(^ATXAX(TD,21,"B",D)) Q 1
S V=$P($G(^PSDRUG(D,0)),U,2)
I V]"",TC,$D(^ATXAX(TC,21,"B",V)) Q 1
S V=$P($G(^PSDRUG(D,2)),U,4)
I V]"",TN,$D(^ATXAX(TN,21,"B",V)) Q 1
Q ""
LVSD(P,BDATE,EDATE,BGPY,BGPC) ;EP
NEW X,Y,I,T,V,BGPG
K BGPG
I $G(BGPC)="" S BGPC=0
S X=P_"^ALL DX 429.71;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
;S X=$$LASTDXI^BGP1UTL(P,"429.71",BDATE,EDATE) I X]"" D
S X=0 F S X=$O(BGPG(X)) Q:X'=+X D
.S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($P(BGPG(X),U,1))_" ["_$P(BGPG(X),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(X),U,4),.04)
.Q
Q
EJECFRAC(P,BDATE,EDATE,BGPY,BGPC) ;EP - now get all measurements CEF
NEW X,Y,BGPG,N,E,V,T
I $G(BGPC)="" S BGPC=0
K BGPG S Y="BGPG(",X=P_"^ALL MEAS CEF;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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
.Q:$P($G(^AUPNVMSR(Y,2)),U,1)
.S N=$P(^AUPNVMSR(Y,0),U,4)
.;Q:N>39
.S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT CEF: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_N
.Q
;now see if any procedures
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
.I $$ICD^ATXCHK(I,T,0) D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V<BDATE Q
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="CEF PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
;now get all cpts
S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVCPT(X,0))
.S I=$P($G(^AUPNVCPT(X,0)),U) Q:'I
.S Y=$P($$CPT^ICPTCOD(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
.I $$ICD^ATXCHK(I,T,1) D
..S V=$P(^AUPNVCPT(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V<BDATE Q
..I V>EDATE Q ;after discharge
..S BGPC=BGPC+1,BGPY(BGPC)="CEF CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$P($$CPT^ICPTCOD(I,V),U,3)
Q
BGP1CU1 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM 30 Oct 2009 11:26 AM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
ASAALLEG(P,BDATE,EDATE) ;EP does patient have an aspirin allergy documented on or before EDATE
+1 ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
+2 NEW BGPG,G,X,N,Z,Y,T,I
+3 KILL BGPG
+4 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+5 SET G=""
+6 SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+7 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET Y=+$PIECE(BGPG(X),U,4)
+9 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+10 IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)
QUIT
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E935.3"
SET G=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U,1))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" w/E935.3 "
QUIT
+12 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E935.3"
SET G=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U,1))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" w/E935.3 "
QUIT
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E935.3"
SET G=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U,1))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" w/E935.3 "
QUIT
+14 QUIT
End DoDot:1
+15 ;found pov with ecode or narrative
IF G
QUIT G
+16 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+17 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+18 SET Y=+$PIECE(BGPG(X),U,4)
+19 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+20 IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)
+21 QUIT
End DoDot:1
+22 IF G
QUIT G
+23 ;now check problem list for these codes
+24 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+25 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+26 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+27 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+28 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+29 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+30 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP1UTL($PIECE(^AUPNPROB(X,0),U,8))_" Problem List "_$$VAL^XBDIQ1(9000011,X,.01)
QUIT
End DoDot:1
+31 IF G
QUIT G
+32 ;now check allergy tracking
+33 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+34 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")<BDATE
QUIT
+35 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+36 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+37 IF N["ASPIRIN"
SET G=1_U_$$DATE^BGP1UTL($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking "_N
End DoDot:1
+38 QUIT G
+39 ;
ACEALLEG(P,BDATE,EDATE) ;EP
+1 NEW ED,BD,BGPG,G,X,Y,Z,N
+2 SET G=""
+3 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+4 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+6 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+7 IF N["ACEI"!(N["ACE I")
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.6] "_N
QUIT
+9 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.6] "_N
QUIT
+10 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.6] "_N
QUIT
+11 QUIT
End DoDot:1
+12 IF G
QUIT G
+13 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+15 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+16 IF N["ACEI"!(N["ACE I")
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+17 IF G
QUIT G
+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^ICDCODE(I),U,2)
+21 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+22 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+23 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+24 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ACEI"!(N["ACE I")
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP1UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+25 QUIT
End DoDot:1
+26 IF G
QUIT G
+27 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+28 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")<BDATE
QUIT
+29 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+30 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+31 IF N["ACEI"!(N["ACE INHIBITOR")
SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP1UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+32 QUIT G
+33 ;
ARBALLEG(P,BDATE,EDATE) ;EP
+1 NEW ED,BD,BGPG,G,X,Y,Z,N
+2 SET G=""
+3 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+4 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+6 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+7 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.6] "_N
QUIT
+9 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.6] "_N
QUIT
+10 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.6] "_N
QUIT
+11 QUIT
End DoDot:1
+12 IF G
QUIT G
+13 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+15 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+16 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+17 IF G
QUIT G
+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^ICDCODE(I),U,2)
+21 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+22 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+23 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+24 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP1UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+25 QUIT
End DoDot:1
+26 IF G
QUIT G
+27 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+28 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")<BDATE
QUIT
+29 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+30 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+31 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP1UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+32 QUIT G
+33 ;
SAORSTEN(P,BDATE,EDATE) ;EP
+1 NEW BGPG,Y,E,X
+2 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP CMS AORTIC STENOSIS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+3 IF $DATA(BGPG(1))
QUIT 1_U_"POV: "_$$DATE^BGP1UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(1),U,4),.04)
+4 QUIT ""
+5 ;
WARRX(P,BDATE,EDATE,EXP,BGPY) ;EP
+1 ;get active warfarin rx before date of adm
+2 NEW BGPC,X,Y,Z,E
+3 SET BGPC=0
+4 KILL BGPY
+5 DO GETMEDS^BGP1CU(P,BDATE,EDATE,"BGP CMS WARFARIN MEDS","BGP CMS WARFARIN MEDS NDC","BGP CMS WARFARIN MEDS CLASS",EXP,EDATE,"WARFARIN",0)
+6 QUIT
+7 ;
NMIDRUG(P,BDATE,EDATE,BGPY,TAX,C) ;EP ;nmi in refusal file for aspirin or cpt/tran
+1 ;array returned is BGPY
+2 NEW T,Z,Y,D,N
+3 IF $GET(C)=""
SET C=0
+4 SET T=$ORDER(^ATXAX("B",TAX,0))
+5 IF T=""
QUIT
+6 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,50,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;not an aspirin
IF '$DATA(^ATXAX(T,21,"B",X))
QUIT
+8 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+9 ;documented before bdate
SET Y=9999999-D
IF Y<BDATE
QUIT
+10 ;documented after discharge
IF Y>EDATE
QUIT
+11 SET N=0
FOR
SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
IF N'=+N
QUIT
Begin DoDot:3
+12 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
QUIT
+13 SET C=C+1
SET BGPY(C)="NMI Refusal of: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP1UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF TAX'["ASPIRIN"
QUIT
+17 ;now check for CPT code G8008
+18 SET X=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8008"))
+19 IF X
SET C=C+1
SET BGPY(C)="CPT G8008: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+20 SET X=$$TRANI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8008"))
+21 IF X
SET C=C+1
SET BGPY(C)="CPT (tran code) G8008: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+22 QUIT
+23 ;
LASTMED(P,BDATE,EDATE,T,T1,T2) ;EP - last rx prescription for taxonomy T
+1 KILL BGPY
+2 SET T=$GET(T)
+3 SET T1=$GET(T1)
+4 SET T2=$GET(T2)
+5 DO GETMEDS^BGP1CU(P,BDATE,EDATE,T,T1,T2,0,"","",0,1)
+6 IF '$DATA(BGPY)
QUIT ""
+7 QUIT BGPY
+8 ;
LASTASPC(P,BDATE,EDATE) ;EP - last G8006
+1 NEW X
+2 SET X=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8006"))
+3 IF X=""
QUIT ""
+4 QUIT "G8006 "_$$DATE^BGP1UTL($PIECE(X,U,2))
+5 ;
ALLALG1(P,EDATE,DSCH,BGPY) ;EP
+1 SET DSCH=$SELECT(DSCH:DSCH,1:DT)
+2 NEW ED,BD,BGPG,BGPC,X,Y,Z,N
+3 KILL BGPY
+4 SET BGPC=0
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF 'X
QUIT
Begin DoDot:1
+6 SET I=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNPROB(X,0),U)),U,2)
+7 SET Z=$$PROBACHK(I,X)
+8 IF Z=0
QUIT
+9 SET D=$PIECE(^AUPNPROB(X,0),U,8)
+10 IF D>EDATE
QUIT
+11 IF Z=2
Begin DoDot:2
+12 SET BGPC=BGPC+1
SET BGPY(BGPC)="NO ALLERGY NOTED ON "_$$DATE^BGP1UTL(D)
End DoDot:2
QUIT
+13 SET N=$PIECE(^AUTNPOV(+$PIECE(^AUPNPROB(X,0),U,5),0),U,1)
+14 IF N=""
SET N="???"
+15 SET BGPC=BGPC+1
SET BGPY(BGPC)="["_I_"] "_N_" "_$$DATE^BGP1UTL(D)
+16 QUIT
End DoDot:1
+17 KILL BGPG
+18 SET X=P_"^ALL DX [BGP CMS ALLERGY POV DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+19 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U,1))_" ["_$PIECE(BGPG(X),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(X),U,4),.04)
+21 QUIT
End DoDot:1
+22 QUIT
ALLALGA1(P,EDATE,BGPY) ;EP - all allergies from the allergy tracking system
+1 ;
+2 ;now check allergy tracking
+3 SET BGPC=0
+4 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;entered after END date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+6 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+7 SET BGPC=BGPC+1
SET BGPY(BGPC)=N_" "_$$DATE^BGP1UTL($PIECE(^GMR(120.8,X,0),U,4))
End DoDot:1
+8 QUIT
PROBACHK(I,X) ;checking for allergy codes
+1 IF I="693.0"
QUIT 1
+2 IF I="693.2"
QUIT 1
+3 IF I="995.0"
QUIT 1
+4 IF I=995.2
QUIT 1
+5 IF (+I'<999.4)
IF (+I'>999.8)
QUIT 1
+6 IF I?1"V14."1E
QUIT 1
+7 IF I="692.5"
QUIT 1
+8 IF I="693.1"
QUIT 1
+9 IF I["V15.0"
QUIT 1
+10 IF $EXTRACT(I,1,3)=692
IF I'="692.9"
QUIT 1
+11 IF I="693.8"
QUIT 1
+12 IF I="693.9"
QUIT 1
+13 IF I="989.5"
QUIT 1
+14 IF I="989.82"
QUIT 1
+15 IF I="995.3"
QUIT 1
+16 IF I["995.2"
QUIT 1
+17 IF $PIECE(^AUPNPROB(X,0),U,5)=""
QUIT 0
+18 SET N=$PIECE(^AUTNPOV($PIECE(^AUPNPROB(X,0),U,5),0),U)
+19 IF I="799.9"!(I="V82.9")
IF N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG")
QUIT 2
+20 QUIT 0
IVUD(P,BD,ED,TAX,BGPY,TAXN,TAXC) ;EP
+1 ;p - patient
+2 ;bd - beg date
+3 ;ed - ending date
+4 ;BGPY - return array
+5 ;tax - taxonomy ien
+6 NEW C,X,E,D,S,I,A,B,F,Z,V,BGPE
+7 KILL BGPY,BGPE
+8 SET TAX=$GET(TAX)
SET TAXN=$GET(TAXN)
SET TAXC=$GET(TAXC)
+9 SET C=0
+10 SET X=0
FOR
SET X=$ORDER(^PS(55,P,5,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 SET E=$PIECE($PIECE($GET(^PS(55,P,5,X,2)),U,2),".",1)
+12 IF E>ED
QUIT
+13 IF E<BD
QUIT
+14 SET D=""
SET G=""
SET Z=0
FOR
SET Z=$ORDER(^PS(55,P,5,X,1,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+15 SET D=$PIECE(^PS(55,P,5,X,1,Z,0),U)
+16 IF D=""
QUIT
+17 IF '$DATA(^PSDRUG(D,0))
QUIT
+18 IF '$$WTD(D,TAX,TAXN,TAXC)
QUIT
+19 SET G=G_$SELECT(G]"":"; ",1:"")_$PIECE(^PSDRUG(D,0),U)
End DoDot:2
+20 SET S=$PIECE(^PS(55,P,5,X,0),U,9)
SET S=$$EXTSET^XBFUNC(55.06,28,S)
+21 SET A=$$FMTE^XLFDT($PIECE($GET(^PS(55,P,5,X,2)),U,2),2)
+22 SET B=$$FMTE^XLFDT($PIECE($GET(^PS(55,P,5,X,2)),U,4),2)
+23 SET F=$$FMTE^XLFDT($PIECE($GET(^PS(55,P,5,X,2)),U,3),2)
+24 IF G]""
SET C=C+1
SET BGPE((9999999-E),C)="Unit Dose: "_G_" Date: "_$$DATE^BGP1UTL(E)_" Status: "_S_" Start: "_A_" Stop: "_B_" Previous Stop: "_F
+25 QUIT
End DoDot:1
+26 SET X=0
FOR
SET X=$ORDER(^PS(55,P,"IV",X))
IF X'=+X
QUIT
Begin DoDot:1
+27 SET E=$PIECE(^PS(55,P,"IV",X,0),U,2)
SET E=$PIECE(E,".")
+28 IF E>ED
QUIT
+29 IF E<BD
QUIT
+30 SET D=""
SET G=""
SET Z=0
FOR
SET Z=$ORDER(^PS(55,P,"IV",X,"AD",Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+31 SET D=$PIECE(^PS(55,P,"IV",X,"AD",Z,0),U)
+32 IF D=""
QUIT
+33 SET D=$PIECE($GET(^PS(52.6,D,0)),U,2)
+34 IF D=""
QUIT
+35 IF '$$WTD(D,TAX,TAXN,TAXC)
QUIT
+36 SET G=G_$SELECT(G]"":"; ",1:"")_$PIECE(^PSDRUG(D,0),U)
End DoDot:2
+37 SET S=$PIECE(^PS(55,P,"IV",X,0),U,17)
SET S=$$EXTSET^XBFUNC(55.01,100,S)
+38 SET A=$$FMTE^XLFDT($PIECE($GET(^PS(55,P,"IV",X,0)),U,2),2)
+39 SET B=$$FMTE^XLFDT($PIECE($GET(^PS(55,P,"IV",X,0)),U,3),2)
+40 SET F=$$FMTE^XLFDT($PIECE($GET(^PS(55,P,"IV",X,2)),U,7),2)
+41 IF G]""
SET C=C+1
SET BGPE((9999999-E),C)="IV: "_G_" Date: "_$$DATE^BGP1UTL(E)_" Status: "_S_" Start: "_A_" Stop: "_B_" Previous Stop: "_F
+42 QUIT
End DoDot:1
+43 SET (D,C,A)=0
FOR
SET D=$ORDER(BGPE(D))
IF D'=+D
QUIT
SET C=0
FOR
SET C=$ORDER(BGPE(D,C))
IF C'=+C
QUIT
SET A=A+1
SET BGPY(A)=BGPE(D,C)
+44 QUIT
WTD(D,TD,TN,TC) ;
+1 SET TD=$GET(TD)
+2 SET TN=$GET(TN)
+3 SET TC=$GET(TC)
+4 NEW V
+5 ;no taxonomies so quit
IF 'TD
IF 'TN
IF 'TC
QUIT 1
+6 IF TD
IF $DATA(^ATXAX(TD,21,"B",D))
QUIT 1
+7 SET V=$PIECE($GET(^PSDRUG(D,0)),U,2)
+8 IF V]""
IF TC
IF $DATA(^ATXAX(TC,21,"B",V))
QUIT 1
+9 SET V=$PIECE($GET(^PSDRUG(D,2)),U,4)
+10 IF V]""
IF TN
IF $DATA(^ATXAX(TN,21,"B",V))
QUIT 1
+11 QUIT ""
LVSD(P,BDATE,EDATE,BGPY,BGPC) ;EP
+1 NEW X,Y,I,T,V,BGPG
+2 KILL BGPG
+3 IF $GET(BGPC)=""
SET BGPC=0
+4 SET X=P_"^ALL DX 429.71;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+5 ;S X=$$LASTDXI^BGP1UTL(P,"429.71",BDATE,EDATE) I X]"" D
+6 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U,1))_" ["_$PIECE(BGPG(X),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(X),U,4),.04)
+8 QUIT
End DoDot:1
+9 QUIT
EJECFRAC(P,BDATE,EDATE,BGPY,BGPC) ;EP - now get all measurements CEF
+1 NEW X,Y,BGPG,N,E,V,T
+2 IF $GET(BGPC)=""
SET BGPC=0
+3 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL MEAS CEF;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+5 IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+6 SET N=$PIECE(^AUPNVMSR(Y,0),U,4)
+7 ;Q:N>39
+8 SET BGPC=BGPC+1
SET BGPY(BGPC)="MEASUREMENT CEF: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_N
+9 QUIT
End DoDot:1
+10 ;now see if any procedures
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+13 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+14 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+15 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
+16 IF $$ICD^ATXCHK(I,T,0)
Begin DoDot:2
+17 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+18 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+19 IF V<BDATE
QUIT
+20 ;after discharge
IF V>EDATE
QUIT
+21 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+22 ;now get all cpts
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+24 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+25 SET I=$PIECE($GET(^AUPNVCPT(X,0)),U)
IF 'I
QUIT
+26 SET Y=$PIECE($$CPT^ICPTCOD(I),U,2)
+27 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
+28 IF $$ICD^ATXCHK(I,T,1)
Begin DoDot:2
+29 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
+30 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+31 IF V<BDATE
QUIT
+32 ;after discharge
IF V>EDATE
QUIT
+33 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$PIECE($$CPT^ICPTCOD(I,V),U,3)
End DoDot:2
End DoDot:1
+34 QUIT
