Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP0CU2

BGP0CU2.m

Go to the documentation of this file.
  1. BGP0CU2 ; IHS/CMI/LAB - calc CMS measures ;
  1. ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
  1. ;
  1. ALLDXS(P,BDATE,EDATE,BGPY,BGPC,TAX) ;EP
  1. NEW X,Y,I,T,V,BGPG
  1. K BGPG
  1. I $G(BGPC)="" S BGPC=0
  1. S X=P_"^ALL DX ["_TAX_";DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X D
  1. .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)
  1. .Q
  1. Q
  1. SMOKER(P,BDATE,EDATE,BGPY) ;EP
  1. NEW BGPC,BGPDENT,BGPDX,BGPTOB
  1. K BGPY S BGPC=0
  1. NEW BGPTOB,BGPDX,BGPDENT
  1. S BGPTOB=$$TOBACCO^BGP0D7(P,BDATE,EDATE)
  1. I BGPTOB["CURRENT SMOKER"!(BGPTOB="CESSATION-SMOKER") S BGPC=BGPC+1,BGPY(BGPC)="Yes, Health Factor: "_$P(BGPTOB,U)_" on "_$P(BGPTOB,U,2)
  1. S BGPDX=$$DX^BGP0D7(P,BDATE,EDATE)
  1. 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))
  1. S BGPDENT=$$DENT^BGP0D7(P,BDATE,EDATE)
  1. I BGPDENT]"" S BGPC=BGPC+1,BGPY(BGPC)="Yes, "_$P(BGPDENT,U)_" on "_$$DATE^BGP0UTL($P(BGPDENT,U,2))
  1. S BGPCPT=$$CPTSM^BGP0D7(P,BDATE,EDATE)
  1. 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))
  1. Q
  1. CESS(P,BDATE,EDATE,BGPY,BGPC) ;EP
  1. NEW BGPALLED,Y,E,X,T,A,B,Z,G
  1. S BGPC=$G(BGPC)
  1. K BGPALLED
  1. S Y="BGPALLED("
  1. S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPALLED(1)) S %="" D
  1. .S (X,D)=0,T="" F S X=$O(BGPALLED(X)) Q:X'=+X D
  1. ..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
  1. ..Q:'T
  1. ..Q:'$D(^AUTTEDT(T,0))
  1. ..S T=$P(^AUTTEDT(T,0),U,2)
  1. ..I $P(T,"-")="TO" S BGPC=BGPC+1,BGPY(BGPC)=$P(BGPALLED(X),U)_U_T Q
  1. ..I $P(T,"-",2)="TO" S BGPC=BGPC+1,BGPY(BGPC)=$P(BGPALLED(X),U)_U_T Q
  1. ..I $P(T,"-",2)="SHS" S BGPC=BGPC+1,BGPY(BGPC)=$P(BGPALLED(X),U)_U_T Q
  1. ..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
  1. K ^TMP($J,"A")
  1. S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1. 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
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:'$P(^AUPNVSIT(V,0),U,9)
  1. .Q:$P(^AUPNVSIT(V,0),U,11)
  1. .S B=$$CLINIC^APCLV(V,"C")
  1. .I B=94 S BGPC=BGPC+1,BGPY(BGPC)=$P($P(^AUPNVSIT(V,0),U),".")_U_"CL 94"
  1. .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"
  1. .Q
  1. 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"
  1. 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"
  1. 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"
  1. 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"
  1. 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"
  1. 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"
  1. ;now check all refusals
  1. S G="",X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""!(G]"") D
  1. .S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"") D
  1. ..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"") D
  1. ...S Z=$P($G(^AUPNPREF(I,0)),U,3)
  1. ...Q:Z=""
  1. ...I Z<BDATE Q
  1. ...I Z>EDATE Q
  1. ...S Y=$P($G(^AUTTEDT(X,0)),U,2)
  1. ...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
  1. Q
  1. ;
  1. CESSMEDS(P,BDATE,EDATE,BGPY) ;EP
  1. NEW BGPMEDS1,T,X,G,M,E,V,Z,BGPC,T1
  1. S BGPC=0
  1. K BGPMEDS1,M
  1. D GETMEDS^BGP0UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
  1. S T=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
  1. S T1=$O(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
  1. 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
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .S Z=$P($G(^AUPNVMED(Y,0)),U)
  1. .Q:'Z
  1. .S N=$P($G(^PSDRUG(Z,0)),U)
  1. .I $D(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY") D
  1. ..S M((9999999-$P($P(^AUPNVSIT(V,0),U),".")),Y)=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
  1. .S C=$P($G(^PSDRUG(Z,2)),U,4)
  1. .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
  1. 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
  1. .S BGPC=BGPC+1,BGPY(BGPC)=M(X,Y)
  1. 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"
  1. 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"
  1. Q
  1. ;
  1. BETAALEG(P,BDATE,EDATE) ;EP
  1. NEW ED,BD,BGPG,G,X,Y,Z,N
  1. S G=""
  1. I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
  1. 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)
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
  1. .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
  1. .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
  1. .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
  1. .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
  1. .Q
  1. I G Q G
  1. K BGPG S Y="BGPG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
  1. .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
  1. I G Q G
  1. S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
  1. S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^ICDCODE(I),U,2)
  1. .S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
  1. .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1. .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1. .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
  1. .Q
  1. I G Q G
  1. S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
  1. .Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")<BDATE
  1. .Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after discharge date
  1. .S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
  1. .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
  1. Q G
  1. ;
  1. BETARX(P,BDATE,EDATE,EXP,BGPY) ;EP
  1. ;get active warfarin rx
  1. NEW BGPC,X,Y,Z,E
  1. S BGPC=0
  1. K BGPY
  1. D GETMEDS^BGP0CU(P,BDATE,EDATE,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS",EXP,EDATE,"",0)
  1. Q
  1. ;
  1. PACE(P,BDATE,EDATE) ;EP
  1. NEW G
  1. S G=$$LASTDX^BGP0UTL1(P,"BGP CMS PACEMAKER DXS",BDATE,EDATE)
  1. I G Q 1_U_$$DATE^BGP0UTL($P(G,U,3))_" ["_$P(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.07,$P(G,U,5),.04)
  1. S G=$$LASTPRC^BGP0UTL1(P,"BGP CMS PACEMAKER PROCS",BDATE,EDATE)
  1. I G Q 1_U_$$DATE^BGP0UTL($P(G,U,3))_" ["_$P(G,U,2)_"] "_$$VAL^XBDIQ1(9000010.08,$P(G,U,5),.04)
  1. S G=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CMS PACEMAKER CPTS",0)),6)
  1. I G Q 1_U_$$DATE^BGP0UTL($P(G,U,2))_" ["_$P(G,U,3)_"]"
  1. Q ""
  1. ;
  1. ST1(P,BDATE,EDATE,BGPY) ;EP
  1. K BGPY S BGPC=0
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^ALL DX [BGP ST ELEVATION DX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. 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)
  1. K BGPG
  1. Q
  1. LBBBDX(P,BDATE,EDATE) ;EP
  1. Q $$LASTDXI^BGP0UTL1(P,"426.3",BDATE,EDATE)
  1. ;
  1. LBBBPROC(P,BDATE,EDATE,BGPY) ;EP
  1. NEW Y,X,BGPG,BGPC
  1. S BGPC=0
  1. K BGPY
  1. S Y="BGPG("
  1. S X=$$LASTPRC^BGP0UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
  1. 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)
  1. K BGPG
  1. ;CPT codes
  1. S X=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
  1. I X]"" S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$$DATE^BGP0UTL($P(X,U,2))_" "_$P(X,U,3)
  1. S X=$$TRAN^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
  1. I X]"" S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT: "_$$DATE^BGP0UTL($P(X,U,2))_" "_$P(X,U,3)
  1. Q
  1. LBBB1(P,BDATE,EDATE,BGPY) ;EP
  1. K BGPY S BGPC=0
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^ALL DX 426.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I '$D(BGPG) Q
  1. 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)
  1. K BGPG
  1. S Y="BGPG("
  1. S X=$$LASTPRC^BGP0UTL1(P,"BGP LBBB ON ECG PROC",BDATE,EDATE)
  1. 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)
  1. K BGPG
  1. ;CPT codes
  1. S X=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
  1. I X]"" S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$$DATE^BGP0UTL($P(X,U,2))_" "_$P(X,U,3)
  1. S X=$$TRAN^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LBBB ON ECG CPT",0)),6)
  1. I X]"" S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT: "_$$DATE^BGP0UTL($P(X,U,2))_" "_$P(X,U,3)
  1. Q
  1. TA1(P,BGPA,BGPD,BGPY) ;EP
  1. ;get last TA rx before date of adm
  1. NEW BGPG,BGPC,X,Y,Z,E,BD,ED,G,D
  1. S BGPC=0 K BGPY
  1. S ED=$$FMADD^XLFDT(BGPA,-1)
  1. S BD=$$FMADD^XLFDT(BGPA,-365)
  1. D GETMEDS^BGP0CU(P,BD,ED,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENT CLASS")
  1. S BD=BGPA
  1. S ED=$$FMADD^XLFDT(BGPD,30)
  1. D GETMEDS^BGP0CU(P,BD,ED,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENT CLASS")
  1. K BGPG
  1. Q
  1. ;
  1. TARX(P,BDATE,EDATE,EXP,ADM,BGPY) ;EP
  1. NEW BGPC,X,Y,Z,E
  1. S BGPC=0
  1. K BGPY
  1. D GETMEDS^BGP0CU(P,BDATE,EDATE,"BGP CMS THROMBOLYTIC MEDS","","BGP THROMBOLYTIC AGENTS CLASS",EXP,ADM,"",0)
  1. Q
  1. ;
  1. PNEUVAX(P,BDATE,EDATE,BGPDD,BGPY) ;EP
  1. NEW BGPG,BGPX,BGPC,X,Y,Z,A,B,C,R,C1,V
  1. S BGPC=0
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S Y=$P($G(^AUPNVIMM(X,0)),U)
  1. .Q:'Y
  1. .S C=$P($G(^AUTTIMM(Y,0)),U,3)
  1. .I C'=33,C'=100,C'=109 Q
  1. .S V=$P(^AUPNVIMM(X,0),U,3)
  1. .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .S BGPC=BGPC+1,BGPY(BGPC)="Immunization CVX: "_C_" "_$$DATE^BGP0UTL($P($P(^AUPNVSIT($P(^AUPNVIMM(X,0),U,3),0),U),"."))
  1. K BGPG S %=P_"^ALL PROCEDURE 99.55;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .Q:'$D(^AUPNVPRC(Y,0))
  1. .S Y=$P(^AUPNVPRC(Y,0),U,1)
  1. .Q:'Y
  1. .S D=$P(BGPG(X),U)
  1. .S BGPC=BGPC+1,BGPY(BGPC)="Procedure 99.55: "_$$DATE^BGP0UTL(D)
  1. .Q
  1. K BGPG S %=P_"^ALL DX V03.82;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .Q:'$D(^AUPNVPOV(Y,0))
  1. .S Y=$P(^AUPNVPOV(Y,0),U,1)
  1. .Q:'Y
  1. .S D=$P(BGPG(X),U)
  1. .S BGPC=BGPC+1,BGPY(BGPC)="Diagnosis V03.82: "_$$DATE^BGP0UTL(D)
  1. .Q
  1. K BGPG S %=P_"^ALL DX V06.6;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .Q:'$D(^AUPNVPOV(Y,0))
  1. .S Y=$P(^AUPNVPOV(Y,0),U,1)
  1. .Q:'Y
  1. .S D=$P(BGPG(X),U)
  1. .S BGPC=BGPC+1,BGPY(BGPC)="Diagnosis V06.06: "_$$DATE^BGP0UTL(D)
  1. .Q
  1. ;cpts
  1. S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
  1. .Q:'$D(^AUPNVCPT(X,0))
  1. .S C1=$$VAL^XBDIQ1(9000010.18,X,.01)
  1. .I '$$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) Q
  1. .S V=$P(^AUPNVCPT(X,0),U,3)
  1. .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_C1_" "_$$DATE^BGP0UTL(D)
  1. .Q
  1. ;tran codes
  1. S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
  1. .Q:'$D(^AUPNVTC(X,0))
  1. .S C1=$$VAL^XBDIQ1(9000010.33,X,.07)
  1. .I '$$ICD^ATXCHK($P(^AUPNVTC(X,0),U,7),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) Q
  1. .S D=$P(^AUPNVTC(X,0),U,3)
  1. .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .S BGPC=BGPC+1,BGPY(BGPC)="Tran code: "_C1_" "_$$DATE^BGP0UTL(D)
  1. .Q
  1. ;refusals?
  1. K BGPI F X=33,100,109 S Y=$O(^AUTTIMM("C",X,0)) I Y S BGPI(Y)=""
  1. S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,X)) Q:X'=+X D
  1. .Q:'$D(BGPI(X))
  1. .S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.14,X,D)) Q:D'=+D D
  1. ..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.14,X,D,I)) Q:I'=+I D
  1. ...Q:"NR"'[$P(^AUPNPREF(I,0),U,7)
  1. ...Q:D>(9999999-BDATE)
  1. ...Q:D<(9999999-EDATE)
  1. ...S BGPC=BGPC+1
  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)
  1. ..Q
  1. .Q
  1. S (X,G)=0,Y=$O(^AUTTIMM("C",33,0)) F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
  1. .S R=$P(^BIPC(X,0),U,3)
  1. .Q:R=""
  1. .Q:'$D(^BICONT(R,0))
  1. .Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1. .S D=$P(^BIPC(X,0),U,4)
  1. .Q:D=""
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 33 "_$$DATE^BGP0UTL(D)
  1. 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
  1. .S R=$P(^BIPC(X,0),U,3)
  1. .Q:R=""
  1. .Q:'$D(^BICONT(R,0))
  1. .Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1. .S D=$P(^BIPC(X,0),U,4)
  1. .Q:D=""
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 100 "_$$DATE^BGP0UTL(D)
  1. 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
  1. .S R=$P(^BIPC(X,0),U,3)
  1. .Q:R=""
  1. .Q:'$D(^BICONT(R,0))
  1. .Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1. .S D=$P(^BIPC(X,0),U,4)
  1. .Q:D=""
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 109 "_$$DATE^BGP0UTL(D)
  1. 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))
  1. ;bone marrow contraindication
  1. S X=$$LASTPRC^BGP0UTL1(P,"BGP CMS BONE MARROW PROC",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
  1. I X S BGPC=BGPC+1,BGPY(BGPC)="Bone Marrow Contraindication: ["_$P(X,U,2)_"] "_$$DATE^BGP0UTL($P(X,U,3))
  1. S X=$$CPT^BGP0DU(P,$$FMADD^XLFDT(BGPDD,-365),BGPDD,$O(^ATXAX("B","BGP CMS BONE MARROW CPT",0)),6)
  1. I X S BGPC=BGPC+1,BGPY(BGPC)="Bone Marrow Contraindication: ["_$P(X,U,3)_"] "_$$DATE^BGP0UTL($P(X,U,2))
  1. Q