BDMD418.m

BDMD418 ; IHS/CMI/LAB - 2012 DIABETES AUDIT ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007

 ;

 ;cmi/anch/maw 9/12/2007 code set versioning in WT

 ;

HT(P,BDATE,EDATE) ;EP

 I 'P Q ""

 NEW %,BDMARRY,H,E,D,W

 S E=$O(^AUTTMSR("B","HT",0))

 S H=""

 S D=0 F  S D=$O(^AUPNVMSR("AA",P,E,D)) Q:D'=+D!(H]"")  D

 .S W=0 F  S W=$O(^AUPNVMSR("AA",P,E,D,W)) Q:W'=+W!(H]"")  D

 ..Q:'$D(^AUPNVMSR(W,0))

 ..Q:$P($G(^AUPNVMSR(W,2)),U,1)  ;entered in error

 ..S H=$P(^AUPNVMSR(W,0),U,4)

 ..S BDMARRAY(1)=$$VD^APCLV($P(^AUPNVMSR(W,0),U,3))

 I H="" Q H

 I H["?" Q ""

 S H=$J(H,5,2)

 Q H

WT(P,BDATE,EDATE) ;EP

 I 'P Q ""

 NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF

 K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")

 S BDMN=0 F  S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"")  D

 .S BDMVF=+$P(BDM(BDMN),U,4)

 .Q:$P($G(^AUPNVMSR(BDMVF,2)),U,1)  ;entered in error

 .S BDMZ=$P(BDM(BDMN),U,5)

 .I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2) Q

 . S BDMD=0 F  S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"")  D

 .. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BDMD,0),U)),U,2) D  ;cmi/anch/maw 9/12/2007 csv

 ...I $E(ICD,1,3)="V22" Q

 ...I $E(ICD,1,3)="V23" Q

 ...I $E(ICD,1,3)="V27" Q

 ...I $E(ICD,1,3)="V28" Q

 ...I ICD>629.9999&(ICD<676.95) Q

 ...S BDMW=$P(BDM(BDMN),U,2)

 ..Q

 Q BDMW

BMI(P,BDATE,EDATE) ;EP

 I 'P Q ""

 NEW %,W,H,B,D,%DT,X

 S %=""

 D  Q %

 .S W=$$WT(P,BDATE,EDATE) Q:W=""  S W=W+.5,W=$P(W,".")

 .S HDATE=$P(^DPT(P,0),U,3)

 .S H=$$HT(P,HDATE,EDATE) I H="" Q

 .S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)

 .Q

 Q

CREAT(P,BDATE,EDATE,F) ;EP

 G CREAT^BDMD41C

CHOL(P,BDATE,EDATE,F) ;EP

 G CHOL^BDMD41C

HDL(P,BDATE,EDATE,F) ;EP

 G HDL^BDMD41C

LDL(P,BDATE,EDATE,F) ;EP

 G LDL^BDMD41C

TRIG(P,BDATE,EDATE,F) ;EP

 G TRIG^BDMD41C

URIN(P,BDATE,EDATE) ;EP

 G URIN^BDMD41H

PROTEIN(P,BDATE,EDATE) ;EP

 G PROTEIN^BDMD41C

MICRO(P,BDATE,EDATE) ;EP

 G MICRO^BDMD41C

HGBA1C(P,BDATE,EDATE) ;EP

 G HGBA1C^BDMD41D

SEMI(P,BDATE,EDATE) ;EP

 G SEMI^BDMD41C

PPDS(P) ;

 NEW BDMS,E,X

 K BDMS

 S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")

 I $D(BDMS) Q 1_U_$$FMTE^XLFDT($P(BDMS(1),U))_"  HF: "_$P(BDMS(1),U,3)

PPDSPL ;CHECK PL

 N T S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))

 I 'T Q ""

 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

 I I Q 1_U_$$VAL^XBDIQ1(9000011,I,.03)_"  Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)

 ;check povs

 K BDMS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"BDMS(")

 I $D(BDMS(1)) Q 1_U_$$FMTE^XLFDT($P(BDMS(1),U))_"  POV: "_$P(BDMS(1),U,3)

 Q ""

PPD(P,EDATE,F) ;EP

 ;f 1=tb test done

 ;f 2=tb result

 S F=$G(F)

 ;RETURN 1^1  Skin Test||1  Positive

 NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR

 S LD="",LR=""

 S X=EDATE,%DT="P" D ^%DT S ED=Y

 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

 K BDM

 ;get, in reverse order all skin tests and lab tests for TB testing  (BDM(inverse date,#)=ST or LAB^ien^result^reading

 S X=$O(^AUTTSK("B","PPD",0))

 S D=9999999-ED-1,C=0 F  S D=$O(^AUPNVSK("AA",P,X,D)) Q:D=""  D

 .S G=0 F  S G=$O(^AUPNVSK("AA",P,X,D,G)) Q:G'=+G  D

 ..Q:'$D(^AUPNVSK(G,0))

 ..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))

 ;go through all ppds and find last reading or result

 ;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

 ;S LD=R2

 ;I R]"",R>9 S LR=1_U_1_U_"1  SKIN TEST"_U_"1  POSITIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1

 ;I R]"",R<10 S LR=1_U_2_U_"1  SKIN TEST"_U_"2  NEGATIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1

 ;I R1]"",R1="P" S LR=1_U_1_U_"1  SKIN TEST"_U_"1  POSITIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1

 ;I R1]"",R1="N" S LR=1_U_2_U_"1  SKIN TEST"_U_"2  NEGATIVE  "_$$FMTE^XLFDT(R2)_" Reading: "_R_"  Result: "_R1

 ;Now get last lab test, must have a result

 S BDMC=0

 S BDMLT=$O(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))

 S BDMOT=$O(^ATXAX("B","DM AUDIT TB TEST LOINC",0))

 S G="",E=9999999-ED S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G)  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))

 ...Q:$P(^AUPNVLAB(X,0),U,4)=""

 ...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"

 ...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D

 ....S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1

 ...Q:'BDMOT

 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""

 ...Q:'$$LOINC^BDMD41C(J,BDMOT)

 ...S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1

 ...Q

 ;now get latest with a result and use it, if none with a result take latest one

 ;if none, quit on value

 S (D,C)=0,G=""

 F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  D

 .S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D

 ..I $P(BDM(D,C),U,3)]""!($P(BDM(D,C),U,4)]"") S G=BDM(D,C)

 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)))

 I G]"" S C="" D  Q C   ;C=1 skin test||result value

 .S C=$S($P(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")

 .;GET RESULT VALUE

 .I $P(G,U,1)="LAB" S R=$P(G,U,3) D  Q

 ..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

 ..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

 ..S C=C_"||4  Unknown" Q

 .I $P(G,U,1)="ST" D  Q

 ..S R=$P(G,U,3),R1=$P(G,U,4)

 ..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

 ..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

 ..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

 ..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

 ;now check refusal for PPD or lab test

 S X=EDATE,%DT="P" D ^%DT S BDATE=$$FMADD^XLFDT(Y,-365),BDATE=$$FMTE^XLFDT(BDATE),G=0 S X=$$REFUSAL^BDMD417(P,9999999.28,$O(^AUTTSK("B","PPD",0)),BDATE,EDATE) I X S G=X

 I G Q "3  Refused "_$P(G,U,3)_" "_$P(G,U,4)_" "_$P(G,U,5)_"||3  Refused"

 ;now check lab test refusal - lori

 Q "4  Unknown||"

 ;

LASTNP(P,EDATE) ;EP - last negative ppd

 I $E($P($$PPD(P,EDATE),"||",2))'="2" Q ""

 Q $$PPD(P,EDATE,"I")

 ;

FGLUCOSE(P,BDATE,EDATE,F) ;EP

 G FGLUCOSE^BDMD41D

G75(P,BDATE,EDATE,F) ;EP

 G G75^BDMD41D

 ;

STV(X,T,D) ;EP - strip hgba1c before epi export

 I X="" Q X  ;no value in X so don't bother

 I X="?" Q ""

 NEW A,B,L

 S L=$L(X)

 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

 I X="" Q ""

 I $G(D),X["." S X=$J(X,T,D)

 S X=$$STRIP^XLFSTR(X," ")

 Q $E(X,1,T)

STE(X,T,D) ;EP - strip hgba1c before epi export

 I X="" Q X  ;no value in X so don't bother

 I X="?" Q ""

 NEW A,B,L

 S L=$L(X)

 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

 I X="" Q ""

 I $G(D),X["." S X=$J(X,T,D)

 S X=$$STRIP^XLFSTR(X," ")

 Q $E(X,1,T)

ASPIRIN ;EP

 NEW X,BDM,E,A,N,G,T,T1,O,B,%

 S (A,B,G,N)=""

 S X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")

 I $D(BDM(1)) S A=1

 K BDM S X=P_"^MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")

 I $D(BDM(1)) S N=1

 I A!(N) Q "1  Aspirin/Antiplatelet Rx"

 ;CHECK NON-VA MEDS for drug or orderable item that is not-discontinued

 S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))

 S T1=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))

 S X=0,%="" F  S X=$O(^PS(55,P,"NVA",X)) Q:X'=+X!(%]"")  D

 .I $P($G(^PS(55,P,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,P,"NVA",X,999999911),U,1),0)) Q  ;got this with V MED

 .S L=$P($P($G(^PS(55,P,"NVA",X,0)),U,10),".")

 .Q:$P(^PS(55,P,"NVA",X,0),U,6)=1  ;discontinued

 .I $P(^PS(55,P,"NVA",X,0),U,7)]"",$P(^PS(55,P,"NVA",X,0),U,7)<EDATE Q  ;discontinued date

 .Q:$P(^PS(55,P,"NVA",X,0),U,9)>EDATE  ;

 .S D=$P(^PS(55,P,"NVA",X,0),U,2)

 .I D S G=0 D

 ..I $D(^ATXAX(T,21,"B",D)) S G=1

 ..I $D(^ATXAX(T1,21,"B",D)) S G=1

 .I D,G S %="1  Yes - NVA MED - "_$P(^PSDRUG(D,0),U,1) Q

 .S O=$P(^PS(55,P,"NVA",X,0),U,1)

 .Q:O=""

 .S O=$P($G(^PS(50.7,O,0)),U,1)

 .Q:O=""

 .I $E(O,1,7)="ASPIRIN",$E(O,8)'="/" S %="1  Yes - NVA MED - "_O Q

 I %]"" Q %

 ;refusal oR NMI

 S G=0

 NEW T S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))

 I 'T G ANTI

 S X=0 F  S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G)  S G=$$REFUSAL^BDMD417(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)

 I G,$P(G,U,2)'="N" Q "3  Refused"

 I G Q "2  None - Not Medically Indicated"

ANTI ;

 NEW T S T=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))

 I 'T G AR

 S (X,G)=0 F  S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G)  S G=$$REFUSAL^BDMD417(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)

 I G Q "3  Refused or adverse reaction"

AR ;NOW CHECK FOR ADVERSE REACTION/ALLERGY

 S X=EDATE,%DT="P" D ^%DT S E=Y

 D ASAALLEG(P,E,.BDMSAAL) ;return text of aspirin allergy if found

 I $D(BDMSAAL(1)) Q "3  Refused or adverse reaction "_BDMSAAL(1)_"  (Allergy Tracking)"

 Q "2  None"

 ;

 ;

 ;;

ASAALLEG(P,BDMD,BDMY) ;does patient have an aspirin allergy

 ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date

 NEW ED,BD,BDMG,BDMC,X,Y,Z,N

 ;BDMD is discharge date

 S BDMC=0 K BDMY

 ;S ED=$$FMADD^XLFDT(BDMD,-365)

ASAPOV ;

 K BDMG S Y="BDMG(",X=P_"^ALL DX [BDM ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD) S E=$$START1^APCLDF(X,Y)

 S X=0 F  S X=$O(BDMG(X)) Q:X'=+X  S Y=+$P(BDMG(X),U,4) D

 .S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)

 .I N["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="POV:  "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_"]  "_N

 .;S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($G(^ICD9(Z,0)),U)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_"  ["_$P(BDMG(X),U,2)_" + E935.3]  "_N  ;cmi/anch/maw 9/12/2007 orig line

 .S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_"  ["_$P(BDMG(X),U,2)_" + E935.3]  "_N  ;cmi/anch/maw 9/12/2007 csv

 .Q

 K BDMG S Y="BDMG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD) S E=$$START1^APCLDF(X,Y)

 S X=0 F  S X=$O(BDMG(X)) Q:X'=+X  S Y=+$P(BDMG(X),U,4) D

 .S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)

 .I N["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="POV:  "_$$FMTE^XLFDT($P(BDMG(X),U))_"  ["_$P(BDMG(X),U,2)_"]  "_N

 .Q

 ;now check problem list for these codes

 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($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 .S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)

 .Q:$P(^AUPNPROB(X,0),U,8)>BDMD  ;added after discharge date

 .I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="PROBLEM LIST:  "_$$FMTE^XLFDT($P(^AUPNPROB(X,0),U,8))_"  ["_Y_"]  "_N

 .Q

 ;now check allergy tracking

 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),".")>BDMD  ;entered after AUDIT date

 .S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)

 .I N["ASPIRIN" S BDMC=BDMC+1,BDMY(BDMC)="ALLERGY TRACKING:  "_$$FMTE^XLFDT($P(^GMR(120.8,X,0),U,4))_"  "_N Q

 .S C=$O(^PS(50.605,"B","CN103",0))

 .I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q

 .S C=$O(^PS(50.605,"B","BL100",0))

 .I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q

 .S C=$O(^PS(50.605,"B","BL110",0))

 .I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q

 .S C=$O(^PS(50.605,"B","BL117",0))

 .I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q

 .Q

 Q

BDMD418   ; IHS/CMI/LAB - 2012 DIABETES AUDIT ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007

 +2       ;

 +3       ;cmi/anch/maw 9/12/2007 code set versioning in WT

 +4       ;

HT(P,BDATE,EDATE) ;EP

 +1        IF 'P

               QUIT ""

 +2        NEW %,BDMARRY,H,E,D,W

 +3        SET E=$ORDER(^AUTTMSR("B","HT",0))

 +4        SET H=""

 +5        SET D=0

           FOR 

               SET D=$ORDER(^AUPNVMSR("AA",P,E,D))

               IF D'=+D!(H]"")

                   QUIT 

               Begin DoDot:1

 +6                SET W=0

                   FOR 

                       SET W=$ORDER(^AUPNVMSR("AA",P,E,D,W))

                       IF W'=+W!(H]"")

                           QUIT 

                       Begin DoDot:2

 +7                        IF '$DATA(^AUPNVMSR(W,0))

                               QUIT 

 +8       ;entered in error

                           IF $PIECE($GET(^AUPNVMSR(W,2)),U,1)

                               QUIT 

 +9                        SET H=$PIECE(^AUPNVMSR(W,0),U,4)

 +10                       SET BDMARRAY(1)=$$VD^APCLV($PIECE(^AUPNVMSR(W,0),U,3))

                       End DoDot:2

               End DoDot:1

 +11       IF H=""

               QUIT H

 +12       IF H["?"

               QUIT ""

 +13       SET H=$JUSTIFY(H,5,2)

 +14       QUIT H

WT(P,BDATE,EDATE) ;EP

 +1        IF 'P

               QUIT ""

 +2        NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF

 +3        KILL BDM

           SET BDMW=""

           SET BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(BDMX,"BDM(")

 +4        SET BDMN=0

           FOR 

               SET BDMN=$ORDER(BDM(BDMN))

               IF BDMN'=+BDMN!(BDMW]"")

                   QUIT 

               Begin DoDot:1

 +5                SET BDMVF=+$PIECE(BDM(BDMN),U,4)

 +6       ;entered in error

                   IF $PIECE($GET(^AUPNVMSR(BDMVF,2)),U,1)

                       QUIT 

 +7                SET BDMZ=$PIECE(BDM(BDMN),U,5)

 +8                IF '$DATA(^AUPNVPOV("AD",BDMZ))

                       SET BDMW=$PIECE(BDM(BDMN),U,2)

                       QUIT 

 +9                SET BDMD=0

                   FOR 

                       SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))

                       IF 'BDMD!(BDMW]"")

                           QUIT 

                       Begin DoDot:2

 +10      ;cmi/anch/maw 9/12/2007 csv

                           SET ICD=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVPOV(BDMD,0),U)),U,2)

                           Begin DoDot:3

 +11                           IF $EXTRACT(ICD,1,3)="V22"

                                   QUIT 

 +12                           IF $EXTRACT(ICD,1,3)="V23"

                                   QUIT 

 +13                           IF $EXTRACT(ICD,1,3)="V27"

                                   QUIT 

 +14                           IF $EXTRACT(ICD,1,3)="V28"

                                   QUIT 

 +15                           IF ICD>629.9999&(ICD<676.95)

                                   QUIT 

 +16                           SET BDMW=$PIECE(BDM(BDMN),U,2)

                           End DoDot:3

 +17                       QUIT 

                       End DoDot:2

               End DoDot:1

 +18       QUIT BDMW

BMI(P,BDATE,EDATE) ;EP

 +1        IF 'P

               QUIT ""

 +2        NEW %,W,H,B,D,%DT,X

 +3        SET %=""

 +4        Begin DoDot:1

 +5            SET W=$$WT(P,BDATE,EDATE)

               IF W=""

                   QUIT 

               SET W=W+.5

               SET W=$PIECE(W,".")

 +6            SET HDATE=$PIECE(^DPT(P,0),U,3)

 +7            SET H=$$HT(P,HDATE,EDATE)

               IF H=""

                   QUIT 

 +8            SET W=W*.45359

               SET H=(H*.0254)

               SET H=(H*H)

               SET %=(W/H)

               SET %=$JUSTIFY(%,4,1)

 +9            QUIT 

           End DoDot:1

           QUIT %

 +10       QUIT 

CREAT(P,BDATE,EDATE,F) ;EP

 +1        GOTO CREAT^BDMD41C

CHOL(P,BDATE,EDATE,F) ;EP

 +1        GOTO CHOL^BDMD41C

HDL(P,BDATE,EDATE,F) ;EP

 +1        GOTO HDL^BDMD41C

LDL(P,BDATE,EDATE,F) ;EP

 +1        GOTO LDL^BDMD41C

TRIG(P,BDATE,EDATE,F) ;EP

 +1        GOTO TRIG^BDMD41C

URIN(P,BDATE,EDATE) ;EP

 +1        GOTO URIN^BDMD41H

PROTEIN(P,BDATE,EDATE) ;EP

 +1        GOTO PROTEIN^BDMD41C

MICRO(P,BDATE,EDATE) ;EP

 +1        GOTO MICRO^BDMD41C

HGBA1C(P,BDATE,EDATE) ;EP

 +1        GOTO HGBA1C^BDMD41D

SEMI(P,BDATE,EDATE) ;EP

 +1        GOTO SEMI^BDMD41C

PPDS(P)   ;

 +1        NEW BDMS,E,X

 +2        KILL BDMS

 +3        SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"

           SET E=$$START1^APCLDF(X,"BDMS(")

 +4        IF $DATA(BDMS)

               QUIT 1_U_$$FMTE^XLFDT($PIECE(BDMS(1),U))_"  HF: "_$PIECE(BDMS(1),U,3)

PPDSPL    ;CHECK PL

 +1        NEW T

           SET T=$ORDER(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))

 +2        IF 'T

               QUIT ""

 +3        NEW X,Y,I

           SET (X,Y,I)=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X!(I)

                   QUIT 

               IF $DATA(^AUPNPROB(X,0))

                   SET Y=$PIECE(^AUPNPROB(X,0),U)

                   IF $$ICD^ATXCHK(Y,T,9)

                       SET I=X

 +4        IF I

               QUIT 1_U_$$VAL^XBDIQ1(9000011,I,.03)_"  Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)

 +5       ;check povs

 +6        KILL BDMS

           SET X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS"

           SET E=$$START1^APCLDF(X,"BDMS(")

 +7        IF $DATA(BDMS(1))

               QUIT 1_U_$$FMTE^XLFDT($PIECE(BDMS(1),U))_"  POV: "_$PIECE(BDMS(1),U,3)

 +8        QUIT ""

PPD(P,EDATE,F) ;EP

 +1       ;f 1=tb test done

 +2       ;f 2=tb result

 +3        SET F=$GET(F)

 +4       ;RETURN 1^1  Skin Test||1  Positive

 +5        NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR

 +6        SET LD=""

           SET LR=""

 +7        SET X=EDATE

           SET %DT="P"

           DO ^%DT

           SET ED=Y

 +8       ;IF HAD HF or dx or pl of TB use it as positive

           SET G=$$PPDS(P)

           IF G

               QUIT "1  TB Positive  "_$PIECE(G,U,2)_"||1  Positive TB "_$PIECE(G,U,2)

 +9        KILL BDM

 +10      ;get, in reverse order all skin tests and lab tests for TB testing  (BDM(inverse date,#)=ST or LAB^ien^result^reading

 +11       SET X=$ORDER(^AUTTSK("B","PPD",0))

 +12       SET D=9999999-ED-1

           SET C=0

           FOR 

               SET D=$ORDER(^AUPNVSK("AA",P,X,D))

               IF D=""

                   QUIT 

               Begin DoDot:1

 +13               SET G=0

                   FOR 

                       SET G=$ORDER(^AUPNVSK("AA",P,X,D,G))

                       IF G'=+G

                           QUIT 

                       Begin DoDot:2

 +14                       IF '$DATA(^AUPNVSK(G,0))

                               QUIT 

 +15                       SET C=C+1