BGP2CU2 ; IHS/CMI/LAB - calc CMS measures ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
ALLDXS(P,BDATE,EDATE,BGPY,BGPC,TAX) ;EP
NEW X,Y,I,T,V,BGPG
K BGPG
I $G(BGPC)="" S BGPC=0
S X=P_"^ALL DX ["_TAX_";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 D
.S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP2UTL($P(BGPG(X),U,1))_" ["_$P(BGPG(X),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(X),U,4),.04)
.Q
Q
SMOKER(P,BDATE,EDATE,BGPY) ;EP
NEW BGPC,BGPDENT,BGPDX,BGPTOB
K BGPY S BGPC=0
NEW BGPTOB,BGPDX,BGPDENT
S BGPTOB=$$TOBACCO^BGP2D7(P,BDATE,EDATE)
I BGPTOB["CURRENT SMOKER"!(BGPTOB="CESSATION-SMOKER") S BGPC=BGPC+1,BGPY(BGPC)="Yes, Health Factor: "_$P(BGPTOB,U)_" on "_$P(BGPTOB,U,2)
S BGPDX=$$DX^BGP2D7(P,BDATE,EDATE)
I BGPDX]"",'$$ICD^ATXCHK($P(BGPDX,U,3),$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0)),9) S BGPC=BGPC+1,BGPY(BGPC)="Yes, Diagnosis: "_$P(BGPDX,U)_" on "_$$DATE^BGP2UTL($P(BGPDX,U,2))
S BGPDENT=$$DENT^BGP2D7(P,BDATE,EDATE)
I BGPDENT]"" S BGPC=BGPC+1,BGPY(BGPC)="Yes, "_$P(BGPDENT,U)_" on "_$$DATE^BGP2UTL($P(BGPDENT,U,2))
S BGPCPT=$$CPTSM^BGP2D7(P,BDATE,EDATE)
I BGPCPT]"",$P(BGPCPT,U,1)'="1036F" S BGPC=BGPC+1,BGPY(BGPC)="Yes, CPT "_$P(BGPCPT,U,1)_" on "_$$DATE^BGP2UTL($P(BGPCPT,U,2))
Q
CESS(P,BDATE,EDATE,BGPY,BGPC) ;EP
NEW BGPALLED,Y,E,X,T,A,B,Z,G
S BGPC=$G(BGPC)
K BGPALLED
S Y="BGPALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPALLED(1)) S %="" D
.S (X,D)=0,T="" F S X=$O(BGPALLED(X)) Q:X'=+X D
..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-")="TO" S BGPC=BGPC+1,BGPY(BGPC)=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-",2)="TO" S BGPC=BGPC+1,BGPY(BGPC)=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-",2)="SHS" S BGPC=BGPC+1,BGPY(BGPC)=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-",1)["305.1"!($P(T,"-")="649.00")!($P(T,"-")="649.01")!($P(T,"-")="649.02")!($P(T,"-")="649.03")!($P(T,"-")="649.04")!($P(T,"-")="V15.82"),$P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T 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)
S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X 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)
.S B=$$CLINIC^APCLV(V,"C")
.I B=94 S BGPC=BGPC+1,BGPY(BGPC)=$P($P(^AUPNVSIT(V,0),U),".")_U_"CL 94"
.S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S BGPC=BGPC+1,BGPY(BGPC)=$P($P(^AUPNVSIT(V,0),U),".")_U_"ADA 1320"
.Q
S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT G0375"
S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT G0376"
S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT 4000F"
S G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"TRAN G0375"
S G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"TRAN G0376"
S G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"TRAN 4000F"
;now check all Refusals
S G="",X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""!(G]"") D
.S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"") D
..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"") D
...S Z=$P($G(^AUPNPREF(I,0)),U,3)
...Q:Z=""
...I Z<BDATE Q
...I Z>EDATE Q
...S Y=$P($G(^AUTTEDT(X,0)),U,2)
...I $P(Y,"-")="TO"!($P(Y,"-",2)="TO")!($P(Y,"-",2)="SHS")!($P(Y,"-",1)["305.1")!($P(Y,"-")="649.00")!($P(Y,"-")="649.01")!($P(Y,"-")="649.02")!($P(Y,"-")="649.03")!($P(Y,"-")="649.04") S BGPC=BGPC+1,BGPY(BGPC)=Z_U_"Ref "_Y
Q
;
CESSMEDS(P,BDATE,EDATE,BGPY) ;EP
NEW BGPMEDS1,T,X,G,M,E,V,Z,BGPC,T1
S BGPC=0
K BGPMEDS1,M
D GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
S T=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
S T1=$O(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
S (X,G,M,E)=0,D="" F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.S Z=$P($G(^AUPNVMED(Y,0)),U)
.Q:'Z
.S N=$P($G(^PSDRUG(Z,0)),U)
.I $D(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY") D
..S M((9999999-$P($P(^AUPNVSIT(V,0),U),".")),Y)=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
.S C=$P($G(^PSDRUG(Z,2)),U,4)
.I C]"",$D(^ATXAX(T1,21,"B",C)) S M((9999999-$P($P(^AUPNVSIT(V,0),U),".")),Y)=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
S X=0,Y=0 F S X=$O(M(X)) Q:X'=+X S Y=0 F S Y=$O(M(X,Y)) Q:Y'=+Y D
.S BGPC=BGPC+1,BGPY(BGPC)=M(X,Y)
S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT 4001F"
S G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"TRAN 4001F"
Q
;
BETAALEG(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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S G=1_U_"POV: "_$$DATE^BGP2UTL($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^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP2UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP2UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP2UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(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(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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S G=1_U_"POV: "_$$DATE^BGP2UTL($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
.I $$ICD^ATXCHK(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9)),N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP2UTL($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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP2UTL($P(^GMR(120.8,X,0),U,4))_" "_N
Q G
;
BETARX(P,BDATE,EDATE,EXP,BGPY) ;EP
;get active warfarin rx
NEW BGPC,X,Y,Z,E
S BGPC=0
K BGPY
D GETMEDS^BGP2CU(P,BDATE,EDATE,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS",EXP,EDATE,"",0)
Q
;
PACE(P,BDATE,EDATE) ;EP
NEW G
S G=$$LASTDX^BGP2UTL1(P,"BGP CMS PACEMAKER DXS",BDATE,EDATE)
I G Q 1_U_$$DATE^BGP2UTL($P(G,U,3))_" ["_$P(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.07,$P(G,U,5),.04)
S G=$$LASTPRC^BGP2UTL1(P,"BGP CMS PACEMAKER PROCS",BDATE,EDATE)
I G Q 1_U_$$DATE^BGP2UTL($P(G,U,3))_" ["_$P(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.08,$P(G,U,5),.04)
S G=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CMS PACEMAKER CPTS",0)),6)
I G Q 1_U_$$DATE^BGP2UTL($P(G,U,2))_" ["_$P(G,U,3)_"]"
Q ""
;
ST1(P,BDATE,EDATE,BGPY) ;EP
K BGPY S BGPC=0
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP ST ELEVATION DX;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 BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP2UTL($P(BGPG(X),U))_" "_$P(BGPG(X),U,2)_" "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(X),U,4),.04)
K BGPG
Q
LBBBDX(P,BDATE,EDATE) ;EP
Q $$LASTDXI^BGP2UTL1(P,"426.3",BDATE,EDATE)
;
LBBBPROC(P,BDATE,EDATE,BGPY) ;EP
NEW Y,X,BGPG,BGPC
S BGPC=0
K BGPY
S Y="BGPG("
S X=$$LASTPRC^BGP2UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
I X]"" S BGPC=BGPC+1,BGPY(BGPC)="Procedure: "_$$DATE^BGP2UTL($P(X,U,3))_" "_$P(X,U,2)_" "_$$VAL^XBDIQ1(9000010.08,$P(X,U,4),.04)
K BGPG
;CPT codes
S X=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
I X]"" S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$$DATE^BGP2UTL($P(X,U,2))_" "_$P(X,U,3)
S X=$$TRAN^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
I X]"" S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT: "_$$DATE^BGP2UTL($P(X,U,2))_" "_$P(X,U,3)
Q
LBBB1(P,BDATE,EDATE,BGPY) ;EP
K BGPY S BGPC=0
K BGPG
S Y="BGPG("
S X=P_"^ALL DX 426.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG) Q
S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP2UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)_" "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
K BGPG
S Y="BGPG("
S X=$$LASTPRC^BGP2UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
I X]"" S BGPC=BGPC+1,BGPY(BGPC)="Procedure: "_$$DATE^BGP2UTL($P(X,U,3))_" "_$P(X,U,2)_" "_$$VAL^XBDIQ1(9000010.08,$P(X,U,4),.04)
K BGPG
;CPT codes
S X=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
I X]"" S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$$DATE^BGP2UTL($P(X,U,2))_" "_$P(X,U,3)
S X=$$TRAN^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
I X]"" S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT: "_$$DATE^BGP2UTL($P(X,U,2))_" "_$P(X,U,3)
Q
TA1(P,BGPA,BGPD,BGPY) ;EP
;get last TA rx before date of adm
NEW BGPG,BGPC,X,Y,Z,E,BD,ED,G,D
S BGPC=0 K BGPY
S ED=$$FMADD^XLFDT(BGPA,-1)
S BD=$$FMADD^XLFDT(BGPA,-365)
D GETMEDS^BGP2CU(P,BD,ED,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENT CLASS")
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP2CU(P,BD,ED,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENT CLASS")
K BGPG
Q
;
TARX(P,BDATE,EDATE,EXP,ADM,BGPY) ;EP
NEW BGPC,X,Y,Z,E
S BGPC=0
K BGPY
D GETMEDS^BGP2CU(P,BDATE,EDATE,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENTS CLASS",EXP,ADM,"",0)
Q
;
PNEUVAX(P,BDATE,EDATE,BGPDD,BGPY) ;EP
NEW BGPG,BGPX,BGPC,X,Y,Z,A,B,C,R,C1,V
S BGPC=0
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P($G(^AUPNVIMM(X,0)),U)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U,3)
.I C'=33,C'=100,C'=109 Q
.S V=$P(^AUPNVIMM(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="Immunization CVX: "_C_" "_$$DATE^BGP2UTL($P($P(^AUPNVSIT($P(^AUPNVIMM(X,0),U,3),0),U),"."))
K BGPG S %=P_"^ALL PROCEDURE 99.55;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPRC(Y,0))
.S Y=$P(^AUPNVPRC(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S BGPC=BGPC+1,BGPY(BGPC)="Procedure 99.55: "_$$DATE^BGP2UTL(D)
.Q
K BGPG S %=P_"^ALL DX [BGP PNEUMO IZ DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPOV(Y,0))
.S Y=$P(^AUPNVPOV(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S BGPC=BGPC+1,BGPY(BGPC)="Diagnosis "_$P(BGPG(X),U,2)_": "_$$DATE^BGP2UTL(D)
.Q
;cpts
S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVCPT(X,0))
.S C1=$$VAL^XBDIQ1(9000010.18,X,.01)
.I '$$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) Q
.S V=$P(^AUPNVCPT(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_C1_" "_$$DATE^BGP2UTL(D)
.Q
;tran codes
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S C1=$$VAL^XBDIQ1(9000010.33,X,.07)
.I '$$ICD^ATXCHK($P(^AUPNVTC(X,0),U,7),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) Q
.S D=$P(^AUPNVTC(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="Tran code: "_C1_" "_$$DATE^BGP2UTL(D)
.Q
;Refusals?
K BGPI F X=33,100,109 S Y=$O(^AUTTIMM("C",X,0)) I Y S BGPI(Y)=""
S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,X)) Q:X'=+X D
.Q:'$D(BGPI(X))
.S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.14,X,D)) Q:D'=+D D
..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.14,X,D,I)) Q:I'=+I D
...Q:"NR"'[$P(^AUPNPREF(I,0),U,7)
...Q:D>(9999999-BDATE)
...Q:D<(9999999-EDATE)
...S BGPC=BGPC+1
...S BGPY(BGPC)="REFUSAL: "_$$VAL^XBDIQ1(9000022,I,.07)_" - "_$$VAL^XBDIQ1(9000022,I,.04)_" "_$$DATE^BGP2UTL($P(^AUPNPREF(I,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
S (X,G)=0,Y=$O(^AUTTIMM("C",33,0)) F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X 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:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 33 "_$$DATE^BGP2UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",100,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X 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:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 100 "_$$DATE^BGP2UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",109,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X 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:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 109 "_$$DATE^BGP2UTL(D)
F BGPZ=33,100,109 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) I X]"" S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,2)_" "_$$DATE^BGP2UTL($P(X,U,1))
;bone marrow Contraindication
S X=$$LASTPRC^BGP2UTL1(P,"BGP CMS BONE MARROW PROC",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
I X S BGPC=BGPC+1,BGPY(BGPC)="Bone Marrow Contraindication: ["_$P(X,U,2)_"] "_$$DATE^BGP2UTL($P(X,U,3))
S X=$$CPT^BGP2DU(P,$$FMADD^XLFDT(BGPDD,-365),BGPDD,$O(^ATXAX("B","BGP CMS BONE MARROW CPT",0)),6)
I X S BGPC=BGPC+1,BGPY(BGPC)="Bone Marrow Contraindication: ["_$P(X,U,3)_"] "_$$DATE^BGP2UTL($P(X,U,2))
Q
BGP2CU2 ; IHS/CMI/LAB - calc CMS measures ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
ALLDXS(P,BDATE,EDATE,BGPY,BGPC,TAX) ;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 ["_TAX_";DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+5 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP2UTL($PIECE(BGPG(X),U,1))_" ["_$PIECE(BGPG(X),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(X),U,4),.04)
+7 QUIT
End DoDot:1
+8 QUIT
SMOKER(P,BDATE,EDATE,BGPY) ;EP
+1 NEW BGPC,BGPDENT,BGPDX,BGPTOB
+2 KILL BGPY
SET BGPC=0
+3 NEW BGPTOB,BGPDX,BGPDENT
+4 SET BGPTOB=$$TOBACCO^BGP2D7(P,BDATE,EDATE)
+5 IF BGPTOB["CURRENT SMOKER"!(BGPTOB="CESSATION-SMOKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)="Yes, Health Factor: "_$PIECE(BGPTOB,U)_" on "_$PIECE(BGPTOB,U,2)
+6 SET BGPDX=$$DX^BGP2D7(P,BDATE,EDATE)
+7 IF BGPDX]""
IF '$$ICD^ATXCHK($PIECE(BGPDX,U,3),$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0)),9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="Yes, Diagnosis: "_$PIECE(BGPDX,U)_" on "_$$DATE^BGP2UTL($PIECE(BGPDX,U,2))
+8 SET BGPDENT=$$DENT^BGP2D7(P,BDATE,EDATE)
+9 IF BGPDENT]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="Yes, "_$PIECE(BGPDENT,U)_" on "_$$DATE^BGP2UTL($PIECE(BGPDENT,U,2))
+10 SET BGPCPT=$$CPTSM^BGP2D7(P,BDATE,EDATE)
+11 IF BGPCPT]""
IF $PIECE(BGPCPT,U,1)'="1036F"
SET BGPC=BGPC+1
SET BGPY(BGPC)="Yes, CPT "_$PIECE(BGPCPT,U,1)_" on "_$$DATE^BGP2UTL($PIECE(BGPCPT,U,2))
+12 QUIT
CESS(P,BDATE,EDATE,BGPY,BGPC) ;EP
+1 NEW BGPALLED,Y,E,X,T,A,B,Z,G
+2 SET BGPC=$GET(BGPC)
+3 KILL BGPALLED
+4 SET Y="BGPALLED("
+5 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 IF $DATA(BGPALLED(1))
SET %=""
Begin DoDot:1
+7 SET (X,D)=0
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $PIECE(T,"-")="TO"
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(BGPALLED(X),U)_U_T
QUIT
+13 IF $PIECE(T,"-",2)="TO"
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(BGPALLED(X),U)_U_T
QUIT
+14 IF $PIECE(T,"-",2)="SHS"
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(BGPALLED(X),U)_U_T
QUIT
+15 IF $PIECE(T,"-",1)["305.1"!($PIECE(T,"-")="649.00")!($PIECE(T,"-")="649.01")!($PIECE(T,"-")="649.02")!($PIECE(T,"-")="649.03")!($PIECE(T,"-")="649.04")!($PIECE(T,"-")="V15.82")
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
End DoDot:2
End DoDot:1
+16 KILL ^TMP($JOB,"A")
+17 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+18 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+19 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+20 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+21 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+22 SET B=$$CLINIC^APCLV(V,"C")
+23 IF B=94
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CL 94"
+24 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"ADA 1320"
+25 QUIT
End DoDot:1
+26 SET G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"CPT G0375"
+27 SET G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"CPT G0376"
+28 SET G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"CPT 4000F"
+29 SET G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"TRAN G0375"
+30 SET G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"TRAN G0376"
+31 SET G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"TRAN 4000F"
+32 ;now check all Refusals
+33 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))
IF X=""!(G]"")
QUIT
Begin DoDot:1
+34 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))
IF D=""!(G]"")
QUIT
Begin DoDot:2
+35 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D,I))
IF I'=+I!(G]"")
QUIT
Begin DoDot:3
+36 SET Z=$PIECE($GET(^AUPNPREF(I,0)),U,3)
+37 IF Z=""
QUIT
+38 IF Z<BDATE
QUIT
+39 IF Z>EDATE
QUIT
+40 SET Y=$PIECE($GET(^AUTTEDT(X,0)),U,2)
+41 IF $PIECE(Y,"-")="TO"!($PIECE(Y,"-",2)="TO")!($PIECE(Y,"-",2)="SHS")!($PIECE(Y,"-",1)["305.1")!($PIECE(Y,"-")="649.00")!($PIECE(Y,"-")="649.01")!($PIECE(Y,"-")="649.02")!($PIECE(Y,"-")="649.03")!($PIECE(Y,"-")="649.04")
SET BGPC=BGPC+1
SET BGPY(BGPC)=Z_U_"Ref "_Y
End DoDot:3
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
CESSMEDS(P,BDATE,EDATE,BGPY) ;EP
+1 NEW BGPMEDS1,T,X,G,M,E,V,Z,BGPC,T1
+2 SET BGPC=0
+3 KILL BGPMEDS1,M
+4 DO GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 SET T=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
+6 SET T1=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
+7 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+10 IF 'Z
QUIT
+11 SET N=$PIECE($GET(^PSDRUG(Z,0)),U)
+12 IF $DATA(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY")
Begin DoDot:2
+13 SET M((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),Y)=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:2
+14 SET C=$PIECE($GET(^PSDRUG(Z,2)),U,4)
+15 IF C]""
IF $DATA(^ATXAX(T1,21,"B",C))
SET M((9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")),Y)=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:1
+16 SET X=0
SET Y=0
FOR
SET X=$ORDER(M(X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(M(X,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+17 SET BGPC=BGPC+1
SET BGPY(BGPC)=M(X,Y)
End DoDot:1
+18 SET G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"CPT 4001F"
+19 SET G=$$TRANI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F"))
IF G
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(G,U,2)_U_"TRAN 4001F"
+20 QUIT
+21 ;
BETAALEG(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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET G=1_U_"POV: "_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+8 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARD RHYTH",0))
+9 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+10 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+12 QUIT
End DoDot:1
+13 IF G
QUIT G
+14 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+15 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+16 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+17 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET G=1_U_"POV: "_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+18 IF G
QUIT G
+19 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+20 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+21 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+22 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+23 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+24 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+25 IF $$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9))
IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP2UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+26 QUIT
End DoDot:1
+27 IF G
QUIT G
+28 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+29 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")<BDATE
QUIT
+30 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+31 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+32 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP2UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+33 QUIT G
+34 ;
BETARX(P,BDATE,EDATE,EXP,BGPY) ;EP
+1 ;get active warfarin rx
+2 NEW BGPC,X,Y,Z,E
+3 SET BGPC=0
+4 KILL BGPY
+5 DO GETMEDS^BGP2CU(P,BDATE,EDATE,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS",EXP,EDATE,"",0)
+6 QUIT
+7 ;
PACE(P,BDATE,EDATE) ;EP
+1 NEW G
+2 SET G=$$LASTDX^BGP2UTL1(P,"BGP CMS PACEMAKER DXS",BDATE,EDATE)
+3 IF G
QUIT 1_U_$$DATE^BGP2UTL($PIECE(G,U,3))_" ["_$PIECE(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.07,$PIECE(G,U,5),.04)
+4 SET G=$$LASTPRC^BGP2UTL1(P,"BGP CMS PACEMAKER PROCS",BDATE,EDATE)
+5 IF G
QUIT 1_U_$$DATE^BGP2UTL($PIECE(G,U,3))_" ["_$PIECE(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.08,$PIECE(G,U,5),.04)
+6 SET G=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CMS PACEMAKER CPTS",0)),6)
+7 IF G
QUIT 1_U_$$DATE^BGP2UTL($PIECE(G,U,2))_" ["_$PIECE(G,U,3)_"]"
+8 QUIT ""
+9 ;
ST1(P,BDATE,EDATE,BGPY) ;EP
+1 KILL BGPY
SET BGPC=0
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=P_"^ALL DX [BGP ST ELEVATION DX;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 BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP2UTL($PIECE(BGPG(X),U))_" "_$PIECE(BGPG(X),U,2)_" "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(X),U,4),.04)
+6 KILL BGPG
+7 QUIT
LBBBDX(P,BDATE,EDATE) ;EP
+1 QUIT $$LASTDXI^BGP2UTL1(P,"426.3",BDATE,EDATE)
+2 ;
LBBBPROC(P,BDATE,EDATE,BGPY) ;EP
+1 NEW Y,X,BGPG,BGPC
+2 SET BGPC=0
+3 KILL BGPY
+4 SET Y="BGPG("
+5 SET X=$$LASTPRC^BGP2UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
+6 IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="Procedure: "_$$DATE^BGP2UTL($PIECE(X,U,3))_" "_$PIECE(X,U,2)_" "_$$VAL^XBDIQ1(9000010.08,$PIECE(X,U,4),.04)
+7 KILL BGPG
+8 ;CPT codes
+9 SET X=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
+10 IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT: "_$$DATE^BGP2UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+11 SET X=$$TRAN^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
+12 IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT: "_$$DATE^BGP2UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+13 QUIT
LBBB1(P,BDATE,EDATE,BGPY) ;EP
+1 KILL BGPY
SET BGPC=0
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=P_"^ALL DX 426.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BGPG)
QUIT
+6 SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP2UTL($PIECE(BGPG(1),U))_" "_$PIECE(BGPG(1),U,2)_" "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(1),U,4),.04)
+7 KILL BGPG
+8 SET Y="BGPG("
+9 SET X=$$LASTPRC^BGP2UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
+10 IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="Procedure: "_$$DATE^BGP2UTL($PIECE(X,U,3))_" "_$PIECE(X,U,2)_" "_$$VAL^XBDIQ1(9000010.08,$PIECE(X,U,4),.04)
+11 KILL BGPG
+12 ;CPT codes
+13 SET X=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
+14 IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT: "_$$DATE^BGP2UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+15 SET X=$$TRAN^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
+16 IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT: "_$$DATE^BGP2UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+17 QUIT
TA1(P,BGPA,BGPD,BGPY) ;EP
+1 ;get last TA rx before date of adm
+2 NEW BGPG,BGPC,X,Y,Z,E,BD,ED,G,D
+3 SET BGPC=0
KILL BGPY
+4 SET ED=$$FMADD^XLFDT(BGPA,-1)
+5 SET BD=$$FMADD^XLFDT(BGPA,-365)
+6 DO GETMEDS^BGP2CU(P,BD,ED,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENT CLASS")
+7 SET BD=BGPA
+8 SET ED=$$FMADD^XLFDT(BGPD,30)
+9 DO GETMEDS^BGP2CU(P,BD,ED,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENT CLASS")
+10 KILL BGPG
+11 QUIT
+12 ;
TARX(P,BDATE,EDATE,EXP,ADM,BGPY) ;EP
+1 NEW BGPC,X,Y,Z,E
+2 SET BGPC=0
+3 KILL BGPY
+4 DO GETMEDS^BGP2CU(P,BDATE,EDATE,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENTS CLASS",EXP,ADM,"",0)
+5 QUIT
+6 ;
PNEUVAX(P,BDATE,EDATE,BGPDD,BGPY) ;EP
+1 NEW BGPG,BGPX,BGPC,X,Y,Z,A,B,C,R,C1,V
+2 SET BGPC=0
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET Y=$PIECE($GET(^AUPNVIMM(X,0)),U)
+5 IF 'Y
QUIT
+6 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+7 IF C'=33
IF C'=100
IF C'=109
QUIT
+8 SET V=$PIECE(^AUPNVIMM(X,0),U,3)
+9 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+10 IF D<BDATE
QUIT
+11 IF D>EDATE
QUIT
+12 SET BGPC=BGPC+1
SET BGPY(BGPC)="Immunization CVX: "_C_" "_$$DATE^BGP2UTL($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVIMM(X,0),U,3),0),U),"."))
End DoDot:1
+13 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.55;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+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 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+16 SET Y=$PIECE(^AUPNVPRC(Y,0),U,1)
+17 IF 'Y
QUIT
+18 SET D=$PIECE(BGPG(X),U)
+19 SET BGPC=BGPC+1
SET BGPY(BGPC)="Procedure 99.55: "_$$DATE^BGP2UTL(D)
+20 QUIT
End DoDot:1
+21 KILL BGPG
SET %=P_"^ALL DX [BGP PNEUMO IZ DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+22 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+23 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+24 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+25 IF 'Y
QUIT
+26 SET D=$PIECE(BGPG(X),U)
+27 SET BGPC=BGPC+1
SET BGPY(BGPC)="Diagnosis "_$PIECE(BGPG(X),U,2)_": "_$$DATE^BGP2UTL(D)
+28 QUIT
End DoDot:1
+29 ;cpts
+30 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+31 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+32 SET C1=$$VAL^XBDIQ1(9000010.18,X,.01)
+33 IF '$$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
QUIT
+34 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
+35 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+36 IF D<BDATE
QUIT
+37 IF D>EDATE
QUIT
+38 SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT: "_C1_" "_$$DATE^BGP2UTL(D)
+39 QUIT
End DoDot:1
+40 ;tran codes
+41 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+42 IF '$DATA(^AUPNVTC(X,0))
QUIT
+43 SET C1=$$VAL^XBDIQ1(9000010.33,X,.07)
+44 IF '$$ICD^ATXCHK($PIECE(^AUPNVTC(X,0),U,7),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
QUIT
+45 SET D=$PIECE(^AUPNVTC(X,0),U,3)
+46 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+47 IF D<BDATE
QUIT
+48 IF D>EDATE
QUIT
+49 SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran code: "_C1_" "_$$DATE^BGP2UTL(D)
+50 QUIT
End DoDot:1
+51 ;Refusals?
+52 KILL BGPI
FOR X=33,100,109
SET Y=$ORDER(^AUTTIMM("C",X,0))
IF Y
SET BGPI(Y)=""
+53 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,X))
IF X'=+X
QUIT
Begin DoDot:1
+54 IF '$DATA(BGPI(X))
QUIT
+55 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.14,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+56 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9999999.14,X,D,I))
IF I'=+I
QUIT
Begin DoDot:3
+57 IF "NR"'[$PIECE(^AUPNPREF(I,0),U,7)
QUIT
+58 IF D>(9999999-BDATE)
QUIT
+59 IF D<(9999999-EDATE)
QUIT
+60 SET BGPC=BGPC+1
+61 SET BGPY(BGPC)="REFUSAL: "_$$VAL^XBDIQ1(9000022,I,.07)_" - "_$$VAL^XBDIQ1(9000022,I,.04)_" "_$$DATE^BGP2UTL($PIECE(^AUPNPREF(I,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
End DoDot:3
+62 QUIT
End DoDot:2
+63 QUIT
End DoDot:1
+64 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",33,0))
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+65 SET R=$PIECE(^BIPC(X,0),U,3)
+66 IF R=""
QUIT
+67 IF '$DATA(^BICONT(R,0))
QUIT
+68 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+69 SET D=$PIECE(^BIPC(X,0),U,4)
+70 IF D=""
QUIT
+71 IF D<BDATE
QUIT
+72 IF D>EDATE
QUIT
+73 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 33 "_$$DATE^BGP2UTL(D)
End DoDot:1
+74 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
QUIT
Begin DoDot:1
+75 SET R=$PIECE(^BIPC(X,0),U,3)
+76 IF R=""
QUIT
+77 IF '$DATA(^BICONT(R,0))
QUIT
+78 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+79 SET D=$PIECE(^BIPC(X,0),U,4)
+80 IF D=""
QUIT
+81 IF D<BDATE
QUIT
+82 IF D>EDATE
QUIT
+83 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 100 "_$$DATE^BGP2UTL(D)
End DoDot:1
+84 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
QUIT
Begin DoDot:1
+85 SET R=$PIECE(^BIPC(X,0),U,3)
+86 IF R=""
QUIT
+87 IF '$DATA(^BICONT(R,0))
QUIT
+88 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+89 SET D=$PIECE(^BIPC(X,0),U,4)
+90 IF D=""
QUIT
+91 IF D<BDATE
QUIT
+92 IF D>EDATE
QUIT
+93 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 109 "_$$DATE^BGP2UTL(D)
End DoDot:1
+94 FOR BGPZ=33,100,109
SET X=$$ANCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,2)_" "_$$DATE^BGP2UTL($PIECE(X,U,1))
+95 ;bone marrow Contraindication
+96 SET X=$$LASTPRC^BGP2UTL1(P,"BGP CMS BONE MARROW PROC",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
+97 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Bone Marrow Contraindication: ["_$PIECE(X,U,2)_"] "_$$DATE^BGP2UTL($PIECE(X,U,3))
+98 SET X=$$CPT^BGP2DU(P,$$FMADD^XLFDT(BGPDD,-365),BGPDD,$ORDER(^ATXAX("B","BGP CMS BONE MARROW CPT",0)),6)
+99 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Bone Marrow Contraindication: ["_$PIECE(X,U,3)_"] "_$$DATE^BGP2UTL($PIECE(X,U,2))
+100 QUIT
