- BGP7C13 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
- ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- ;
- ARBALG1 ;EP does patient have an ARB allergy
- ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
- NEW ED,BD,BGPG,X,Y,Z,N
- ;BGPD is discharge date
- S:$G(BGPC)="" BGPC=0 ;cmi/maw 3/19/2010 this was commented out for some reason so it was undef in the next sub routine
- S ED=$$FMADD^XLFDT(BGPD,-365)
- ARBPOV ;
- K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPD) 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 BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2) Q
- .S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN ARB",0))
- .S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP7UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP7UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N Q
- .S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP7UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP7UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N Q
- .S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP7UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP7UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N Q
- .Q
- K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD) 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 BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)
- ;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 D
- .S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP7UTL2(I),U,2)
- .S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
- .Q:$P(^AUPNPROB(X,0),U,8)>BGPD ;added after discharge date
- .I $P(^AUPNPROB(X,0),U,13)]"",$P(^AUPNPROB(X,0),U,13)>EDATE Q ;doo
- .Q:$P(^AUPNPROB(X,0),U,12)="D"
- .;Q:$P(^AUPNPROB(X,0),U,12)="I"
- .I $$ICD^BGP7UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP7UTL2(I,T,9)),N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_Y_" "_N Q
- .S S=$$VAL^XBDIQ1(9000011,X,80001)
- .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP ADR ARB",S)) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_S_" "_N Q
- .Q
- ;now check allergy tracking
- 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),".")>BGPD ;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 BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING"
- Q
- ARBCON1 ;EP does patient have an ARB allergy
- ;nmi in refusal file for ARB
- S T=$O(^ATXAX("B","BGP CMS ARB MEDS",0))
- S Z=$$FMADD^XLFDT(BGPDDT,-365)
- 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 ARB
- .S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
- ..S Y=9999999-D I Y<Z Q ;documented more than 1 year before discharge
- ..I Y>BGPDDT 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 BGPC=BGPC+1,BGPY(BGPC)="NMI ARB: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP7UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
- ..Q
- .Q
- Q:BGPIND'=2
- S X=$$CPTI^BGP7DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
- I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8029: "_$$DATE^BGP7UTL($P(X,U,2))
- S X=$$TRANI^BGP7DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
- I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8029: "_$$DATE^BGP7UTL($P(X,U,2))
- Q
- ARBRX1 ;EP
- ;get last aspirin rx before date of adm
- NEW BGPG,BGPC,X,Y,Z,E,BD,ED
- S BGPC=0
- S ED=$$FMADD^XLFDT(BGPA,-1)
- S BD=$$FMADD^XLFDT(BGPA,-365)
- D GETMEDS^BGP7CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
- I BGPIND=2 D
- .S X=$$CPTI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- .I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
- .S X=$$TRANI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- .I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
- S BD=BGPA
- S ED=$$FMADD^XLFDT(BGPD,30)
- D GETMEDS^BGP7CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
- I BGPIND=2 D
- .S X=$$CPTI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- .I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
- .S X=$$TRANI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- .I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
- K BGPG
- Q
- DSCH(H) ;
- Q $P($P(^AUPNVINP(H,0),U),".")
- ACEICON1(P,BGPD,BGPDDT,BGPV,BGPY) ;EP have an ACEI allergy
- NEW ED,BD,BGPG,BGPC,X,Y,Z,N,E
- S BGPC=0 K BGPY
- S BD=$$FMADD^XLFDT(BGPD,-365)
- K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP CMS AORTIC STENOSIS DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPDDT) S E=$$START1^APCLDF(X,Y)
- I $D(BGPG(1)) S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP7UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
- ;
- ;nmi in refusal file for ACEI
- S T=$O(^ATXAX("B","BGP CMS ACEI MEDS",0))
- S Z=$$FMADD^XLFDT(BGPDDT,-365)
- 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 ACEI
- .S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
- ..S Y=9999999-D I Y<Z Q ;documented more than 1 year before disc
- ..I Y>BGPDDT 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 BGPC=BGPC+1,BGPY(BGPC)="NMI ACEI: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP7UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
- ..Q
- .Q
- D ARBCON1
- Q
- BGP7C13 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
- +1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- +2 ;
- ARBALG1 ;EP does patient have an ARB allergy
- +1 ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
- +2 NEW ED,BD,BGPG,X,Y,Z,N
- +3 ;BGPD is discharge date
- +4 ;cmi/maw 3/19/2010 this was commented out for some reason so it was undef in the next sub routine
- IF $GET(BGPC)=""
- SET BGPC=0
- +5 SET ED=$$FMADD^XLFDT(BGPD,-365)
- ARBPOV ;
- +1 KILL BGPG
- SET Y="BGPG("
- SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPD)
- SET E=$$START1^APCLDF(X,Y)
- +2 SET X=0
- FOR
- SET X=$ORDER(BGPG(X))
- IF X'=+X
- QUIT
- SET Y=+$PIECE(BGPG(X),U,4)
- Begin DoDot:1
- +3 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
- SET N=$$UP^XLFSTR(N)
- +4 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
- SET BGPC=BGPC+1
- SET BGPY(BGPC)=$$DATE^BGP7UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
- QUIT
- +5 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN ARB",0))
- +6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
- IF Z]""
- IF $$ICD^BGP7UTL2(Z,T,9)
- SET G=1_U_"POV: "_$$DATE^BGP7UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N
- QUIT
- +7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
- IF Z]""
- IF $$ICD^BGP7UTL2(Z,T,9)
- SET G=1_U_"POV: "_$$DATE^BGP7UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N
- QUIT
- +8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
- IF Z]""
- IF $$ICD^BGP7UTL2(Z,T,9)
- SET G=1_U_"POV: "_$$DATE^BGP7UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N
- QUIT
- +9 QUIT
- End DoDot:1
- +10 KILL BGPG
- SET Y="BGPG("
- SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD)
- SET E=$$START1^APCLDF(X,Y)
- +11 SET X=0
- FOR
- SET X=$ORDER(BGPG(X))
- IF X'=+X
- QUIT
- SET Y=+$PIECE(BGPG(X),U,4)
- Begin DoDot:1
- +12 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
- SET N=$$UP^XLFSTR(N)
- +13 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
- SET BGPC=BGPC+1
- SET BGPY(BGPC)=$$DATE^BGP7UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
- End DoDot:1
- +14 ;now check problem list for these codes
- +15 SET T=""
- SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
- +16 SET X=0
- FOR
- SET X=$ORDER(^AUPNPROB("AC",P,X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +17 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
- SET Y=$PIECE($$ICDDX^BGP7UTL2(I),U,2)
- +18 SET N=$$VAL^XBDIQ1(9000011,X,.05)
- SET N=$$UP^XLFSTR(N)
- +19 ;added after discharge date
- IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
- QUIT
- +20 ;doo
- IF $PIECE(^AUPNPROB(X,0),U,13)]""
- IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
- QUIT
- +21 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
- QUIT
- +22 ;Q:$P(^AUPNPROB(X,0),U,12)="I"
- +23 IF $$ICD^BGP7UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP7UTL2(I,T,9))
- IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
- SET BGPC=BGPC+1
- SET BGPY(BGPC)=$$DATE^BGP7UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_Y_" "_N
- QUIT
- +24 SET S=$$VAL^XBDIQ1(9000011,X,80001)
- +25 IF S]""
- IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP ADR ARB",S))
- SET BGPC=BGPC+1
- SET BGPY(BGPC)=$$DATE^BGP7UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_S_" "_N
- QUIT
- +26 QUIT
- End DoDot:1
- +27 ;now check allergy tracking
- +28 SET X=0
- FOR
- SET X=$ORDER(^GMR(120.8,"B",P,X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +29 ;entered after discharge date
- IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
- 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 BGPC=BGPC+1
- SET BGPY(BGPC)=$$DATE^BGP7UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING"
- End DoDot:1
- +32 QUIT
- ARBCON1 ;EP does patient have an ARB allergy
- +1 ;nmi in refusal file for ARB
- +2 SET T=$ORDER(^ATXAX("B","BGP CMS ARB MEDS",0))
- +3 SET Z=$$FMADD^XLFDT(BGPDDT,-365)
- +4 SET X=0
- FOR
- SET X=$ORDER(^AUPNPREF("AA",P,50,X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +5 ;not an ARB
- IF '$DATA(^ATXAX(T,21,"B",X))
- QUIT
- +6 SET D=0
- FOR
- SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
- IF D'=+D
- QUIT
- Begin DoDot:2
- +7 ;documented more than 1 year before discharge
- SET Y=9999999-D
- IF Y<Z
- QUIT
- +8 ;documented after discharge
- IF Y>BGPDDT
- QUIT
- +9 SET N=0
- FOR
- SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
- IF N'=+N
- QUIT
- Begin DoDot:3
- +10 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
- QUIT
- +11 SET BGPC=BGPC+1
- SET BGPY(BGPC)="NMI ARB: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP7UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
- End DoDot:3
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 IF BGPIND'=2
- QUIT
- +15 SET X=$$CPTI^BGP7DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
- +16 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="CPT code G8029: "_$$DATE^BGP7UTL($PIECE(X,U,2))
- +17 SET X=$$TRANI^BGP7DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
- +18 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Tran Code G8029: "_$$DATE^BGP7UTL($PIECE(X,U,2))
- +19 QUIT
- ARBRX1 ;EP
- +1 ;get last aspirin rx before date of adm
- +2 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
- +3 SET BGPC=0
- +4 SET ED=$$FMADD^XLFDT(BGPA,-1)
- +5 SET BD=$$FMADD^XLFDT(BGPA,-365)
- +6 DO GETMEDS^BGP7CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
- +7 IF BGPIND=2
- Begin DoDot:1
- +8 SET X=$$CPTI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- +9 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP7UTL($PIECE(X,U,2))
- +10 SET X=$$TRANI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- +11 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP7UTL($PIECE(X,U,2))
- End DoDot:1
- +12 SET BD=BGPA
- +13 SET ED=$$FMADD^XLFDT(BGPD,30)
- +14 DO GETMEDS^BGP7CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
- +15 IF BGPIND=2
- Begin DoDot:1
- +16 SET X=$$CPTI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- +17 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP7UTL($PIECE(X,U,2))
- +18 SET X=$$TRANI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
- +19 IF X
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP7UTL($PIECE(X,U,2))
- End DoDot:1
- +20 KILL BGPG
- +21 QUIT
- DSCH(H) ;
- +1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
- ACEICON1(P,BGPD,BGPDDT,BGPV,BGPY) ;EP have an ACEI allergy
- +1 NEW ED,BD,BGPG,BGPC,X,Y,Z,N,E
- +2 SET BGPC=0
- KILL BGPY
- +3 SET BD=$$FMADD^XLFDT(BGPD,-365)
- +4 KILL BGPG
- SET Y="BGPG("
- SET X=P_"^LAST DX [BGP CMS AORTIC STENOSIS DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPDDT)
- SET E=$$START1^APCLDF(X,Y)
- +5 IF $DATA(BGPG(1))
- SET BGPC=BGPC+1
- SET BGPY(BGPC)="POV: "_$$DATE^BGP7UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(1),U,4),.04)
- +6 ;
- +7 ;nmi in refusal file for ACEI
- +8 SET T=$ORDER(^ATXAX("B","BGP CMS ACEI MEDS",0))
- +9 SET Z=$$FMADD^XLFDT(BGPDDT,-365)
- +10 SET X=0
- FOR
- SET X=$ORDER(^AUPNPREF("AA",P,50,X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +11 ;not an ACEI
- IF '$DATA(^ATXAX(T,21,"B",X))
- QUIT
- +12 SET D=0
- FOR
- SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
- IF D'=+D
- QUIT
- Begin DoDot:2
- +13 ;documented more than 1 year before disc
- SET Y=9999999-D
- IF Y<Z
- QUIT
- +14 ;documented after discharge
- IF Y>BGPDDT
- QUIT
- +15 SET N=0
- FOR
- SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
- IF N'=+N
- QUIT
- Begin DoDot:3
- +16 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
- QUIT
- +17 SET BGPC=BGPC+1
- SET BGPY(BGPC)="NMI ACEI: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP7UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
- End DoDot:3
- +18 QUIT
- End DoDot:2
- +19 QUIT
- End DoDot:1
- +20 DO ARBCON1
- +21 QUIT