- BGP0CU2 ; IHS/CMI/LAB - calc CMS measures ;
- ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
- ;
- 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^BGP0UTL($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^BGP0D7(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^BGP0D7(P,BDATE,EDATE)
- I BGPDX]"",$P(BGPDX,U)'="305.13",$P(BGPDX,U)'="V15.82" S BGPC=BGPC+1,BGPY(BGPC)="Yes, Diagnosis: "_$P(BGPDX,U)_" on "_$$DATE^BGP0UTL($P(BGPDX,U,2))
- S BGPDENT=$$DENT^BGP0D7(P,BDATE,EDATE)
- I BGPDENT]"" S BGPC=BGPC+1,BGPY(BGPC)="Yes, "_$P(BGPDENT,U)_" on "_$$DATE^BGP0UTL($P(BGPDENT,U,2))
- S BGPCPT=$$CPTSM^BGP0D7(P,BDATE,EDATE)
- I BGPCPT]"",$P(BGPCPT,U,1)'="1036F" S BGPC=BGPC+1,BGPY(BGPC)="Yes, CPT "_$P(BGPCPT,U,1)_" on "_$$DATE^BGP0UTL($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^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT G0375"
- S G=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT G0376"
- S G=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT 4000F"
- S G=$$TRANI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"TRAN G0375"
- S G=$$TRANI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"TRAN G0376"
- S G=$$TRANI^BGP0DU(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^BGP0UTL2(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^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G S BGPC=BGPC+1,BGPY(BGPC)=$P(G,U,2)_U_"CPT 4001F"
- S G=$$TRANI^BGP0DU(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^BGP0UTL($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.0" S G=1_U_"POV: "_$$DATE^BGP0UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.0] "_N Q
- .S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.0" S G=1_U_"POV: "_$$DATE^BGP0UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.0] "_N Q
- .S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.0" S G=1_U_"POV: "_$$DATE^BGP0UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.0] "_N
- .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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S G=1_U_"POV: "_$$DATE^BGP0UTL($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 Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP0UTL($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^BGP0UTL($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^BGP0CU(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^BGP0UTL1(P,"BGP CMS PACEMAKER DXS",BDATE,EDATE)
- I G Q 1_U_$$DATE^BGP0UTL($P(G,U,3))_" ["_$P(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.07,$P(G,U,5),.04)
- S G=$$LASTPRC^BGP0UTL1(P,"BGP CMS PACEMAKER PROCS",BDATE,EDATE)
- I G Q 1_U_$$DATE^BGP0UTL($P(G,U,3))_" ["_$P(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.08,$P(G,U,5),.04)
- S G=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CMS PACEMAKER CPTS",0)),6)
- I G Q 1_U_$$DATE^BGP0UTL($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^BGP0UTL($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^BGP0UTL1(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^BGP0UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
- I X]"" S BGPC=BGPC+1,BGPY(BGPC)="Procedure: "_$$DATE^BGP0UTL($P(X,U,3))_" "_$P(X,U,2)_" "_$$VAL^XBDIQ1(9000010.08,$P(X,U,4),.04)
- K BGPG
- ;CPT codes
- S X=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
- I X]"" S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$$DATE^BGP0UTL($P(X,U,2))_" "_$P(X,U,3)
- S X=$$TRAN^BGP0DU(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^BGP0UTL($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^BGP0UTL($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^BGP0UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
- I X]"" S BGPC=BGPC+1,BGPY(BGPC)="Procedure: "_$$DATE^BGP0UTL($P(X,U,3))_" "_$P(X,U,2)_" "_$$VAL^XBDIQ1(9000010.08,$P(X,U,4),.04)
- K BGPG
- ;CPT codes
- S X=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
- I X]"" S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$$DATE^BGP0UTL($P(X,U,2))_" "_$P(X,U,3)
- S X=$$TRAN^BGP0DU(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^BGP0UTL($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^BGP0CU(P,BD,ED,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENT CLASS")
- S BD=BGPA
- S ED=$$FMADD^XLFDT(BGPD,30)
- D GETMEDS^BGP0CU(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^BGP0CU(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^BGP0UTL($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^BGP0UTL(D)
- .Q
- K BGPG S %=P_"^ALL DX V03.82;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 V03.82: "_$$DATE^BGP0UTL(D)
- .Q
- K BGPG S %=P_"^ALL DX V06.6;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 V06.06: "_$$DATE^BGP0UTL(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^BGP0UTL(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^BGP0UTL(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^BGP0UTL($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^BGP0UTL(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^BGP0UTL(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^BGP0UTL(D)
- F BGPZ=33,100,109 S X=$$ANCONT^BGP0D31(P,BGPZ,EDATE) I X]"" S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,2)_" "_$$DATE^BGP0UTL($P(X,U,1))
- ;bone marrow contraindication
- S X=$$LASTPRC^BGP0UTL1(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^BGP0UTL($P(X,U,3))
- S X=$$CPT^BGP0DU(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^BGP0UTL($P(X,U,2))
- Q
- BGP0CU2 ; IHS/CMI/LAB - calc CMS measures ;
- +1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
- +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^BGP0UTL($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^BGP0D7(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^BGP0D7(P,BDATE,EDATE)
- +7 IF BGPDX]""
- IF $PIECE(BGPDX,U)'="305.13"
- IF $PIECE(BGPDX,U)'="V15.82"
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Yes, Diagnosis: "_$PIECE(BGPDX,U)_" on "_$$DATE^BGP0UTL($PIECE(BGPDX,U,2))
- +8 SET BGPDENT=$$DENT^BGP0D7(P,BDATE,EDATE)
- +9 IF BGPDENT]""
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Yes, "_$PIECE(BGPDENT,U)_" on "_$$DATE^BGP0UTL($PIECE(BGPDENT,U,2))
- +10 SET BGPCPT=$$CPTSM^BGP0D7(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^BGP0UTL($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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0UTL2(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^BGP0DU(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^BGP0DU(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^BGP0UTL($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.0"
- SET G=1_U_"POV: "_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.0] "_N
- QUIT
- +9 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
- IF Z]""
- IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.0"
- SET G=1_U_"POV: "_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.0] "_N
- QUIT
- +10 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
- IF Z]""
- IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.0"
- SET G=1_U_"POV: "_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.0] "_N
- +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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
- SET G=1_U_"POV: "_$$DATE^BGP0UTL($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 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
- QUIT
- +24 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
- IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
- SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP0UTL($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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
- SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP0UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
- End DoDot:1
- +32 QUIT G
- +33 ;
- 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^BGP0CU(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^BGP0UTL1(P,"BGP CMS PACEMAKER DXS",BDATE,EDATE)
- +3 IF G
- QUIT 1_U_$$DATE^BGP0UTL($PIECE(G,U,3))_" ["_$PIECE(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.07,$PIECE(G,U,5),.04)
- +4 SET G=$$LASTPRC^BGP0UTL1(P,"BGP CMS PACEMAKER PROCS",BDATE,EDATE)
- +5 IF G
- QUIT 1_U_$$DATE^BGP0UTL($PIECE(G,U,3))_" ["_$PIECE(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.08,$PIECE(G,U,5),.04)
- +6 SET G=$$CPT^BGP0DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CMS PACEMAKER CPTS",0)),6)
- +7 IF G
- QUIT 1_U_$$DATE^BGP0UTL($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^BGP0UTL($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^BGP0UTL1(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^BGP0UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
- +6 IF X]""
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Procedure: "_$$DATE^BGP0UTL($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^BGP0DU(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^BGP0UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
- +11 SET X=$$TRAN^BGP0DU(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^BGP0UTL($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^BGP0UTL($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^BGP0UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
- +10 IF X]""
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Procedure: "_$$DATE^BGP0UTL($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^BGP0DU(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^BGP0UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
- +15 SET X=$$TRAN^BGP0DU(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^BGP0UTL($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^BGP0CU(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^BGP0CU(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^BGP0CU(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^BGP0UTL($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^BGP0UTL(D)
- +20 QUIT
- End DoDot:1
- +21 KILL BGPG
- SET %=P_"^ALL DX V03.82;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 V03.82: "_$$DATE^BGP0UTL(D)
- +28 QUIT
- End DoDot:1
- +29 KILL BGPG
- SET %=P_"^ALL DX V06.6;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(%,"BGPG(")
- +30 SET X=0
- FOR
- SET X=$ORDER(BGPG(X))
- IF X'=+X
- QUIT
- SET Y=+$PIECE(BGPG(X),U,4)
- Begin DoDot:1
- +31 IF '$DATA(^AUPNVPOV(Y,0))
- QUIT
- +32 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
- +33 IF 'Y
- QUIT
- +34 SET D=$PIECE(BGPG(X),U)
- +35 SET BGPC=BGPC+1
- SET BGPY(BGPC)="Diagnosis V06.06: "_$$DATE^BGP0UTL(D)
- +36 QUIT
- End DoDot:1
- +37 ;cpts
- +38 SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AC",P,X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +39 IF '$DATA(^AUPNVCPT(X,0))
- QUIT
- +40 SET C1=$$VAL^XBDIQ1(9000010.18,X,.01)
- +41 IF '$$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
- QUIT
- +42 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
- +43 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
- +44 IF D<BDATE
- QUIT
- +45 IF D>EDATE
- QUIT
- +46 SET BGPC=BGPC+1
- SET BGPY(BGPC)="CPT: "_C1_" "_$$DATE^BGP0UTL(D)
- +47 QUIT
- End DoDot:1
- +48 ;tran codes
- +49 SET X=0
- FOR
- SET X=$ORDER(^AUPNVTC("AC",P,X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +50 IF '$DATA(^AUPNVTC(X,0))
- QUIT
- +51 SET C1=$$VAL^XBDIQ1(9000010.33,X,.07)
- +52 IF '$$ICD^ATXCHK($PIECE(^AUPNVTC(X,0),U,7),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
- QUIT
- +53 SET D=$PIECE(^AUPNVTC(X,0),U,3)
- +54 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
- +55 IF D<BDATE
- QUIT
- +56 IF D>EDATE
- QUIT
- +57 SET BGPC=BGPC+1
- SET BGPY(BGPC)="Tran code: "_C1_" "_$$DATE^BGP0UTL(D)
- +58 QUIT
- End DoDot:1
- +59 ;refusals?
- +60 KILL BGPI
- FOR X=33,100,109
- SET Y=$ORDER(^AUTTIMM("C",X,0))
- IF Y
- SET BGPI(Y)=""
- +61 SET X=0
- FOR
- SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +62 IF '$DATA(BGPI(X))
- QUIT
- +63 SET D=0
- FOR
- SET D=$ORDER(^AUPNPREF("AA",P,9999999.14,X,D))
- IF D'=+D
- QUIT
- Begin DoDot:2
- +64 SET I=0
- FOR
- SET I=$ORDER(^AUPNPREF("AA",P,9999999.14,X,D,I))
- IF I'=+I
- QUIT
- Begin DoDot:3
- +65 IF "NR"'[$PIECE(^AUPNPREF(I,0),U,7)
- QUIT
- +66 IF D>(9999999-BDATE)
- QUIT
- +67 IF D<(9999999-EDATE)
- QUIT
- +68 SET BGPC=BGPC+1
- +69 SET BGPY(BGPC)="REFUSAL: "_$$VAL^XBDIQ1(9000022,I,.07)_" - "_$$VAL^XBDIQ1(9000022,I,.04)_" "_$$DATE^BGP0UTL($PIECE(^AUPNPREF(I,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
- End DoDot:3
- +70 QUIT
- End DoDot:2
- +71 QUIT
- End DoDot:1
- +72 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
- +73 SET R=$PIECE(^BIPC(X,0),U,3)
- +74 IF R=""
- QUIT
- +75 IF '$DATA(^BICONT(R,0))
- QUIT
- +76 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
- QUIT
- +77 SET D=$PIECE(^BIPC(X,0),U,4)
- +78 IF D=""
- QUIT
- +79 IF D<BDATE
- QUIT
- +80 IF D>EDATE
- QUIT
- +81 SET BGPC=BGPC+1
- SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 33 "_$$DATE^BGP0UTL(D)
- End DoDot:1
- +82 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
- +83 SET R=$PIECE(^BIPC(X,0),U,3)
- +84 IF R=""
- QUIT
- +85 IF '$DATA(^BICONT(R,0))
- QUIT
- +86 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
- QUIT
- +87 SET D=$PIECE(^BIPC(X,0),U,4)
- +88 IF D=""
- QUIT
- +89 IF D<BDATE
- QUIT
- +90 IF D>EDATE
- QUIT
- +91 SET BGPC=BGPC+1
- SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 100 "_$$DATE^BGP0UTL(D)
- End DoDot:1
- +92 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
- +93 SET R=$PIECE(^BIPC(X,0),U,3)
- +94 IF R=""
- QUIT
- +95 IF '$DATA(^BICONT(R,0))
- QUIT
- +96 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
- QUIT
- +97 SET D=$PIECE(^BIPC(X,0),U,4)
- +98 IF D=""
- QUIT
- +99 IF D<BDATE
- QUIT
- +100 IF D>EDATE
- QUIT
- +101 SET BGPC=BGPC+1
- SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 109 "_$$DATE^BGP0UTL(D)
- End DoDot:1
- +102 FOR BGPZ=33,100,109
- SET X=$$ANCONT^BGP0D31(P,BGPZ,EDATE)
- IF X]""
- SET BGPC=BGPC+1
- SET BGPY(BGPC)=$PIECE(X,U,2)_" "_$$DATE^BGP0UTL($PIECE(X,U,1))
- +103 ;bone marrow contraindication
- +104 SET X=$$LASTPRC^BGP0UTL1(P,"BGP CMS BONE MARROW PROC",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
- +105 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Bone Marrow Contraindication: ["_$PIECE(X,U,2)_"] "_$$DATE^BGP0UTL($PIECE(X,U,3))
- +106 SET X=$$CPT^BGP0DU(P,$$FMADD^XLFDT(BGPDD,-365),BGPDD,$ORDER(^ATXAX("B","BGP CMS BONE MARROW CPT",0)),6)
- +107 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Bone Marrow Contraindication: ["_$PIECE(X,U,3)_"] "_$$DATE^BGP0UTL($PIECE(X,U,2))
- +108 QUIT