BGP4ALG2 ; IHS/CMI/LAB - measure AHR.A ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
;
;
STATIN ;EP
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
NEW BGPC,BGPG,BGPY,Y,X,E,N,T,I,BGPLT,D,B,L,T2,BGPLT2
S BGPC=""
K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$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["STATIN"!(N["STATINS") S BGPC=1_U_"Alg Statin POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N Q
.Q
I BGPC Q BGPC
K BGPG S BGPC=0 S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$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["STATIN"!(N["STATINS") S BGPC=1_U_"alg statin POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I BGPC Q BGPC
;now check problem list for these codes
S BGPC=0
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^BGP4UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;added after discharge date
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP4UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP4UTL2(I,T,9)),N["STATIN"!(N["STATINS") S BGPC=1_U_"alg statin PROBLEM LIST: "_$$DATE^BGP4UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I BGPC Q BGPC
;now check allergy tracking
S BGPC=0
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),".")>EDATE
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["STATIN" S BGPC=1_U_" alg statin ALLERGY TRACKING: "_$$DATE^BGP4UTL($P(^GMR(120.8,X,0),U,4))_" "_N
I BGPC Q BGPC
;now go into the report period items
K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_"Statin allergy POV: "_$$DATE^BGP4UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
;creatine lab value > 10,000 or 10x uln
S BGPG=""
S T=$O(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) I $$RESCK(X) S BGPG=1_U_"adr statin creat kinase of "_$P(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP4UTL((9999999-D)) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP4D2(J,T)
...I $$RESCK(X) S BGPG=1_U_"adr statin creat kinase of "_$P(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP4UTL((9999999-D)) Q
...Q
I BGPG Q BGPG
S T=$O(^ATXAX("B","BGP ALT LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT TAX",0))
S T2=$O(^ATXAX("B","BGP AST LOINC",0))
S BGPLT2=$O(^ATXLAB("B","DM AUDIT AST TAX",0))
S B=9999999-$$FMADD^XLFDT(EDATE,-365),E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...I BGPLT2,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT2,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...I '$$LOINC^BGP4D2(J,T),'$$LOINC^BGP4D2(J,T2)
...S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...Q
;are they 2 consecutive
S BGPG=""
S X=0 F S X=$O(BGPC(X)) Q:X'=+X!(BGPG) D
.Q:'$$RESAL(BGPC(X))
.;is next one also bad?
.S Y=$O(BGPC(X))
.Q:Y="" ;no next one
.I $$RESAL(BGPC(Y)) S BGPG=1_U_"adr Statin - AST/ALT" Q
.Q
I BGPG Q BGPG
Q ""
;
RESAL(Y) ;
NEW V,ULN
S V=+$P(Y,U,2),ULN=$P(Y,U,3)
I ULN="" Q ""
I V>(ULN*3) Q 1
Q ""
RESCK(Y) ;
NEW V,ULN
S V=+$P(^AUPNVLAB(X,0),U,4)
I V>10000 Q 1
S ULN=$P($G(^AUPNVLAB(X,11)),U,5)
I ULN="" Q 0
I V>(ULN*10) Q 1
Q 0
BGP4ALG2 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
+3 ;
+4 ;
STATIN ;EP
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+5 NEW BGPC,BGPG,BGPY,Y,X,E,N,T,I,BGPLT,D,B,L,T2,BGPLT2
+6 SET BGPC=""
+7 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+8 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+9 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+10 IF N["STATIN"!(N["STATINS")
SET BGPC=1_U_"Alg Statin POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+11 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
+12 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N
QUIT
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N
QUIT
+14 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N
QUIT
+15 QUIT
End DoDot:1
+16 IF BGPC
QUIT BGPC
+17 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+18 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+19 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+20 IF N["STATIN"!(N["STATINS")
SET BGPC=1_U_"alg statin POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+21 IF BGPC
QUIT BGPC
+22 ;now check problem list for these codes
+23 SET BGPC=0
+24 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+25 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+26 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP4UTL2(I),U,2)
+27 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+28 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+29 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+30 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+31 IF $$ICD^BGP4UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP4UTL2(I,T,9))
IF N["STATIN"!(N["STATINS")
SET BGPC=1_U_"alg statin PROBLEM LIST: "_$$DATE^BGP4UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+32 QUIT
End DoDot:1
+33 IF BGPC
QUIT BGPC
+34 ;now check allergy tracking
+35 SET BGPC=0
+36 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+37 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+38 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+39 IF N["STATIN"
SET BGPC=1_U_" alg statin ALLERGY TRACKING: "_$$DATE^BGP4UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+40 IF BGPC
QUIT BGPC
+41 ;now go into the report period items
+42 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+43 IF $DATA(BGPG(1))
QUIT 1_U_"Statin allergy POV: "_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(1),U,4),.04)
+44 ;creatine lab value > 10,000 or 10x uln
+45 SET BGPG=""
+46 SET T=$ORDER(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
+47 SET BGPLT=$ORDER(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
+48 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPG)
QUIT
Begin DoDot:1
+49 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+50 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+51 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+52 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
IF $$RESCK(X)
SET BGPG=1_U_"adr statin creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP4UTL((9999999-D))
QUIT
+53 IF 'T
QUIT
+54 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+55 IF '$$LOINC^BGP4D2(J,T)
QUIT
+56 IF $$RESCK(X)
SET BGPG=1_U_"adr statin creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP4UTL((9999999-D))
QUIT
+57 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+58 IF BGPG
QUIT BGPG
+59 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+60 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+61 SET T2=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+62 SET BGPLT2=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+63 SET B=9999999-$$FMADD^XLFDT(EDATE,-365)
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPG)
QUIT
Begin DoDot:1
+64 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+65 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+66 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+67 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+68 IF BGPLT2
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT2,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+69 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+70 IF '$$LOINC^BGP4D2(J,T)
IF '$$LOINC^BGP4D2(J,T2)
+71 SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+72 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+73 ;are they 2 consecutive
+74 SET BGPG=""
+75 SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X!(BGPG)
QUIT
Begin DoDot:1
+76 IF '$$RESAL(BGPC(X))
QUIT
+77 ;is next one also bad?
+78 SET Y=$ORDER(BGPC(X))
+79 ;no next one
IF Y=""
QUIT
+80 IF $$RESAL(BGPC(Y))
SET BGPG=1_U_"adr Statin - AST/ALT"
QUIT
+81 QUIT
End DoDot:1
+82 IF BGPG
QUIT BGPG
+83 QUIT ""
+84 ;
RESAL(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(Y,U,2)
SET ULN=$PIECE(Y,U,3)
+3 IF ULN=""
QUIT ""
+4 IF V>(ULN*3)
QUIT 1
+5 QUIT ""
RESCK(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(^AUPNVLAB(X,0),U,4)
+3 IF V>10000
QUIT 1
+4 SET ULN=$PIECE($GET(^AUPNVLAB(X,11)),U,5)
+5 IF ULN=""
QUIT 0
+6 IF V>(ULN*10)
QUIT 1
+7 QUIT 0
