BDMS9B1 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT 12 Jan 2011 12:27 PM ; [ 12 Jan 2011 12:27 PM ]
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
;
Q:'$G(APCHSPAT)
S BDMSPAT=APCHSPAT
S BDMSHDR=APCHSHDR
D EN^XBNEW("EP^BDMS9B1","BDMSPAT;BDMSHDR;APCHSQIT")
K ^TMP("APCHS",$J)
K BDMSPAT
Q
EP ;EP - called from xbnew
D EP2(BDMSPAT)
W ;write out array
W:$D(IOF) @IOF
K BDMQUIT
W !
S BDMX=0 F S BDMX=$O(^TMP("APCHS",$J,"DCS",BDMX)) Q:BDMX'=+BDMX!($D(BDMQUIT)) D
.I $Y>(IOSL-3) D HEADER Q:$D(BDMQUIT)
.W ^TMP("APCHS",$J,"DCS",BDMX),!
.Q
I $D(BDMQUIT) S APCHSQIT=1
K ^TMP("APCHS",$J,"DCS")
D EOJ
Q
;
EOJ ;
K BDMX,BDMQUIT,BDMY,BDMSDFN,BDMSBEG,BDMSTOB,BDMSUPI,BDMSED,BDMTOBN,BDMTOB,BDMSTEX
K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
Q
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BDMQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
W !,BDMSHDR,!
W !,"Diabetes Patient Care Summary - continued"
W !,"Patient: ",$P(^DPT(BDMSPAT,0),U)," HRN: ",$$HRN^AUPNPAT(BDMSPAT,DUZ(2)),!
Q
EP2(BDMSDFN) ;PEP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("APCHS",$J,"DCS"
K ^TMP("APCHS",$J,"DCS")
S ^TMP("APCHS",$J,"DCS",0)=0
D EN^XBNEW("EP21^BDMS9B1","BDMSDFN")
Q
EP21 ;
S BDMSPAT=BDMSDFN
D SETARRAY
;K ^XTMP("BDMTAX",BDMJOB,BDMBTH)
Q
DATE(D) ;EP
I D="" Q ""
I 'D Q $$DATE1(D)
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
DATE1(D) ;
NEW %,%DT,X,Y
S %="",%DT="P",X=D D ^%DT
I Y=-1 Q ""
Q $$DATE(Y)
SETARRAY ;set up array containing dm care summary
;CHECK TO SEE IF START1^APCLDF EXISTS
S BDMJOB=$J,BDMBTH=$H
;D UNFOLDTX^BDMUTL(2016)
I '$D(BDMSCVD) S BDMSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S X="APCLDF" X ^%ZOSF("TEST") I '$T Q
S X="DIABETES PATIENT CARE SUMMARY",$E(X,40)="Report Date: "_$$DATE(DT) D S(X)
S X="Patient: "_$E($P(^DPT(BDMSDFN,0),U),1,28),$E(X,40)="HRN: "_$$HRN^AUPNPAT(BDMSDFN,DUZ(2)) D S(X,1)
I $$DOD^AUPNPAT(BDMSDFN)]"" S X="DATE OF DEATH: "_$$DATE($$DOD^AUPNPAT(BDMSDFN)) D S(X,1),S(" ")
S X="Age: "_$$AGE^BDMAPIU(BDMSDFN,1,DT)_" (DOB "_$$DATE($$DOB^AUPNPAT(BDMSDFN))_")",$E(X,40)="Sex: "_$$VAL^XBDIQ1(2,BDMSDFN,.02) D S(X)
S X="CLASS/BEN: "_$$VAL^XBDIQ1(9000001,BDMSDFN,1111),$E(X,40)="Designated PCP: "_$E($$DPCP(BDMSDFN),1,25) D S(X)
S X="Date of DM Diagnosis: "_$$DOO(BDMSDFN) D S(X,1) ;S Y=$$DMPN(BDMSDFN),$E(X,58)="DM Problem #: "_$S(Y]"":Y,1:"*NONE RECORDED*") D S(X,1)
S X=$$TYPE^BDMDG16(BDMSDFN,,DT) D S("Diabetes type: (1 or 2): "_X)
S X="" I '$$NOTREG(BDMSDFN) S X="**NOT ON DIABETES REGISTER**"
D GETHWB(BDMSDFN)
S X="BMI: "_BDMX("BMI"),$E(X,12)="Last Height: "_$$STRIP^XLFSTR($J(BDMX("HT"),5,2)," ")_$S(BDMX("HT")]"":" inches",1:""),$E(X,40)=BDMX("HTD") D S(X,1)
S X="",$E(X,12)="Last Weight: "_$S(BDMX("WT")]"":BDMX("WT")\1,1:"")_$S(BDMX("WT")]"":" lbs",1:""),$E(X,40)=BDMX("WTD") D S(X)
S BDMTOBC="",BDMTOBS=$$TOBACCO^BDMDG1T(BDMSDFN,$$DOB^AUPNPAT(BDMSDFN),DT)
D S("Tobacco Use:",1)
S X=" Last Screened: "_$$DATE($P(BDMTOBS,U,3)) D S(X)
S X=" Current Status: "_$P($P($G(BDMTOBS),U,2)," ",2,99) D S(X)
;I BDMTOBS="" S X=" Last Scree: NOT DOCUMENTED" D S(X,1)
;I $G(BDMTOBC)]"" S X=" "_$P(BDMTOBC,U,1) D S(X)
;COUNSELED?
S X="",$E(X,15)="Counseled in the past year? " D
.I $E(BDMTOBS),$E(BDMTOBS)'=1 S X=X_"N/A" Q
.S Y=$$CESS^BDMDG11(BDMSDFN,$$FMADD^XLFDT(DT,-365),DT)
.I $E(Y)=1 S X=X_$P(Y," ",2,999) Q
.I $E(Y)=2 S X=X_"No" Q
D S(X)
S X=$$LASTHF^BDMSMU(BDMSDFN,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)","X",$$DOB^AUPNPAT(BDMSDFN),DT) ; (BDMSDFN,$$DOB^AUPNPAT(BDMSDFN),DT)
D S("Electronic Nicotine Delivery System (ENDS) use:",1)
S Y=" Last Screened: "_$S($P(X,U,2)="":" Never",1:$$DATE($P(X,U,2))) D S(Y)
S Y=" Current Status: "_$P(X,U,1) D S(Y) ;I $P(X,U,1)=1 D S(" "_$P(X,U,3))
S X="HTN Diagnosed: "_$$HTN(BDMSDFN) D S(X,1)
S X="CVD Diagnosed: "_$P($$CVD^BDMDG12(BDMSDFN,DT)," ",2,999) D S(X)
S B=$$BP(BDMSDFN)
S X="Last 3 BP: "_$P($G(BDMX(1)),U,2),$E(X,26)=$$DATE($P($G(BDMX(1)),U)) D S(X)
S X="(non ER)" I $D(BDMX(2)) S $E(X,17)=$P(BDMX(2),U,2),$E(X,26)=$$DATE($P(BDMX(2),U)) D S(X)
S X="" I $D(BDMX(3)) S X="",$E(X,17)=$P(BDMX(3),U,2),$E(X,26)=$$DATE($P(BDMX(3),U)) D S(X)
S BDMSBEG=$$FMADD^XLFDT(DT,-(6*30.5))
S %=$$ACE^BDMS9B4(BDMSDFN,BDMSBEG)
S X="",X="ACE Inhibitor or ARB prescribed (in past 6 months): "
I $E(%)="N" S $E(X,50)=% D S(X,1) I 1
E D S(X) S X=" "_% D S(X)
K BDMSX
S BDMSBEG=$$FMADD^XLFDT(DT,-180)
S BDMSX=$E($$ASPIRIN(BDMSDFN,BDMSBEG),1,32)
S X="Aspirin or Other Anti-platelet/Anticoagulant prescribed (past 6 months): "
I $E(BDMSX)="N" S X=X_BDMSX D S(X) I 1
E D S(X) S X=" "_BDMSX D S(X)
I BDMSX="No" S X="",X=$$ASPREF^BDMS9B4(BDMSDFN) I X]"" S X=" "_X D S(X)
;statin
S X=""
S BDMSBEG=$$FMADD^XLFDT(DT,-180)
S Y=$$STATIN^BDMDG16(BDMSDFN,BDMSBEG,DT)
S X="Statin prescribed (in past 6 months):"
I $E(Y)=2 S $E(X,50)=$P(Y," ",2,99) D S(X)
I $E(Y)=1 D S(X) S X=" "_$P(Y," ",2,99) D S(X)
I $E(Y)=3 D S(X) S X=" Statin Note: "_$P(Y," ",2,99) D S(X)
;
M12 ;
;determine date range
S BDMSBEG=$$FMADD^XLFDT(DT,-365)
S X="Exams (in past 12 months):" D S(X,1)
S X=" Foot:",$E(X,13)=$P($$DFE^BDMDG17(BDMSDFN,BDMSBEG,DT,"H")," ",2,99) D S(X)
S X=" Eye:",$E(X,13)=$P($$EYE^BDMDG17(BDMSDFN,BDMSBEG,DT,"H")," ",2,99) D S(X)
S X=" Dental:",$E(X,13)=$P($$DENTAL^BDMDG17(BDMSDFN,BDMSBEG,DT,"H")," ",2,99) D S(X)
K BDMSTEX,BDMSDAT,BDMX
S BDMDEPP=$$DEPDX^BDMDG12(BDMSDFN,$$FMADD^XLFDT(DT,-365),DT)
S BDMDEPP=$P(BDMDEPP," ",2,99)
S BDMDEPS=$$DEPSCR^BDMDG12(BDMSDFN,$$FMADD^XLFDT(DT,-365),DT)
S BDMDEPS=$P(BDMDEPS," ",2,99)
S X="Depression - Active problem: "_BDMDEPP D S(X,1)
S X="",$E(X,14)="If no, screened in past year: "_$S($E(BDMDEPP,1)="N":BDMDEPS,1:"") D S(X)
D MORE^BDMS9B2
S X=$P(^DPT(BDMSDFN,0),U),$E(X,35)="DOB: "_$$DOB^AUPNPAT(BDMSDFN,"S"),$E(X,55)="Chart #"_$$HRN^AUPNPAT(BDMSDFN,DUZ(2),2) D S(X,1) ;IHS/CMI/LAB - X,3 to X,2
Q
DPCP(P) ;EP
NEW R
D ALLDP^BDPAPI(P,"DESIGNATED PRIMARY PROVIDER",.R)
I $D(R("DESIGNATED PRIMARY PROVIDER")) Q $P(^VA(200,$P(R("DESIGNATED PRIMARY PROVIDER"),U,2),0),U,1)
S R=$P(^AUPNPAT(P,0),U,14) I R Q $P(^VA(200,R,0),U,1)
S R=""
Q R
;
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X,L
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("APCHS",$J,"DCS",0),U)+1,$P(^TMP("APCHS",$J,"DCS",0),U)=%
S ^TMP("APCHS",$J,"DCS",%)=X
Q
HTN(P) ;
;check problem list OR must have 3 diagnoses
N T S T=$O(^ATXAX("B","SURVEILLANCE HYPERTENSION",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) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U) I $$ICD^BDMUTL(Y,"SURVEILLANCE HYPERTENSION",9) S I=1 Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL($$LE^BDMS9B2(),"PXRM ESSENTIAL HYPERTENSION",$P(^AUPNPROB(X,800),U,1)) S I=1
I I Q "Yes"
NEW BDMX
S BDMX=""
S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION" S E=$$START1^APCLDF(X,"BDMX(") G:E HTNX I $D(BDMX(3)) S BDMX="Yes"
I $G(BDMX)="" S BDMX="No"
HTNX ;
Q BDMX
DMPN(P) ;return problem number of firt encountered DM problem
I '$G(P) Q ""
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q ""
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(D]"") D
.S I=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $$ICD^BDMUTL(I,"SURVEILLANCE DIABETES",9) S D=X Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL($$LE^BDMS9B2(),"PXRM DIABETES",$P(^AUPNPROB(X,800),U,1)) S D=X
I D="" Q D
S X=D ;Ien of problem now return problem #
NEW L S L=$P(^AUPNPROB(X,0),U,6)
NEW Y S Y=$S(L:$P(^AUTTLOC(L,0),U,7),1:"???")_$P(^AUPNPROB(X,0),U,7)
Q Y
BP(P) ;last 3 BPs
;exclude ER visits for BP's
NEW BDMD,BDMC
K BDMX
S BDMX="",BDMD="",BDMC=0
S T=$O(^AUTTMSR("B","BP",""))
F S BDMD=$O(^AUPNVMSR("AA",P,T,BDMD)) Q:BDMD=""!(BDMC=3) D
.S M=0 F S M=$O(^AUPNVMSR("AA",P,T,BDMD,M)) Q:M'=+M!(BDMC=3) D
..S V=$P($G(^AUPNVMSR(M,0)),U,3) Q:'V
..Q:'$D(^AUPNVSIT(V,0))
..Q:$$CLINIC^APCLV(V,"C")=30
..Q:$P($G(^AUPNVMSR(M,2)),U,1) ;deleted
..S BDMC=BDMC+1,BDMX(BDMC)=(9999999-BDMD)_U_$P(^AUPNVMSR(M,0),U,4)
..Q
.Q
I '$D(BDMX(1)) S BDMX(1)="^None recorded"
BPX ;
K BDMD,BDMC
Q BDMX
GETHWB(P) ;get last height, height date, weight, weight date and BMI for patient P, return in BDMX("HT"),BDMX("HTD"),BDMX("WT"),BDMX("WTD"),BDMX("BMI")
K BDMX
NEW BDMWV
S BDMX("HT")="",BDMX("HTD")="",BDMX("WT")="",BDMX("WTD")="",BDMX("BMI")="",BDMX("WC")="",BDMX("WCD")=""
LASTHT ;
Q:'$D(^AUPNVSIT("AC",P))
Q:'$D(^AUPNVMSR("AC",P))
NEW BDMY
S %=P_"^LAST MEAS HT" NEW X S E=$$START1^APCLDF(%,"BDMY(") S BDMX("HT")=$$STRIP^XLFSTR($J($P($G(BDMY(1)),U,2),5,2)," "),BDMX("HTD")=$$DATE($P($G(BDMY(1)),U))
;S BDMX("HT")=$S(BDMX("HT")]"":$J(BDMX("HT"),2,0),1:"")
LASTWT ;
K BDMY S %=P_"^LAST MEAS WT" NEW X S E=$$START1^APCLDF(%,"BDMY(") S BDMX("WT")=$P($G(BDMY(1)),U,2)\1,BDMX("WTD")=$$DATE($P($G(BDMY(1)),U)),BDMWV=$P($G(BDMY(1)),U,5)
LASTWC ;
;K BDMY S %=P_"^LAST MEAS WC" NEW X S E=$$START1^APCLDF(%,"BDMY(") S BDMX("WC")=$P($G(BDMY(1)),U,2),BDMX("WCD")=$$DATE($P($G(BDMY(1)),U))
BMI ;
I $$AGE^AUPNPAT(P)<19,(BDMX("WTD")'=BDMX("HTD")) Q
I BDMX("WT")=""!('BDMX("HT")) Q
;is there a pregnancy dx on date of weight?
;
NEW X K BDMY S %=P_"^LAST DX [BGP PREGNANCY DIAGNOSES 2;DURING "_BDMX("WTD")_"-"_BDMX("WTD") S E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)) Q
S %=""
;S W=BDMX("WT")*.45359,H=(BDMX("HT")*0.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
S H=(BDMX("HT")*BDMX("HT")),W=BDMX("WT"),%=(W/H)*703,%=$J(%,4,1)
S BDMX("BMI")=%
Q
ASPIRIN(P,D) ;
I '$G(P) Q ""
I '$G(D) S D=0 ;if don't pass date look at all time
NEW V,I,%
S %=""
NEW T,T1,T2 S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
S T1=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
S T2=$O(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0))
I 'T Q ""
S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.S V=0 F S V=$O(^AUPNVMED("AA",P,I,V)) Q:V'=+V!(%) S G=$P(^AUPNVMED(V,0),U) D
..I $D(^ATXAX(T,21,"B",G)) S %=V Q
..I T2,$D(^ATXAX(T2,21,"B",G)) S %=V Q
..I T1,$D(^ATXAX(T1,21,"B",G)) S %=V Q
I %]"" D Q %
.I $P(^AUPNVMED(%,0),U,8)="" S %="Yes "_$$DATE($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01) Q
.I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued "_$$DATE($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01) Q
Q "No"
DOO(P) ;get earliest date of onset
NEW X,DOO
S X=$$CMSFDX^BDMS9B4(P,"I")
I X]"",'$D(DOO(X)) S DOO(X)=$E($$CMSFDXR^BDMS9B4(P),1,22)
S DOO="" S X=$$PLDMDOO^BDMS9B4(P,"I")
I X]"" S DOO(X)="Problem List"
I $O(DOO(0))="" Q ""
S X=$O(DOO(0)) Q $$DATE(X)_" ("_DOO(X)_")"
NOTREG(P) ;is patient on any Diabetes register 1 if on reg, "" if not
I $G(P)="" Q ""
NEW X,Y
S X=0,Y="" F S X=$O(^ACM(41,"AC",P,X)) Q:X'=+X!(Y) D
.S N=$$UP^XLFSTR($P($G(^ACM(41.1,X,0)),U))
.I N["DIABETES" S Y=1
.I N["DIAB" S Y=1
.I N["DM " S Y=1
.I N[" DM" S Y=1
.Q
Q Y
DEPPL(P,BDATE,EDATE) ;EP
NEW BDM,X
K BDM
S (G,X,I)=""
;is depression on the problem list?
S T=$O(^ATXAX("B","BGP MOOD DISORDERS",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.S I=$P($G(^AUPNPROB(X,0)),U)
.Q:'$$ICD^BDMUTL(I,"BGP MOOD DISORDERS",9)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S G="Yes Problem List ("_$P($$ICDDX^BDMUTL(I,,,"I"),U,2)_") " ;_$E($P($$ICDDX^BDMUTL(I,,,"I"),U,4),1,20)
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL($$LE^BDMS9B2(),"DEPRESSION DIAGNOSES",$P(^AUPNPROB(X,800),U,1)) S G="Yes Problem List (SNOMED: "_$P(^AUPNPROB(X,800),U,1)_") "
.Q
I G]"" Q G
S (G,X,I)=""
;is depression on the BH problem list?
S T=$O(^ATXAX("B","BGP MOOD DISORDERS",0))
S X=0 F S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(G]"") D
.S I=$P($G(^AMHPPROB(X,0)),U)
.Q:I=""
.S I=$P($G(^AMHPROB(I,0)),U,5)
.Q:I=""
.;S I=+$$CODEN^ICDCODE(I,80)
.S I=+$$CODEN^BDMUTL(I,80) ;cmi/maw 05/14/2014 patch 8 ICD-10
.Q:I=""
.Q:'$$ICD^BDMUTL(I,T,9)
.Q:$P(^AMHPPROB(X,0),U,12)'="A"
.;S G="Yes - BH Problem List "_$P(^ICD9(I,0),U) cmi/anch/maw 8/27/2007 orig line
.S G="Yes - BH Problem List "_$P($$ICDDX^BDMUTL(I,,,"I"),U,2) ;cmi/anch/maw 8/27/2007 code set versioning
.Q
I G]"" Q G
;now check for 2 dxs in past year
S Y="BDM("
S X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BDM(2)) Q "Yes, 2 or more dxs in past year"
S BDM=0,BDMV="" I $D(BDM(1)) S BDM=1,BDMV=$P(BDM(1),U,5)
S X=BDATE,%DT="P" D ^%DT S BD=Y
S X=EDATE,%DT="P" D ^%DT S ED=Y
;go through BH record file and find up to 2 visits in date range
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BDM>1) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BDM>1) D
.Q:'$D(^AMHREC(V,0))
.I $P(^AMHREC(V,0),U,16)]"",BDMV]"",$P(^AMHREC(V,0),U,16)=BDMV Q ;don't use same visit
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BDM>1) S BDMP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'BDMP
..S BDMP=$P($G(^AMHPROB(BDMP,0)),U)
..I BDMP=14 S BDM=BDM+1 Q
..I BDMP=15 S BDM=BDM+1 Q
..I BDMP=18 S BDM=BDM+1 Q
..I BDMP=24 S BDM=BDM+1 Q
..I $E(BDMP,1,3)=296 S BDM=BDM+1 Q
..I $E(BDMP,1,3)=300 S BDM=BDM+1 Q
..I $E(BDMP,1,3)=309 S BDM=BDM+1 Q
..I BDMP="301.13" S BDM=BDM+1 Q
..I BDMP=308.3 S BDM=BDM+1 Q
..I BDMP="311." S BDM=BDM+1 Q
..Q
I BDM>1 Q "Yes, 2 or more dxs in past year"
Q "No"
BDMS9B1 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT 12 Jan 2011 12:27 PM ; [ 12 Jan 2011 12:27 PM ]
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;
+3 IF '$GET(APCHSPAT)
QUIT
+4 SET BDMSPAT=APCHSPAT
+5 SET BDMSHDR=APCHSHDR
+6 DO EN^XBNEW("EP^BDMS9B1","BDMSPAT;BDMSHDR;APCHSQIT")
+7 KILL ^TMP("APCHS",$JOB)
+8 KILL BDMSPAT
+9 QUIT
EP ;EP - called from xbnew
+1 DO EP2(BDMSPAT)
W ;write out array
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL BDMQUIT
+3 WRITE !
+4 SET BDMX=0
FOR
SET BDMX=$ORDER(^TMP("APCHS",$JOB,"DCS",BDMX))
IF BDMX'=+BDMX!($DATA(BDMQUIT))
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(BDMQUIT)
QUIT
+6 WRITE ^TMP("APCHS",$JOB,"DCS",BDMX),!
+7 QUIT
End DoDot:1
+8 IF $DATA(BDMQUIT)
SET APCHSQIT=1
+9 KILL ^TMP("APCHS",$JOB,"DCS")
+10 DO EOJ
+11 QUIT
+12 ;
EOJ ;
+1 KILL BDMX,BDMQUIT,BDMY,BDMSDFN,BDMSBEG,BDMSTOB,BDMSUPI,BDMSED,BDMTOBN,BDMTOB,BDMSTEX
+2 KILL N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
+3 QUIT
+1 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BDMQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,BDMSHDR,!
+3 WRITE !,"Diabetes Patient Care Summary - continued"
+4 WRITE !,"Patient: ",$PIECE(^DPT(BDMSPAT,0),U)," HRN: ",$$HRN^AUPNPAT(BDMSPAT,DUZ(2)),!
+5 QUIT
EP2(BDMSDFN) ;PEP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("APCHS",$J,"DCS"
+2 KILL ^TMP("APCHS",$JOB,"DCS")
+3 SET ^TMP("APCHS",$JOB,"DCS",0)=0
+4 DO EN^XBNEW("EP21^BDMS9B1","BDMSDFN")
+5 QUIT
EP21 ;
+1 SET BDMSPAT=BDMSDFN
+2 DO SETARRAY
+3 ;K ^XTMP("BDMTAX",BDMJOB,BDMBTH)
+4 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 IF 'D
QUIT $$DATE1(D)
+3 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
DATE1(D) ;
+1 NEW %,%DT,X,Y
+2 SET %=""
SET %DT="P"
SET X=D
DO ^%DT
+3 IF Y=-1
QUIT ""
+4 QUIT $$DATE(Y)
SETARRAY ;set up array containing dm care summary
+1 ;CHECK TO SEE IF START1^APCLDF EXISTS
+2 SET BDMJOB=$JOB
SET BDMBTH=$HOROLOG
+3 ;D UNFOLDTX^BDMUTL(2016)
+4 IF '$DATA(BDMSCVD)
SET BDMSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+5 SET X="APCLDF"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+6 SET X="DIABETES PATIENT CARE SUMMARY"
SET $EXTRACT(X,40)="Report Date: "_$$DATE(DT)
DO S(X)
+7 SET X="Patient: "_$EXTRACT($PIECE(^DPT(BDMSDFN,0),U),1,28)
SET $EXTRACT(X,40)="HRN: "_$$HRN^AUPNPAT(BDMSDFN,DUZ(2))
DO S(X,1)
+8 IF $$DOD^AUPNPAT(BDMSDFN)]""
SET X="DATE OF DEATH: "_$$DATE($$DOD^AUPNPAT(BDMSDFN))
DO S(X,1)
DO S(" ")
+9 SET X="Age: "_$$AGE^BDMAPIU(BDMSDFN,1,DT)_" (DOB "_$$DATE($$DOB^AUPNPAT(BDMSDFN))_")"
SET $EXTRACT(X,40)="Sex: "_$$VAL^XBDIQ1(2,BDMSDFN,.02)
DO S(X)
+10 SET X="CLASS/BEN: "_$$VAL^XBDIQ1(9000001,BDMSDFN,1111)
SET $EXTRACT(X,40)="Designated PCP: "_$EXTRACT($$DPCP(BDMSDFN),1,25)
DO S(X)
+11 ;S Y=$$DMPN(BDMSDFN),$E(X,58)="DM Problem #: "_$S(Y]"":Y,1:"*NONE RECORDED*") D S(X,1)
SET X="Date of DM Diagnosis: "_$$DOO(BDMSDFN)
DO S(X,1)
+12 SET X=$$TYPE^BDMDG16(BDMSDFN,,DT)
DO S("Diabetes type: (1 or 2): "_X)
+13 SET X=""
IF '$$NOTREG(BDMSDFN)
SET X="**NOT ON DIABETES REGISTER**"
+14 DO GETHWB(BDMSDFN)
+15 SET X="BMI: "_BDMX("BMI")
SET $EXTRACT(X,12)="Last Height: "_$$STRIP^XLFSTR($JUSTIFY(BDMX("HT"),5,2)," ")_$SELECT(BDMX("HT")]"":" inches",1:"")
SET $EXTRACT(X,40)=BDMX("HTD")
DO S(X,1)
+16 SET X=""
SET $EXTRACT(X,12)="Last Weight: "_$SELECT(BDMX("WT")]"":BDMX("WT")\1,1:"")_$SELECT(BDMX("WT")]"":" lbs",1:"")
SET $EXTRACT(X,40)=BDMX("WTD")
DO S(X)
+17 SET BDMTOBC=""
SET BDMTOBS=$$TOBACCO^BDMDG1T(BDMSDFN,$$DOB^AUPNPAT(BDMSDFN),DT)
+18 DO S("Tobacco Use:",1)
+19 SET X=" Last Screened: "_$$DATE($PIECE(BDMTOBS,U,3))
DO S(X)
+20 SET X=" Current Status: "_$PIECE($PIECE($GET(BDMTOBS),U,2)," ",2,99)
DO S(X)
+21 ;I BDMTOBS="" S X=" Last Scree: NOT DOCUMENTED" D S(X,1)
+22 ;I $G(BDMTOBC)]"" S X=" "_$P(BDMTOBC,U,1) D S(X)
+23 ;COUNSELED?
+24 SET X=""
SET $EXTRACT(X,15)="Counseled in the past year? "
Begin DoDot:1
+25 IF $EXTRACT(BDMTOBS)
IF $EXTRACT(BDMTOBS)'=1
SET X=X_"N/A"
QUIT
+26 SET Y=$$CESS^BDMDG11(BDMSDFN,$$FMADD^XLFDT(DT,-365),DT)
+27 IF $EXTRACT(Y)=1
SET X=X_$PIECE(Y," ",2,999)
QUIT
+28 IF $EXTRACT(Y)=2
SET X=X_"No"
QUIT
End DoDot:1
+29 DO S(X)
+30 ; (BDMSDFN,$$DOB^AUPNPAT(BDMSDFN),DT)
SET X=$$LASTHF^BDMSMU(BDMSDFN,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)","X",$$DOB^AUPNPAT(BDMSDFN),DT)
+31 DO S("Electronic Nicotine Delivery System (ENDS) use:",1)
+32 SET Y=" Last Screened: "_$SELECT($PIECE(X,U,2)="":" Never",1:$$DATE($PIECE(X,U,2)))
DO S(Y)
+33 ;I $P(X,U,1)=1 D S(" "_$P(X,U,3))
SET Y=" Current Status: "_$PIECE(X,U,1)
DO S(Y)
+34 SET X="HTN Diagnosed: "_$$HTN(BDMSDFN)
DO S(X,1)
+35 SET X="CVD Diagnosed: "_$PIECE($$CVD^BDMDG12(BDMSDFN,DT)," ",2,999)
DO S(X)
+36 SET B=$$BP(BDMSDFN)
+37 SET X="Last 3 BP: "_$PIECE($GET(BDMX(1)),U,2)
SET $EXTRACT(X,26)=$$DATE($PIECE($GET(BDMX(1)),U))
DO S(X)
+38 SET X="(non ER)"
IF $DATA(BDMX(2))
SET $EXTRACT(X,17)=$PIECE(BDMX(2),U,2)
SET $EXTRACT(X,26)=$$DATE($PIECE(BDMX(2),U))
DO S(X)
+39 SET X=""
IF $DATA(BDMX(3))
SET X=""
SET $EXTRACT(X,17)=$PIECE(BDMX(3),U,2)
SET $EXTRACT(X,26)=$$DATE($PIECE(BDMX(3),U))
DO S(X)
+40 SET BDMSBEG=$$FMADD^XLFDT(DT,-(6*30.5))
+41 SET %=$$ACE^BDMS9B4(BDMSDFN,BDMSBEG)
+42 SET X=""
SET X="ACE Inhibitor or ARB prescribed (in past 6 months): "
+43 IF $EXTRACT(%)="N"
SET $EXTRACT(X,50)=%
DO S(X,1)
IF 1
+44 IF '$TEST
DO S(X)
SET X=" "_%
DO S(X)
+45 KILL BDMSX
+46 SET BDMSBEG=$$FMADD^XLFDT(DT,-180)
+47 SET BDMSX=$EXTRACT($$ASPIRIN(BDMSDFN,BDMSBEG),1,32)
+48 SET X="Aspirin or Other Anti-platelet/Anticoagulant prescribed (past 6 months): "
+49 IF $EXTRACT(BDMSX)="N"
SET X=X_BDMSX
DO S(X)
IF 1
+50 IF '$TEST
DO S(X)
SET X=" "_BDMSX
DO S(X)
+51 IF BDMSX="No"
SET X=""
SET X=$$ASPREF^BDMS9B4(BDMSDFN)
IF X]""
SET X=" "_X
DO S(X)
+52 ;statin
+53 SET X=""
+54 SET BDMSBEG=$$FMADD^XLFDT(DT,-180)
+55 SET Y=$$STATIN^BDMDG16(BDMSDFN,BDMSBEG,DT)
+56 SET X="Statin prescribed (in past 6 months):"
+57 IF $EXTRACT(Y)=2
SET $EXTRACT(X,50)=$PIECE(Y," ",2,99)
DO S(X)
+58 IF $EXTRACT(Y)=1
DO S(X)
SET X=" "_$PIECE(Y," ",2,99)
DO S(X)
+59 IF $EXTRACT(Y)=3
DO S(X)
SET X=" Statin Note: "_$PIECE(Y," ",2,99)
DO S(X)
+60 ;
M12 ;
+1 ;determine date range
+2 SET BDMSBEG=$$FMADD^XLFDT(DT,-365)
+3 SET X="Exams (in past 12 months):"
DO S(X,1)
+4 SET X=" Foot:"
SET $EXTRACT(X,13)=$PIECE($$DFE^BDMDG17(BDMSDFN,BDMSBEG,DT,"H")," ",2,99)
DO S(X)
+5 SET X=" Eye:"
SET $EXTRACT(X,13)=$PIECE($$EYE^BDMDG17(BDMSDFN,BDMSBEG,DT,"H")," ",2,99)
DO S(X)
+6 SET X=" Dental:"
SET $EXTRACT(X,13)=$PIECE($$DENTAL^BDMDG17(BDMSDFN,BDMSBEG,DT,"H")," ",2,99)
DO S(X)
+7 KILL BDMSTEX,BDMSDAT,BDMX
+8 SET BDMDEPP=$$DEPDX^BDMDG12(BDMSDFN,$$FMADD^XLFDT(DT,-365),DT)
+9 SET BDMDEPP=$PIECE(BDMDEPP," ",2,99)
+10 SET BDMDEPS=$$DEPSCR^BDMDG12(BDMSDFN,$$FMADD^XLFDT(DT,-365),DT)
+11 SET BDMDEPS=$PIECE(BDMDEPS," ",2,99)
+12 SET X="Depression - Active problem: "_BDMDEPP
DO S(X,1)
+13 SET X=""
SET $EXTRACT(X,14)="If no, screened in past year: "_$SELECT($EXTRACT(BDMDEPP,1)="N":BDMDEPS,1:"")
DO S(X)
+14 DO MORE^BDMS9B2
+15 ;IHS/CMI/LAB - X,3 to X,2
SET X=$PIECE(^DPT(BDMSDFN,0),U)
SET $EXTRACT(X,35)="DOB: "_$$DOB^AUPNPAT(BDMSDFN,"S")
SET $EXTRACT(X,55)="Chart #"_$$HRN^AUPNPAT(BDMSDFN,DUZ(2),2)
DO S(X,1)
+16 QUIT
DPCP(P) ;EP
+1 NEW R
+2 DO ALLDP^BDPAPI(P,"DESIGNATED PRIMARY PROVIDER",.R)
+3 IF $DATA(R("DESIGNATED PRIMARY PROVIDER"))
QUIT $PIECE(^VA(200,$PIECE(R("DESIGNATED PRIMARY PROVIDER"),U,2),0),U,1)
+4 SET R=$PIECE(^AUPNPAT(P,0),U,14)
IF R
QUIT $PIECE(^VA(200,R,0),U,1)
+5 SET R=""
+6 QUIT R
+7 ;
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X,L
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCHS",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("APCHS",$JOB,"DCS",0),U)=%
+2 SET ^TMP("APCHS",$JOB,"DCS",%)=X
+3 QUIT
HTN(P) ;
+1 ;check problem list OR must have 3 diagnoses
+2 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE HYPERTENSION",0))
+3 IF 'T
QUIT ""
+4 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNPROB(X,0))
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^BDMUTL(Y,"SURVEILLANCE HYPERTENSION",9)
SET I=1
QUIT
+9 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL($$LE^BDMS9B2(),"PXRM ESSENTIAL HYPERTENSION",$PIECE(^AUPNPROB(X,800),U,1))
SET I=1
End DoDot:1
+10 IF I
QUIT "Yes"
+11 NEW BDMX
+12 SET BDMX=""
+13 SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION"
SET E=$$START1^APCLDF(X,"BDMX(")
IF E
GOTO HTNX
IF $DATA(BDMX(3))
SET BDMX="Yes"
+14 IF $GET(BDMX)=""
SET BDMX="No"
HTNX ;
+1 QUIT BDMX
DMPN(P) ;return problem number of firt encountered DM problem
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+3 IF 'T
QUIT ""
+4 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(D]"")
QUIT
Begin DoDot:1
+5 SET I=$PIECE(^AUPNPROB(X,0),U)
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 IF $$ICD^BDMUTL(I,"SURVEILLANCE DIABETES",9)
SET D=X
QUIT
+8 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL($$LE^BDMS9B2(),"PXRM DIABETES",$PIECE(^AUPNPROB(X,800),U,1))
SET D=X
End DoDot:1
+9 IF D=""
QUIT D
+10 ;Ien of problem now return problem #
SET X=D
+11 NEW L
SET L=$PIECE(^AUPNPROB(X,0),U,6)
+12 NEW Y
SET Y=$SELECT(L:$PIECE(^AUTTLOC(L,0),U,7),1:"???")_$PIECE(^AUPNPROB(X,0),U,7)
+13 QUIT Y
BP(P) ;last 3 BPs
+1 ;exclude ER visits for BP's
+2 NEW BDMD,BDMC
+3 KILL BDMX
+4 SET BDMX=""
SET BDMD=""
SET BDMC=0
+5 SET T=$ORDER(^AUTTMSR("B","BP",""))
+6 FOR
SET BDMD=$ORDER(^AUPNVMSR("AA",P,T,BDMD))
IF BDMD=""!(BDMC=3)
QUIT
Begin DoDot:1
+7 SET M=0
FOR
SET M=$ORDER(^AUPNVMSR("AA",P,T,BDMD,M))
IF M'=+M!(BDMC=3)
QUIT
Begin DoDot:2
+8 SET V=$PIECE($GET(^AUPNVMSR(M,0)),U,3)
IF 'V
QUIT
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF $$CLINIC^APCLV(V,"C")=30
QUIT
+11 ;deleted
IF $PIECE($GET(^AUPNVMSR(M,2)),U,1)
QUIT
+12 SET BDMC=BDMC+1
SET BDMX(BDMC)=(9999999-BDMD)_U_$PIECE(^AUPNVMSR(M,0),U,4)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF '$DATA(BDMX(1))
SET BDMX(1)="^None recorded"
BPX ;
+1 KILL BDMD,BDMC
+2 QUIT BDMX
GETHWB(P) ;get last height, height date, weight, weight date and BMI for patient P, return in BDMX("HT"),BDMX("HTD"),BDMX("WT"),BDMX("WTD"),BDMX("BMI")
+1 KILL BDMX
+2 NEW BDMWV
+3 SET BDMX("HT")=""
SET BDMX("HTD")=""
SET BDMX("WT")=""
SET BDMX("WTD")=""
SET BDMX("BMI")=""
SET BDMX("WC")=""
SET BDMX("WCD")=""
LASTHT ;
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT
+2 IF '$DATA(^AUPNVMSR("AC",P))
QUIT
+3 NEW BDMY
+4 SET %=P_"^LAST MEAS HT"
NEW X
SET E=$$START1^APCLDF(%,"BDMY(")
SET BDMX("HT")=$$STRIP^XLFSTR($JUSTIFY($PIECE($GET(BDMY(1)),U,2),5,2)," ")
SET BDMX("HTD")=$$DATE($PIECE($GET(BDMY(1)),U))
+5 ;S BDMX("HT")=$S(BDMX("HT")]"":$J(BDMX("HT"),2,0),1:"")
LASTWT ;
+1 KILL BDMY
SET %=P_"^LAST MEAS WT"
NEW X
SET E=$$START1^APCLDF(%,"BDMY(")
SET BDMX("WT")=$PIECE($GET(BDMY(1)),U,2)\1
SET BDMX("WTD")=$$DATE($PIECE($GET(BDMY(1)),U))
SET BDMWV=$PIECE($GET(BDMY(1)),U,5)
LASTWC ;
+1 ;K BDMY S %=P_"^LAST MEAS WC" NEW X S E=$$START1^APCLDF(%,"BDMY(") S BDMX("WC")=$P($G(BDMY(1)),U,2),BDMX("WCD")=$$DATE($P($G(BDMY(1)),U))
BMI ;
+1 IF $$AGE^AUPNPAT(P)<19
IF (BDMX("WTD")'=BDMX("HTD"))
QUIT
+2 IF BDMX("WT")=""!('BDMX("HT"))
QUIT
+3 ;is there a pregnancy dx on date of weight?
+4 ;
+5 NEW X
KILL BDMY
SET %=P_"^LAST DX [BGP PREGNANCY DIAGNOSES 2;DURING "_BDMX("WTD")_"-"_BDMX("WTD")
SET E=$$START1^APCLDF(%,"BDMY(")
+6 IF $DATA(BDMY(1))
QUIT
+7 SET %=""
+8 ;S W=BDMX("WT")*.45359,H=(BDMX("HT")*0.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
+9 SET H=(BDMX("HT")*BDMX("HT"))
SET W=BDMX("WT")
SET %=(W/H)*703
SET %=$JUSTIFY(%,4,1)
+10 SET BDMX("BMI")=%
+11 QUIT
ASPIRIN(P,D) ;
+1 IF '$GET(P)
QUIT ""
+2 ;if don't pass date look at all time
IF '$GET(D)
SET D=0
+3 NEW V,I,%
+4 SET %=""
+5 NEW T,T1,T2
SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+6 SET T1=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+7 SET T2=$ORDER(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0))
+8 IF 'T
QUIT ""
+9 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V!(%)
QUIT
SET G=$PIECE(^AUPNVMED(V,0),U)
Begin DoDot:2
+11 IF $DATA(^ATXAX(T,21,"B",G))
SET %=V
QUIT
+12 IF T2
IF $DATA(^ATXAX(T2,21,"B",G))
SET %=V
QUIT
+13 IF T1
IF $DATA(^ATXAX(T1,21,"B",G))
SET %=V
QUIT
End DoDot:2
End DoDot:1
+14 IF %]""
Begin DoDot:1
+15 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes "_$$DATE($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01)
QUIT
+16 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued "_$$DATE($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01)
QUIT
End DoDot:1
QUIT %
+17 QUIT "No"
DOO(P) ;get earliest date of onset
+1 NEW X,DOO
+2 SET X=$$CMSFDX^BDMS9B4(P,"I")
+3 IF X]""
IF '$DATA(DOO(X))
SET DOO(X)=$EXTRACT($$CMSFDXR^BDMS9B4(P),1,22)
+4 SET DOO=""
SET X=$$PLDMDOO^BDMS9B4(P,"I")
+5 IF X]""
SET DOO(X)="Problem List"
+6 IF $ORDER(DOO(0))=""
QUIT ""
+7 SET X=$ORDER(DOO(0))
QUIT $$DATE(X)_" ("_DOO(X)_")"
NOTREG(P) ;is patient on any Diabetes register 1 if on reg, "" if not
+1 IF $GET(P)=""
QUIT ""
+2 NEW X,Y
+3 SET X=0
SET Y=""
FOR
SET X=$ORDER(^ACM(41,"AC",P,X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+4 SET N=$$UP^XLFSTR($PIECE($GET(^ACM(41.1,X,0)),U))
+5 IF N["DIABETES"
SET Y=1
+6 IF N["DIAB"
SET Y=1
+7 IF N["DM "
SET Y=1
+8 IF N[" DM"
SET Y=1
+9 QUIT
End DoDot:1
+10 QUIT Y
DEPPL(P,BDATE,EDATE) ;EP
+1 NEW BDM,X
+2 KILL BDM
+3 SET (G,X,I)=""
+4 ;is depression on the problem list?
+5 SET T=$ORDER(^ATXAX("B","BGP MOOD DISORDERS",0))
+6 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
+8 IF '$$ICD^BDMUTL(I,"BGP MOOD DISORDERS",9)
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+11 ;_$E($P($$ICDDX^BDMUTL(I,,,"I"),U,4),1,20)
SET G="Yes Problem List ("_$PIECE($$ICDDX^BDMUTL(I,,,"I"),U,2)_") "
+12 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL($$LE^BDMS9B2(),"DEPRESSION DIAGNOSES",$PIECE(^AUPNPROB(X,800),U,1))
SET G="Yes Problem List (SNOMED: "_$PIECE(^AUPNPROB(X,800),U,1)_") "
+13 QUIT
End DoDot:1
+14 IF G]""
QUIT G
+15 SET (G,X,I)=""
+16 ;is depression on the BH problem list?
+17 SET T=$ORDER(^ATXAX("B","BGP MOOD DISORDERS",0))
+18 SET X=0
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+19 SET I=$PIECE($GET(^AMHPPROB(X,0)),U)
+20 IF I=""
QUIT
+21 SET I=$PIECE($GET(^AMHPROB(I,0)),U,5)
+22 IF I=""
QUIT
+23 ;S I=+$$CODEN^ICDCODE(I,80)
+24 ;cmi/maw 05/14/2014 patch 8 ICD-10
SET I=+$$CODEN^BDMUTL(I,80)
+25 IF I=""
QUIT
+26 IF '$$ICD^BDMUTL(I,T,9)
QUIT
+27 IF $PIECE(^AMHPPROB(X,0),U,12)'="A"
QUIT
+28 ;S G="Yes - BH Problem List "_$P(^ICD9(I,0),U) cmi/anch/maw 8/27/2007 orig line
+29 ;cmi/anch/maw 8/27/2007 code set versioning
SET G="Yes - BH Problem List "_$PIECE($$ICDDX^BDMUTL(I,,,"I"),U,2)
+30 QUIT
End DoDot:1
+31 IF G]""
QUIT G
+32 ;now check for 2 dxs in past year
+33 SET Y="BDM("
+34 SET X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+35 IF $DATA(BDM(2))
QUIT "Yes, 2 or more dxs in past year"
+36 SET BDM=0
SET BDMV=""
IF $DATA(BDM(1))
SET BDM=1
SET BDMV=$PIECE(BDM(1),U,5)
+37 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+38 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+39 ;go through BH record file and find up to 2 visits in date range
+40 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BDM>1)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BDM>1)
QUIT
Begin DoDot:1
+41 IF '$DATA(^AMHREC(V,0))
QUIT
+42 ;don't use same visit
IF $PIECE(^AMHREC(V,0),U,16)]""
IF BDMV]""
IF $PIECE(^AMHREC(V,0),U,16)=BDMV
QUIT
+43 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BDM>1)
QUIT
SET BDMP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+44 IF 'BDMP
QUIT
+45 SET BDMP=$PIECE($GET(^AMHPROB(BDMP,0)),U)
+46 IF BDMP=14
SET BDM=BDM+1
QUIT
+47 IF BDMP=15
SET BDM=BDM+1
QUIT
+48 IF BDMP=18
SET BDM=BDM+1
QUIT
+49 IF BDMP=24
SET BDM=BDM+1
QUIT
+50 IF $EXTRACT(BDMP,1,3)=296
SET BDM=BDM+1
QUIT
+51 IF $EXTRACT(BDMP,1,3)=300
SET BDM=BDM+1
QUIT
+52 IF $EXTRACT(BDMP,1,3)=309
SET BDM=BDM+1
QUIT
+53 IF BDMP="301.13"
SET BDM=BDM+1
QUIT
+54 IF BDMP=308.3
SET BDM=BDM+1
QUIT
+55 IF BDMP="311."
SET BDM=BDM+1
QUIT
+56 QUIT
End DoDot:2
End DoDot:1
+57 IF BDM>1
QUIT "Yes, 2 or more dxs in past year"
+58 QUIT "No"
