BGP8C11 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 8:31 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
ACEIALG1(P,BGPD,BGPY) ;EP
NEW ED,BD,BGPG,BGPC,X,Y,Z,N
S:$G(BGPC)="" BGPC=0
S ED=$$FMADD^XLFDT(BGPD,-365)
ACEIPOV ;
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["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2) Q
.S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"]" Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"]" Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP8UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP8UTL2(Z),U,2)_"]" Q
.Q
S G=""
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ADV EFF ANTIHYPER 10;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) S BGPC=BGPC+1,BGPY(BGPC)="ADR POV: "_$$DATE^BGP8UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"]"
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["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)
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^BGP8UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>BGPD
.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^BGP8UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP8UTL2(I,T,9)),N["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y_" "_N Q
.I $$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP ADV EFF ANTIHYPER 10",0)),9) S BGPC=BGPC+1,BGPY(BGPC)="ADR PROBLEM LIST: "_$$DATE^BGP8UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] " Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP ADR ACEI",S)) S BGPC=BGPC+1,BGPY(BGPC)="ADR PROBLEM LIST: "_$$DATE^BGP8UTL($P(^AUPNPROB(X,0),U,8))_" ["_S_"] " Q
.Q
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
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ACEI"!(N["ACE INHIBITOR") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP8UTL($P(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "
D ARBALG1^BGP8C13
Q
DSCH(H) ;
Q $P($P(^AUPNVINP(H,0),U),".")
BGP8C11 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 8:31 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
ACEIALG1(P,BGPD,BGPY) ;EP
+1 NEW ED,BD,BGPG,BGPC,X,Y,Z,N
+2 IF $GET(BGPC)=""
SET BGPC=0
+3 SET ED=$$FMADD^XLFDT(BGPD,-365)
ACEIPOV ;
+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["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
QUIT
+5 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"]"
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"]"
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP8UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP8UTL2(Z),U,2)_"]"
QUIT
+9 QUIT
End DoDot:1
+10 SET G=""
+11 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ADV EFF ANTIHYPER 10;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+12 IF $DATA(BGPG(1))
SET BGPC=BGPC+1
SET BGPY(BGPC)="ADR POV: "_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"]"
+13 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)
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+15 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+16 IF N["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
End DoDot:1
+17 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+18 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+19 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP8UTL2(I),U,2)
+20 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+21 IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+22 ;doo
IF $PIECE(^AUPNPROB(X,0),U,13)]""
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+23 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+24 ;Q:$P(^AUPNPROB(X,0),U,12)="I"
+25 IF $$ICD^BGP8UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP8UTL2(I,T,9))
IF N["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y_" "_N
QUIT
+26 IF $$ICD^BGP8UTL2(I,$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPER 10",0)),9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="ADR PROBLEM LIST: "_$$DATE^BGP8UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "
QUIT
+27 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+28 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP ADR ACEI",S))
SET BGPC=BGPC+1
SET BGPY(BGPC)="ADR PROBLEM LIST: "_$$DATE^BGP8UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_S_"] "
QUIT
+29 QUIT
End DoDot:1
+30 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+31 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
QUIT
+32 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+33 IF N["ACEI"!(N["ACE INHIBITOR")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP8UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "
End DoDot:1
+34 DO ARBALG1^BGP8C13
+35 QUIT
DSCH(H) ;
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
