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

BGP5ALG2.m

Go to the documentation of this file. 
  1. BGP5ALG2 ; IHS/CMI/LAB - measure AHR.A ;
  1.  ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
  1.  ;
  1.  ;
  1.  ;
  1. STATIN ;EP
  1.  I $G(P)="" Q ""
  1.  S EDATE=$G(EDATE)
  1.  I EDATE="" S EDATE=DT
  1.  I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
  1.  NEW BGPC,BGPG,BGPY,Y,X,E,N,T,I,BGPLT,D,B,L,T2,BGPLT2
  1.  S BGPC=""
  1.  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)
  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["STATIN"!(N["STATINS") S BGPC=1_U_"Alg Statin POV:  "_$$DATE^BGP5UTL($P(BGPG(X),U))_"  ["_$P(BGPG(X),U,2)_"]  "_N Q
  1.  .S T=$O(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
  1.  .S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP5UTL2(Z,T,9) S G=1_U_"POV:  "_$$DATE^BGP5UTL($P(BGPG(X),U))_"  ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP5UTL2(Z),U,2)_"]  "_N Q
  1.  .S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP5UTL2(Z,T,9) S G=1_U_"POV:  "_$$DATE^BGP5UTL($P(BGPG(X),U))_"  ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP5UTL2(Z),U,2)_"]  "_N Q
  1.  .S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP5UTL2(Z,T,9) S G=1_U_"POV:  "_$$DATE^BGP5UTL($P(BGPG(X),U))_"  ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP5UTL2(Z),U,2)_"]  "_N Q
  1.  .Q
  1.  I BGPC Q BGPC
  1.  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)
  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["STATIN"!(N["STATINS") S BGPC=1_U_"alg statin POV:  "_$$DATE^BGP5UTL($P(BGPG(X),U))_"  ["_$P(BGPG(X),U,2)_"]  "_N
  1.  I BGPC Q BGPC
  1.  ;now check problem list for these codes
  1.  S BGPC=0
  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^BGP5UTL2(I),U,2)
  1.  .S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE  ;added after discharge date
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1.  .I $$ICD^BGP5UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP5UTL2(I,T,9)),N["STATIN"!(N["STATINS") S BGPC=1_U_"alg statin PROBLEM LIST:  "_$$DATE^BGP5UTL($P(^AUPNPROB(X,0),U,8))_"  ["_Y_"]  "_N
  1.  .Q
  1.  I BGPC Q BGPC
  1.  ;now check allergy tracking
  1.  S BGPC=0
  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),".")>EDATE
  1.  .S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
  1.  .I N["STATIN" S BGPC=1_U_" alg statin ALLERGY TRACKING:  "_$$DATE^BGP5UTL($P(^GMR(120.8,X,0),U,4))_"  "_N
  1.  I BGPC Q BGPC
  1.  ;now go into the report period items
  1.  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)
  1.  I $D(BGPG(1)) Q 1_U_"Statin allergy POV:  "_$$DATE^BGP5UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"]    "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
  1.  ;creatine lab value > 10,000 or 10x uln
  1.  S BGPG=""
  1.  S T=$O(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
  1.  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
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...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^BGP5UTL((9999999-D)) Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BGP5D2(J,T)
  1.  ...I $$RESCK(X) S BGPG=1_U_"adr statin creat kinase of "_$P(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP5UTL((9999999-D)) Q
  1.  ...Q
  1.  I BGPG Q BGPG
  1.  S T=$O(^ATXAX("B","BGP ALT LOINC",0))
  1.  S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT TAX",0))
  1.  S T2=$O(^ATXAX("B","BGP AST LOINC",0))
  1.  S BGPLT2=$O(^ATXLAB("B","DM AUDIT AST TAX",0))
  1.  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
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...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
  1.  ...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
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...I '$$LOINC^BGP5D2(J,T),'$$LOINC^BGP5D2(J,T2)
  1.  ...S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
  1.  ...Q
  1.  ;are they 2 consecutive
  1.  S BGPG=""
  1.  S X=0 F  S X=$O(BGPC(X)) Q:X'=+X!(BGPG)  D
  1.  .Q:'$$RESAL(BGPC(X))
  1.  .;is next one also bad?
  1.  .S Y=$O(BGPC(X))
  1.  .Q:Y=""  ;no next one
  1.  .I $$RESAL(BGPC(Y)) S BGPG=1_U_"adr Statin - AST/ALT" Q
  1.  .Q
  1.  I BGPG Q BGPG
  1.  Q ""
  1.  ;
  1. RESAL(Y) ;
  1.  NEW V,ULN
  1.  S V=+$P(Y,U,2),ULN=$P(Y,U,3)
  1.  I ULN="" Q ""
  1.  I V>(ULN*3) Q 1
  1.  Q ""
  1. RESCK(Y) ;
  1.  NEW V,ULN
  1.  S V=+$P(^AUPNVLAB(X,0),U,4)
  1.  I V>10000 Q 1
  1.  S ULN=$P($G(^AUPNVLAB(X,11)),U,5)
  1.  I ULN="" Q 0
  1.  I V>(ULN*10) Q 1
  1.  Q 0