- 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),".")
