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

BDMD618.m

Go to the documentation of this file. 
  1. BDMD618 ; IHS/CMI/LAB - 2006 DIABETES AUDIT ;
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
  1.  ;
  1.  ;cmi/anch/maw 9/12/2007 code set versioning in WT
  1.  ;
  1. HT(P,BDATE,EDATE) ;EP
  1.  I 'P Q ""
  1.  NEW %,BDMARRY,H,E
  1.  S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
  1.  I H="" Q H
  1.  I H["?" Q ""
  1.  S H=$J(H,5,2)
  1.  Q H
  1. WT(P,BDATE,EDATE) ;EP
  1.  I 'P Q ""
  1.  NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD
  1.  K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
  1.  S BDMN=0 F  S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"")  D
  1.  .S BDMZ=$P(BDM(BDMN),U,5)
  1.  .I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2) Q
  1.  . S BDMD=0 F  S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"")  D
  1.  .. ;S ICD=$P(^ICD9($P(^AUPNVPOV(BDMD,0),U),0),U) D  ;cmi/anch/maw 9/12/2007 orig line
  1.  .. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BDMD,0),U)),U,2) D  ;cmi/anch/maw 9/12/2007 csv
  1.  ...I $E(ICD,1,3)="V22" Q
  1.  ...I $E(ICD,1,3)="V23" Q
  1.  ...I $E(ICD,1,3)="V27" Q
  1.  ...I $E(ICD,1,3)="V28" Q
  1.  ...I ICD>629.9999&(ICD<676.95) Q
  1.  ...I ICD>61.49&(ICD<61.71) Q
  1.  ...S BDMW=$P(BDM(BDMN),U,2)
  1.  ..Q
  1.  Q BDMW
  1. BMI(P,BDATE,EDATE) ;EP
  1.  I 'P Q -1
  1.  NEW %,W,H,B,D,%DT,X
  1.  S %DT="P",X=EDATE D ^%DT S D=Y
  1.  S %=""
  1.  ;W !,$$HRN^AUPNPAT(P,DUZ(2))
  1.  D  Q %
  1.  .S W=$$WT(P,$$FMADD^XLFDT(D,-(2*365)),EDATE) Q:W=""  S W=W+.5,W=$P(W,".")
  1.  .;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
  1.  .S HDATE=$P(^DPT(P,0),U,3)
  1.  .S H=$$HT(P,HDATE,EDATE) I H="" Q
  1.  .;W U,W,U,H
  1.  .S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
  1.  .Q
  1.  Q
  1.  ;S X=$$HTWTSD(P,BDATE,EDATE)
  1.  ;I '$P(X,"^") Q %
  1.  ;I '$P(X,"^",2) Q %
  1.  ;S W=$P(X,"^"),H=$P(X,"^",2),W=W+.5,W=$P(W,"."),H=$J(H,5,2)
  1.  ;W U,W,U,H
  1.  ;S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
  1.  ;W U,%
  1.  ;Q %
  1. HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
  1.  I '$G(P) Q ""
  1.  NEW BDMWTS,BDMHTS,%,X,BDMWTS1,BDMHTS1
  1.  ;get all hts during time frame
  1.  S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMHTS(")
  1.  ;set the array up by date
  1.  K BDMHTS1 S X=0 F  S X=$O(BDMHTS(X)) Q:X'=+X  S BDMHTS1($P(BDMHTS(X),U))=X
  1.  ;get all wts during time frame
  1.  S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMWTS(")
  1.  ;set the array up by date
  1.  K BDMWTS1 S X=0 F  S X=$O(BDMWTS(X)) Q:X'=+X  S BDMWTS1($P(BDMWTS(X),U))=X
  1.  NEW BDMCHT S BDMCHT="",X=9999999 F  S X=$O(BDMWTS1(X),-1) Q:X=""!(BDMCHT]"")  I $D(BDMHTS1(X)) S BDMCHT=$P(BDMWTS(BDMWTS1(X)),U,2)_U_$P(BDMHTS(BDMHTS1(X)),U,2)
  1.  Q BDMCHT
  1. CREAT(P,BDATE,EDATE,F) ;EP
  1.  G CREAT^BDMD61C
  1. CHOL(P,BDATE,EDATE,F) ;EP
  1.  G CHOL^BDMD61C
  1. HDL(P,BDATE,EDATE,F) ;EP
  1.  G HDL^BDMD61C
  1. LDL(P,BDATE,EDATE,F) ;EP
  1.  G LDL^BDMD61C
  1. TRIG(P,BDATE,EDATE,F) ;EP
  1.  G TRIG^BDMD61C
  1. URIN(P,BDATE,EDATE) ;EP
  1.  G URIN^BDMD61C
  1. PROTEIN(P,BDATE,EDATE) ;EP
  1.  G PROTEIN^BDMD61C
  1. MICRO(P,BDATE,EDATE) ;EP
  1.  G MICRO^BDMD61C
  1. HGBA1C(P,BDATE,EDATE) ;EP
  1.  G HGBA1C^BDMD61C
  1. BS(P,BDATE,EDATE) ;EP
  1.  G BS^BDMD61C
  1. PPDS(P) ;
  1.  NEW BDMS,E,X
  1.  K BDMS
  1.  S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")
  1.  I $D(BDMS) Q 1
  1.  N T S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
  1.  I 'T G PPDSPL
  1.  N G S G=0,X=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X  I $D(^ATXAX(T,21,"B",X)) S G=1
  1.  I G Q 1
  1. PPDSPL ;CHECK PL
  1.  N T S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
  1.  I 'T Q ""
  1.  N X,Y,I S (X,Y,I)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=1
  1.  I I Q 1
  1.  ;check povs
  1.  K BDMS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"BDMS(")
  1.  I $D(BDMS(1)) Q 1
  1.  Q ""
  1. PPD(P,EDATE,F) ;EP
  1.  I $G(F)="" S F="E"
  1.  NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED
  1.  S X=EDATE,%DT="P" D ^%DT S ED=Y
  1.  I $$PPDS(P) Q "POS"
  1.  K BDM
  1.  S X=$O(^AUTTSK("B","PPD",0)) I 'X Q ""
  1.  S G=0,D=9999999-ED-1 F  S D=$O(^AUPNVSK("AA",P,X,D)) Q:D=""  S G=0 F  S G=$O(^AUPNVSK("AA",P,X,D,G)) Q:G'=+G  S BDM(D,G)=$P($P(^AUPNVSIT($P(^AUPNVSK(G,0),U,3),0),U),".")_U_$P(^AUPNVSK(G,0),U,5)_U_$P(^AUPNVSK(G,0),U,4)
  1.  I '$O(BDM(0)) D  Q $S(G:"Refused",1:"Unknown")
  1.  .S X=EDATE,%DT="P" D ^%DT S BDATE=$$FMADD^XLFDT(Y,-365),BDATE=$$FMTE^XLFDT(BDATE),G=0 I $$REFUSAL^BDMD617(P,9999999.28,$O(^AUTTSK("B","PPD",0)),BDATE,EDATE) S G=1
  1.  ;go through all ppds and find last reading or result
  1.  S G="",D=0,X=0 F  S D=$O(BDM(D)) Q:D'=+D!(G)  S X=0 F  S X=$O(BDM(D,X)) Q:X'=+X  S R=$P(BDM(D,X),U,2),R1=$P(BDM(D,X),U,3) I R]""!(R1]"") S G=1,R2=9999999-D
  1.  I F="I",(R]""!(R1]"")) Q R2
  1.  I R]"",R>9 Q "POS"
  1.  I R]"",R<10 Q "NEG"
  1.  I R1]"",R1="P" Q "POS"
  1.  I R1]"",R1="N" Q "NEG"
  1.  Q "Unknown"
  1.  ;
  1. LASTNP(P,EDATE) ;EP - last negative ppd
  1.  I $$PPD(P,EDATE)'="NEG" Q ""
  1.  Q $$PPD(P,EDATE,"I")
  1.  ;
  1. FGLUCOSE(P,BDATE,EDATE,F) ;EP
  1.  G FGLUCOSE^BDMD61C
  1. G75(P,BDATE,EDATE,F) ;EP
  1.  G G75^BDMD61C
  1.  ;
  1. STV(X,T) ;EP - strip hgba1c before epi export
  1.  I X="" Q X  ;no value in X so don't bother
  1.  Q $E(X,1,T)
  1.  NEW A,B,L
  1.  S L=$L(X)
  1.  F B=1:1:L S A=$E(X,B) Q:A=""  I A'?1N,A'?1"." S X=$$STRIP^XLFSTR(X,A) S B=B-1
  1.  Q $E(X,1,T)