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

BDMPF12.m

Go to the documentation of this file.
  1. BDMPF12 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
  1. ;;2.0;DIABETES MANAGEMENT SYSTEM;**11**;JUN 14, 2007;Build 30
  1. ;
  1. ;cmi/anch/maw 9/10/2007 code set versioning in HYSTER,MAMMOG
  1. ;
  1. SETN ;
  1. S N="" NEW A,G S (A,G)=0 F S A=$O(BDM(A)) Q:A'=+A!(G) I $P(^AUPNVLAB(+$P(BDM(A),U,4),0),U,4)]"" S G=A
  1. S N=$S(G:G,1:1)
  1. Q
  1. TBTX(P) ;EP
  1. I '$G(P) Q ""
  1. NEW BDM,E,X
  1. K BDM
  1. S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDM(")
  1. I E Q ""
  1. I $D(BDM(1)) Q $P(BDM(1),U,3)_U_$S($P(BDM(1),U,3)["TX COMPLETE":"1 Yes",$P(BDM(1),U,3)["TX INCOMPLETE"!($P(BDM(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")
  1. N T,Y S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
  1. I 'T Q ""
  1. N G S G="",X=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(G]"") I $D(^ATXAX(T,21,"B",X)) S G=$P(^AUTTHF(X,0),U)
  1. I G]"" Q G_U_$S(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")
  1. Q ""
  1. CPT(P,BDATE,EDATE,T,F) ;EP return ien of CPT entry if patient had this CPT
  1. I '$G(P) Q ""
  1. I $G(T)="" Q ""
  1. I '$G(F) S F=1
  1. I $G(EDATE)="" Q ""
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. ;go through visits in a date range for this patient, check cpts
  1. NEW D,BD,ED,X,Y,D,G,V
  1. S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  1. F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
  1. .S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
  1. ..Q:'$D(^AUPNVSIT(V,0))
  1. ..Q:'$D(^AUPNVCPT("AD",V))
  1. ..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
  1. ...I $$ICD^BDMUTL($P(^AUPNVCPT(X,0),U),T,1) S G=X
  1. ...Q
  1. ..Q
  1. .Q
  1. I 'G Q ""
  1. I F=1 Q $S(G:1,1:"")
  1. I F=2 Q G
  1. I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1. I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1. Q ""
  1. RAD(P,BDATE,EDATE,T,F) ;EP return if a v rad entry in date range
  1. I '$G(P) Q ""
  1. I $G(T)="" Q ""
  1. I '$G(F) S F=1
  1. I $G(EDATE)="" Q ""
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. ;go through visits in a date range for this patient, check cpts
  1. NEW D,BD,ED,X,Y,D,G,V
  1. S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  1. F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
  1. .S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
  1. ..Q:'$D(^AUPNVSIT(V,0))
  1. ..Q:'$D(^AUPNVRAD("AD",V))
  1. ..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
  1. ...Q:'$D(^AUPNVRAD(X,0))
  1. ...S Y=$P(^AUPNVRAD(X,0),U) Q:'Y Q:'$D(^RAMIS(71,Y,0))
  1. ...S Y=$P($G(^RAMIS(71,Y,0)),U,9) Q:'Y
  1. ...Q:'$$ICD^BDMUTL(Y,T,1)
  1. ...S G=X
  1. ...Q
  1. ..Q
  1. .Q
  1. I 'G Q ""
  1. I F=1 Q $S(G:1,1:"")
  1. I F=2 Q G
  1. I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1. I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1. Q ""
  1. EKG(P,EDATE,F) ;EP
  1. I $G(F)="" S F="E"
  1. S %DT="P",X=EDATE D ^%DT S ED=Y
  1. NEW BDM,X,%,E,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
  1. I $D(BDM) S LEKG=$P(BDM(1),U)
  1. K BDM S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"BDM(")
  1. I $D(BDM(1)) D
  1. .Q:LEKG>$P(BDM(1),U)
  1. .S LEKG=$P(BDM(1),U)
  1. K BDM S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"BDM(")
  1. I $D(BDM(1)) D
  1. .Q:LEKG>$P(BDM(1),U)
  1. .S LEKG=$P(BDM(1),U)
  1. K BDM S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"BDM(")
  1. I $D(BDM(1)) D
  1. .Q:LEKG>$P(BDM(1),U)
  1. .S LEKG=$P(BDM(1),U)
  1. K BDM S %=P_"^LAST PROCEDURE 89.50",E=$$START1^APCLDF(%,"BDM(")
  1. I $D(BDM(1)) D
  1. .Q:LEKG>$P(BDM(1),U)
  1. .S LEKG=$P(BDM(1),U)
  1. K BDM S %=P_"^LAST DX 794.31",E=$$START1^APCLDF(%,"BDM(")
  1. I $D(BDM(1)) D
  1. .Q:LEKG>$P(BDM(1),U)
  1. .S LEKG=$P(BDM(1),U)
  1. ;check CPT codes in year prior to date range
  1. S T=$O(^ATXAX("B","DM AUDIT EKG CPTS",0))
  1. K BDM I T S BDM(1)=$$CPT^BDMPF12(P,,ED,"DM AUDIT EKG CPTS",3) D
  1. .I BDM(1)="" K BDM Q
  1. .Q:LEKG>$P(BDM(1),U)
  1. .S LEKG=$P(BDM(1),U)
  1. K BDM I T S BDM(1)=$$RAD^BDMPF12(P,,ED,"DM AUDIT EKG CPTS",3) D
  1. .I BDM(1)="" K BDM Q
  1. .Q:LEKG>$P(BDM(1),U)
  1. .S LEKG=$P(BDM(1),U)
  1. Q $S(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
  1. ;
  1. ALT(P,BDATE,EDATE) ;EP
  1. NEW BDM,X,%,E,R,V
  1. K BDM
  1. S %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
  1. I '$D(BDM(1)) Q ""
  1. S D=$P(BDM(1),U),D=$$FMTE^XLFDT(D) K BDM S %=P_"^ALL LAB [DM AUDIT ALT TAX;DURING "_D_"-"_D,E=$$START1^APCLDF(%,"BDM(")
  1. NEW N D SETN
  1. Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_" "_$$FMTE^XLFDT($P(BDM(N),U),5)
  1. AST(P,BDATE,EDATE) ;EP
  1. NEW BDM,X,%,E,R,V
  1. K BDM
  1. S %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
  1. I '$D(BDM(1)) Q ""
  1. S D=$P(BDM(1),U),D=$$FMTE^XLFDT(D) K BDM S %=P_"^ALL LAB [DM AUDIT AST TAX;DURING "_D_"-"_D,E=$$START1^APCLDF(%,"BDM(")
  1. NEW N D SETN
  1. Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_" "_$$FMTE^XLFDT($P(BDM(N),U),5)
  1. INSULIN(P,BDATE,EDATE) ;EP
  1. NEW X,BDM,E
  1. S X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
  1. I $D(BDM(1)) Q "X"
  1. Q ""
  1. TXNAME(V) ;EP
  1. I $G(V)="" Q ""
  1. S V=$$TXNAMES(V)
  1. Q $E(V,1,16)
  1. TXNAMES(Y) ;
  1. I Y=1 Q "DIET"
  1. I Y=2 Q "INSULIN"
  1. I Y=3 Q "SULFONYLUREA"
  1. I Y=4 Q "METFORMIN (GLUCOPHAGE)"
  1. I Y=5 Q "ACARBOSE OR MIGLITOL"
  1. I Y=6 Q "GLITAZONE"
  1. I Y=9 Q "UNKNOWN/REFUSED"
  1. I Y=23 Q "INSULIN+S'UREA"
  1. I Y=24 Q "INSULIN+MET"
  1. I Y=25 Q "INSULIN+ACAR"
  1. I Y=26 Q "INSULIN+GLITAZONE"
  1. I Y=34 Q "S'UREA+MET"
  1. I Y=35 Q "S'UREA+ACAR"
  1. I Y=36 Q "S'UREA+GLITAZONE"
  1. I Y=45 Q "MET+ACAR"
  1. I Y=46 Q "MET+GLITAZONE"
  1. I Y=56 Q "ACAR+GLITAZONE"
  1. I Y=234 Q "INS+S'UREA+MET"
  1. I Y=235 Q "INS+S'UREA+ACAR"
  1. I Y=236 Q "INS+S'UREA+GLIT"
  1. I Y=245 Q "INS+MET+ACAR"
  1. I Y=246 Q "INS+MET+GLITAZONE"
  1. I Y=256 Q "INS+ACAR+GLITAZONE"
  1. I Y=345 Q "S'UREA+MET+ACAR"
  1. I Y=346 Q "S'UREA+MET+GLIT"
  1. I Y=356 Q "S'UREA+ACAR+GLIT"
  1. I Y=456 Q "MET+ACAR+GLIT"
  1. Q ""
  1. LOINC(A,B) ;
  1. NEW %
  1. S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1. I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1. S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1. I $D(^ATXAX(B,21,"B",%)) Q 1
  1. Q ""