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

BDMP413.m

Go to the documentation of this file.
  1. BDMP413 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
  1. ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
  1. ;LORI - ADD V04,81
  1. ;
  1. ;cmi/anch/maw 9/12/2007 code set versioning in PLDMDXS,IFG,IGT,MS,ABNG
  1. ;
  1. BPS(P,BDATE,EDATE,F) ;EP ;
  1. I $G(F)="" S F="E"
  1. NEW X,BDM,E,BDML,BDMLL,BDMV
  1. S BDMLL=0,BDMV=""
  1. K BDM
  1. S X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
  1. S BDML=0 F S BDML=$O(BDM(BDML)) Q:BDML'=+BDML!(BDMLL=3) S BDMBP=$P($G(BDM(BDML)),U,2) D
  1. .Q:$$CLINIC^APCLV($P(BDM(BDML),U,5),"C")=30
  1. .S BDMLL=BDMLL+1
  1. .I F="E" S $P(BDMV,";",BDMLL)=BDMBP_" "_$$FMTE^XLFDT($P(BDM(BDML),U))
  1. .I F="I" S $P(BDMV,";",BDMLL)=$P(BDMBP," ")
  1. Q BDMV
  1. HTNDX(P,EDATE) ;EP - is HTN on problem list
  1. I '$G(P) Q ""
  1. I '$D(^DPT(P)) Q ""
  1. NEW %,BDM,E
  1. K BDM
  1. S %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES" S E=$$START1^APCLDF(%,"BDM(")
  1. I $D(BDM(1)) Q "Yes"
  1. K BDM
  1. S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(") I $D(BDM(3)) Q "Yes"
  1. Q "No"
  1. LASTHT(P,EDATE,F) ;PEP - return last ht and date
  1. I 'P Q ""
  1. I $G(F)="" S F="E"
  1. I '$D(^AUPNVSIT("AC",P)) Q ""
  1. NEW %,BDMARRY,H,E,W
  1. S %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
  1. I H="" Q H
  1. S H=$J(H,4,1)
  1. I F="I" Q H
  1. Q H_" inches "_$$FMTE^XLFDT($P(BDMARRY(1),U))
  1. LASTWC(P,EDATE,F) ;PEP - return last ht and date
  1. I 'P Q ""
  1. I $G(F)="" S F="E"
  1. I '$D(^AUPNVSIT("AC",P)) Q ""
  1. S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. NEW %,BDMARRY,H,E,W
  1. S %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
  1. Q H_" "_$$FMTE^XLFDT($P($G(BDMARRY(1)),U))
  1. LASTWT(P,EDATE,F) ;PEP - return last wt
  1. I 'P Q ""
  1. I $G(F)="" S F="E"
  1. S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. NEW %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,W,H,BDMC
  1. NEW BDMV221 S BDMV221=$O(^ICD9("BA","V22.1 ",""))
  1. K BDM S BDMW="" S BDMX=P_"^LAST 30 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
  1. S BDMC=0,BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMC>2) D
  1. . S BDMZ=$P(BDM(BDMN),U,5)
  1. . I '$D(^AUPNVPOV("AD",BDMZ)) S BDMC=BDMC+1,BDMW=BDMW_"|"_$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U)) Q
  1. . S BDMD=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"") D
  1. .. I $P(^AUPNVPOV(BDMD,0),U)'=BDMV221 S BDMC=BDMC+1,BDMW=BDMW_"|"_$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U))
  1. ..Q
  1. Q $S(F="E":BDMW,1:+BDMW)
  1. CMSFDX(P,R,T) ;EP - return date/dx of dm in register
  1. I '$G(P) Q ""
  1. I '$G(R) Q ""
  1. I $G(T)="" Q ""
  1. NEW D1,Y,X,D,G S (G,X)=0,(D,Y)="" F S X=$O(^ACM(44,"C",P,X)) Q:X'=+X!(G) I $P(^ACM(44,X,0),U,4)=R D
  1. .S D=$P($G(^ACM(44,X,"SV")),U,2),D1=D,D=$$FMTE^XLFDT(D)
  1. .S Y=$$VAL^XBDIQ1(9002244,X,.01)
  1. Q $S(T="D":$G(D),T="DX":$G(Y),T="ID":$G(D1),1:"")
  1. ;
  1. PLDMDOO(P,F) ;EP
  1. I '$G(P) Q ""
  1. I $G(F)="" S F="E"
  1. NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
  1. I 'T Q ""
  1. NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P(^AUPNPROB(X,0),U)
  1. .I $$ICD^ATXCHK(I,T,9) D
  1. ..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
  1. ..Q
  1. .Q
  1. S D=$O(D(0)) Q $S(F="E":$$FMTE^XLFDT(D),1:$O(D(0)))
  1. PLDMDXS(P) ;EP - get all DM dxs from problem list
  1. I '$G(P) Q ""
  1. NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
  1. I 'T Q "<diabetes taxonomy missing>"
  1. NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P(^AUPNPROB(X,0),U)
  1. .;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P(^ICD9(I,0),U) ;cmi/anch/maw 9/12/2007 orig line
  1. .I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
  1. .Q
  1. Q D
  1. ;
  1. FRSTDMDX(P,F) ;EP return date of first dm dx
  1. I '$G(P) Q ""
  1. I $G(F)="" S F="E"
  1. NEW X,E,BDM,Y
  1. S Y="BDM("
  1. S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(BDM(1)),U)
  1. Q $S(F="E":$$FMTE^XLFDT(Y),1:Y)
  1. LASTDMDX(P,D) ;EP - last pcc dm dx
  1. I '$G(P) Q ""
  1. NEW X,E,BDM,Y
  1. S Y="BDM("
  1. S X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) Q "Type 2"
  1. K BDM S X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) Q "Type 1"
  1. Q ""
  1. ;
  1. IFG(P,BDMRET) ;EP
  1. K BDMRET
  1. NEW BDMC,BDM
  1. S BDMC=0
  1. K BDM
  1. ;look at problem list then povs
  1. ;return where found^dx code^provider narr^date (either visit date or doo from pl)
  1. ;look for first and last pov
  1. S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P(^AUPNPROB(X,0),U)
  1. .;S I=$P($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
  1. .S I=$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
  1. .Q:I'="790.21"
  1. .S BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
  1. .Q
  1. ;now look at first and last pov
  1. S Y="BDM("
  1. S X=P_"^LAST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. K BDM S X=P_"^FIRST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. Q
  1. IGT(P,BDMRET) ;EP
  1. K BDMRET
  1. NEW BDMC,BDM
  1. S BDMC=0
  1. K BDM
  1. ;look at problem list then povs
  1. ;return where found^dx code^provider narr^date (either visit date or doo from pl)
  1. ;look for first and last pov
  1. S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P(^AUPNPROB(X,0),U)
  1. .;S I=$P($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
  1. .S I=$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
  1. .Q:I'="790.22"
  1. .S BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
  1. .Q
  1. ;now look at first and last pov
  1. S Y="BDM("
  1. S X=P_"^LAST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. K BDM S X=P_"^FIRST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. Q
  1. MS(P,BDMRET) ;EP
  1. K BDMRET
  1. NEW BDMC,BDM
  1. S BDMC=0
  1. K BDM
  1. ;look at problem list then povs
  1. ;return where found^dx code^provider narr^date (either visit date or doo from pl)
  1. ;look for first and last pov
  1. S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P(^AUPNPROB(X,0),U)
  1. .;S I=$P($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
  1. .S I=$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
  1. .Q:I'="277.7"
  1. .S BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
  1. .Q
  1. ;now look at first and last pov
  1. S Y="BDM("
  1. S X=P_"^LAST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. K BDM S X=P_"^FIRST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. Q
  1. ABNG(P,BDMRET) ;EP
  1. K BDMRET
  1. NEW BDMC
  1. S BDMC=0
  1. ;look at problem list then povs
  1. ;return where found^dx code^provider narr^date (either visit date or doo from pl)
  1. ;look for first and last pov
  1. S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P(^AUPNPROB(X,0),U)
  1. .;S I=$P($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
  1. .S I=$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
  1. .Q:I'="790.29"
  1. .S BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
  1. .Q
  1. ;now look at first and last pov
  1. S Y="BDM("
  1. S X=P_"^LAST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. K BDM S X=P_"^FIRST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
  1. I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
  1. Q