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

BDMD118.m

Go to the documentation of this file. 
  1. BDMD118 ; IHS/CMI/LAB - 2011 DIABETES AUDIT ;
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**4**;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,D,W
  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.  S E=$O(^AUTTMSR("B","HT",0))
  1.  S H=""
  1.  S D=0 F  S D=$O(^AUPNVMSR("AA",P,E,D)) Q:D'=+D!(H]"")  D
  1.  .S W=0 F  S W=$O(^AUPNVMSR("AA",P,E,D,W)) Q:W'=+W!(H]"")  D
  1.  ..Q:'$D(^AUPNVMSR(W,0))
  1.  ..Q:$P($G(^AUPNVMSR(W,2)),U,1)  ;entered in error
  1.  ..S H=$P(^AUPNVMSR(W,0),U,4)
  1.  ..S BDMARRAY(1)=$$VD^APCLV($P(^AUPNVMSR(W,0),U,3))
  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,BDMVF
  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 BDMVF=+$P(BDM(BDMN),U,4)
  1.  .Q:$P($G(^AUPNVMSR(BDMVF,2)),U,1)  ;entered in error
  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($$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.  ...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.  D  Q %
  1.  .S W=$$WT(P,$$FMADD^XLFDT(D,-365),EDATE) Q:W=""  S W=W+.5,W=$P(W,".")
  1.  .S HDATE=$P(^DPT(P,0),U,3)
  1.  .S H=$$HT(P,HDATE,EDATE) I H="" Q
  1.  .S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
  1.  .Q
  1.  Q
  1. CREAT(P,BDATE,EDATE,F) ;EP
  1.  G CREAT^BDMD11C
  1. CHOL(P,BDATE,EDATE,F) ;EP
  1.  G CHOL^BDMD11C
  1. HDL(P,BDATE,EDATE,F) ;EP
  1.  G HDL^BDMD11C
  1. LDL(P,BDATE,EDATE,F) ;EP
  1.  G LDL^BDMD11C
  1. TRIG(P,BDATE,EDATE,F) ;EP
  1.  G TRIG^BDMD11C
  1. URIN(P,BDATE,EDATE) ;EP
  1.  G URIN^BDMD11H
  1. PROTEIN(P,BDATE,EDATE) ;EP
  1.  G PROTEIN^BDMD11C
  1. MICRO(P,BDATE,EDATE) ;EP
  1.  G MICRO^BDMD11C
  1. HGBA1C(P,BDATE,EDATE) ;EP
  1.  G HGBA1C^BDMD11D
  1. SEMI(P,BDATE,EDATE) ;EP
  1.  G SEMI^BDMD11C
  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_U_$$FMTE^XLFDT($P(BDMS(1),U))_"  HF: "_$P(BDMS(1),U,3)
  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=X
  1.  I I Q 1_U_$$VAL^XBDIQ1(9000011,I,.03)_"  Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
  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_U_$$FMTE^XLFDT($P(BDMS(1),U))_"  POV: "_$P(BDMS(1),U,3)
  1.  Q ""
  1. PPD(P,EDATE,F) ;EP
  1.  ;f 1=tb test done
  1.  ;f 2=tb result
  1.  S F=$G(F)
  1.  ;RETURN 1^1  Skin Test||1  Positive
  1.  NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR
  1.  S LD="",LR=""
  1.  S X=EDATE,%DT="P" D ^%DT S ED=Y
  1.  S G=$$PPDS(P) I G Q "1  TB Positive  "_$P(G,U,2)_"||1  Positive TB "_$P(G,U,2)  ;IF HAD HF or dx or pl of TB use it as positive
  1.  K BDM
  1.  ;get, in reverse order all skin tests and lab tests for TB testing  (BDM(inverse date,#)=ST or LAB^ien^result^reading
  1.  S X=$O(^AUTTSK("B","PPD",0))
  1.  S D=9999999-ED-1,C=0 F  S D=$O(^AUPNVSK("AA",P,X,D)) Q:D=""  D
  1.  .S G=0 F  S G=$O(^AUPNVSK("AA",P,X,D,G)) Q:G'=+G  D
  1.  ..Q:'$D(^AUPNVSK(G,0))
  1.  ..S C=C+1 S BDM(D,C)="ST"_U_G_U_$P(^AUPNVSK(G,0),U,5)_U_$S($P(^AUPNVSK(G,0),U,4)="D":"",$P(^AUPNVSK(G,0),U,4)="O":"",1:$P(^AUPNVSK(G,0),U,4))
  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.  ;S LD=R2
  1.  ;I R]"",R>9 S LR=1_U_1_U_"1  SKIN TEST"_U_"1  POSITIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1
  1.  ;I R]"",R<10 S LR=1_U_2_U_"1  SKIN TEST"_U_"2  NEGATIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1
  1.  ;I R1]"",R1="P" S LR=1_U_1_U_"1  SKIN TEST"_U_"1  POSITIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1
  1.  ;I R1]"",R1="N" S LR=1_U_2_U_"1  SKIN TEST"_U_"2  NEGATIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1
  1.  ;Now get last lab test, must have a result
  1.  S BDMC=0
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
  1.  S BDMOT=$O(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
  1.  S G="",E=9999999-ED S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G)  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.  ...Q:$P(^AUPNVLAB(X,0),U,4)=""
  1.  ...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
  1.  ...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D
  1.  ....S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
  1.  ...Q:'BDMOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC^BDMD11C(J,BDMOT)
  1.  ...S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
  1.  ...Q
  1.  ;now get latest with a result and use it, if none with a result take latest one
  1.  ;if none, quit on value
  1.  S (D,C)=0,G=""
  1.  F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  D
  1.  .S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D
  1.  ..I $P(BDM(D,C),U,3)]""!($P(BDM(D,C),U,4)]"") S G=BDM(D,C)
  1.  I F="I" Q $S($P(G,U,1)="LAB":$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3)),1:$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3)))
  1.  I G]"" S C="" D  Q C   ;C=1 skin test||result value
  1.  .S C=$S($P(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
  1.  .;GET RESULT VALUE
  1.  .I $P(G,U,1)="LAB" S R=$P(G,U,3) D  Q
  1.  ..I $E($$UP^XLFSTR(R))="P" S C=C_"||1  Positive "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
  1.  ..I $E($$UP^XLFSTR(R))="N" S C=C_"||2  Negative "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
  1.  ..S C=C_"||4  Unknown" Q
  1.  .I $P(G,U,1)="ST" D  Q
  1.  ..S R=$P(G,U,3),R1=$P(G,U,4)
  1.  ..I R]"",R>9 S C=C_"||1  Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
  1.  ..I R]"",R<10 S C=C_"||2  Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
  1.  ..I R1]"",R1="P" S C=C_"||1  Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
  1.  ..I R1]"",R1="N" S C=C_"||2  Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
  1.  ;now check refusal for PPD or lab test
  1.  S X=EDATE,%DT="P" D ^%DT S BDATE=$$FMADD^XLFDT(Y,-365),BDATE=$$FMTE^XLFDT(BDATE),G=0 S X=$$REFUSAL^BDMD117(P,9999999.28,$O(^AUTTSK("B","PPD",0)),BDATE,EDATE) I X S G=X
  1.  I G Q "3  Refused "_$P(G,U,3)_" "_$P(G,U,4)_" "_$P(G,U,5)_"||3  Refused"
  1.  ;now check lab test refusal - lori
  1.  Q "4  Unknown||"
  1.  ;
  1. LASTNP(P,EDATE) ;EP - last negative ppd
  1.  I $E($P($$PPD(P,EDATE),"||",2))'="2" Q ""
  1.  Q $$PPD(P,EDATE,"I")
  1.  ;
  1. FGLUCOSE(P,BDATE,EDATE,F) ;EP
  1.  G FGLUCOSE^BDMD11D
  1. G75(P,BDATE,EDATE,F) ;EP
  1.  G G75^BDMD11D
  1.  ;
  1. STV(X,T,D) ;EP - strip hgba1c before epi export
  1.  I X="" Q X  ;no value in X so don't bother
  1.  I X="?" Q ""
  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.  I X="" Q ""
  1.  I $G(D),X["." S X=$J(X,T,D)
  1.  S X=$$STRIP^XLFSTR(X," ")
  1.  Q $E(X,1,T)
  1. STE(X,T,D) ;EP - strip hgba1c before epi export
  1.  I X="" Q X  ;no value in X so don't bother
  1.  I X="?" Q ""
  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".",X'?1"+",X'?1"-",X'?1">",X'?1"<" S X=$$STRIP^XLFSTR(X,A) S B=B-1
  1.  I X="" Q ""
  1.  I $G(D),X["." S X=$J(X,T,D)
  1.  S X=$$STRIP^XLFSTR(X," ")
  1.  Q $E(X,1,T)