APCHS9B1 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
;;2.0;IHS PCC SUITE;**2,4,5,11**;MAY 14, 2009;Build 58
;
;IHS/CMI/LAB patch 3 many changes
;patch 14 added depression screening
;patch 14 added loinc code lookups
;cmi/anch/maw 8/27/2007 code set versioning in DMPN and DEPPL
;
EP ;EP - called from component
Q:'$G(APCHSPAT)
I $E(IOST)="C",IO=IO(0) W !! S DIR("A")="DIABETES SUMMARY WILL NOW BE DISPLAYED (^ TO EXIT, RETURN TO CONTINUE)",DIR(0)="E" D ^DIR I $D(DIRUT) S APCHSQIT=1 Q ;IHS/CMI/LAB fixed for slave printing
;NEW X S X="BDMS9B1" X ^%ZOSF("TEST") I $T D ^BDMS9B1 D EOJ Q
D EP2(APCHSPAT)
W ;write out array
W:$D(IOF) @IOF
K APCHQUIT
S APCHX=0 F S APCHX=$O(^TMP("APCHS",$J,"DCS",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT)) D
.I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)
.W !,^TMP("APCHS",$J,"DCS",APCHX)
.Q
I $D(APCHQUIT) S APCHSQIT=1
D EOJ
Q
;
EOJ ;
K APCHX,APCHQUIT,APCHY,APCHSDFN,APCHSBEG,APCHSTOB,APCHSUPI,APCHSED,APCHTOBN,APCHTOB,APCHSTEX
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 APCHQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
W !,APCHSHDR,!
W !,"Diabetes Patient Care Summary - continued"
W !,"Patient: ",$P(^DPT(APCHSPAT,0),U)," HRN: ",$$HRN^AUPNPAT(APCHSPAT,DUZ(2)),!
Q
EP2(APCHSDFN) ;PEP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("APCHS",$J,"DCS"
NEW X S X="BDMS9B1" X ^%ZOSF("TEST") I $T D EP2^BDMS9B1(APCHSDFN) Q
K ^TMP("APCHS",$J,"DCS")
S ^TMP("APCHS",$J,"DCS",0)=0
I '$D(APCHSCVD) S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
D SETARRAY
Q
SETARRAY ;set up array containing dm care summary
;CHECK TO SEE IF START1^APCLDF EXISTS
S X="APCLDF" X ^%ZOSF("TEST") I '$T Q
S X="DIABETES PATIENT CARE SUMMARY Report Date: "_$$FMTE^XLFDT(DT) D S(X)
S X="Patient Name: "_$P(^DPT(APCHSDFN,0),U)_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)) D S(X)
I $$DOD^AUPNPAT(APCHSDFN)]"" S X="DATE OF DEATH: "_$$FMTE^XLFDT($$DOD^AUPNPAT(APCHSDFN)) D S(X,1),S(" ")
S X="Age: "_$$AGE^AUPNPAT(APCHSDFN),$E(X,15)="Sex: "_$$SEX^AUPNPAT(APCHSDFN),$E(X,31)="Date of DM Onset: "_$$DOO(APCHSDFN) D S(X)
S X="",X="Dob: "_$$FMTE^XLFDT($$DOB^AUPNPAT(APCHSDFN)) S Y=$$DMPN(APCHSDFN),$E(X,31)="DM Problem #: "_$S(Y]"":Y,1:"*** NONE RECORDED ***") D S(X)
S X="" I '$$NOTREG(APCHSDFN) S X="**NOT ON DIABETES REGISTER**"
S $E(X,31)="Designated PCP: "_$$VAL^XBDIQ1(9000001,APCHSDFN,.14) D S(X)
D GETHWB(APCHSDFN) S X="Last Height: "_APCHX("HT")_$S(APCHX("HT")]"":" inches",1:""),$E(X,31)=APCHX("HTD") D S(X)
S X="Last Weight: "_$S(APCHX("WT")]"":$J(APCHX("WT"),3,0),1:"")_$S(APCHX("WT")]"":" lbs",1:""),$E(X,31)=APCHX("WTD"),$E(X,45)="BMI: "_APCHX("BMI") D S(X)
I APCHX("WC")]"" S X="Last Waist Circumference: "_APCHX("WC"),$E(X,31)=APCHX("WCD") D S(X)
D TOBACCO^APCHS9B6
S X="Tobacco Use: "_$G(APCHTOB) D S(X)
S X="HTN Diagnosed: "_$$HTN(APCHSDFN) D S(X)
S APCHSBEG=$$FMADD^XLFDT(DT,-(6*30.5))
S %=$$ACE^APCHS9B5(APCHSDFN,APCHSBEG) ;get date of last ACE in last year
S X="",X="ON ACE Inhibitor/ARB in past 6 months: "_% D S(X)
K APCHSX S APCHSBEG=$$FMADD^XLFDT(DT,-365) S X="Aspirin Use/Anti-platelet (in past yr): "_$E($$ASPIRIN(APCHSDFN,APCHSBEG),1,32) D S(X)
S X="",X=$$ASPREF^APCHS9B5(APCHSDFN) I X]"" S X=" "_X D S(X)
S APCHDEPP=$$DEPPL(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT)
S APCHDEPS=$$DEPSCR(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT)
S B=$$BP(APCHSDFN)
S X="Last 3 BP: "_$P($G(APCHX(1)),U,2)_" "_$$FMTE^XLFDT($P($G(APCHX(1)),U))
S $E(X,40)="Is Depression on the Problem List?"
D S(X)
S X="(non ER)" I $D(APCHX(2)) S $E(X,13)=$P(APCHX(2),U,2)_" "_$$FMTE^XLFDT($P(APCHX(2),U))
S $E(X,42)=APCHDEPP
D S(X)
S X="" I $D(APCHX(3)) S X="",$E(X,13)=$P(APCHX(3),U,2)_" "_$$FMTE^XLFDT($P(APCHX(3),U))
I $E(APCHDEPP,1)="N" S $E(X,40)="If no, Depression Screening in past year?"
D S(X)
S X="" I $E(APCHDEPP,1)="N" S $E(X,42)=APCHDEPS
D S(X)
M12 ;
;determine date range
S APCHSBEG=$$FMADD^XLFDT(DT,-365)
S X="In past 12 months:" D S(X)
S X="Diabetic Foot Exam:",$E(X,23)=$$DFE^APCHS9B4(APCHSDFN,APCHSBEG) D S(X)
S X="Diabetic Eye Exam:",$E(X,23)=$$EYE^APCHS9B4(APCHSDFN,APCHSBEG) D S(X)
S X="Dental Exam:",$E(X,23)=$$DENTAL^APCHS9B6(APCHSDFN,APCHSBEG) D S(X)
;S X="Rectal Exam (age>40):",$E(X,27)=$$RECTAL^APCHS9B4(APCHSDFN,APCHSBEG) D S(X)
K APCHSTEX,APCHSDAT,APCHX
I $P(^DPT(APCHSDFN,0),U,2)="F" D
.S X="(Females Only)" D S(X)
.K APCHSTEX,APCHSDAT
.S APCHX=$$PAP^APCHS9B4(APCHSDFN) ;get date of last pap in pcc/refusal
.S X="Last Pap Smear documented in PCC/WH: "_$$FMTE^XLFDT($P(APCHX,U)) D S(X)
.I $P(APCHX,U,2)]"" S X=$P(APCHX,U,2) D S(X)
.D PAP^APCHS9B5
.S X="",$E(X,17)="WH Cervical TX Need:",$E(X,38)=$G(APCHSTEX(1)) D S(X)
.S X="",Y=1 F S Y=$O(APCHSTEX(Y)) Q:Y="" S X="",$E(X,12)=APCHSTEX(Y) D S(X)
.;S X=" Breast exam:",$E(X,27)=$$BREAST^APCHS9B4(APCHSDFN,APCHSBEG) D S(X)
.K APCHSTEX,APCHSDAT D MAM^APCHS9B5 S X="Mammogram:",$E(X,12)=$$FMTE^XLFDT(APCHSDAT)_" "_$G(APCHSTEX(1)) D S(X)
.S X="",Y=1 F S Y=$O(APCHSTEX(Y)) Q:Y="" S X="",$E(X,23)=APCHSTEX(Y) D S(X)
D MORE^APCHS9B2
S X=$P(^DPT(APCHSDFN,0),U),$E(X,35)="DOB: "_$$DOB^AUPNPAT(APCHSDFN,"S"),$E(X,55)="Chart #"_$$HRN^AUPNPAT(APCHSDFN,DUZ(2),2) D S(X,1) ;IHS/CMI/LAB - X,3 to X,2
;S X="" D S(X,1)
Q
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;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) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXAPI(Y,T,9) S I=1
I I Q "Yes"
NEW APCHX
S APCHX=""
S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION" S E=$$START1^APCLDF(X,"APCHX(") G:E HTNX I $D(APCHX(3)) S APCHX="Yes"
I $G(APCHX)="" S APCHX="No"
HTNX ;
Q APCHX
DMPN(P) ;return problem number of lowest DM code
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
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.S I=$P(^AUPNPROB(X,0),U)
.I $$ICD^ATXAPI(I,T,9) D
..;S D(+$P(^ICD9(I,0),U))=X cmi/anch/maw 8/27/2007 orig line
..S D(+$P($$ICDDX^ICDEX(I,,,"I"),U,2))=X ;cmi/anch/maw 8/27/2007 code set versioning
..Q
.Q
S D=$O(D(""))
I D="" Q D
S X=D(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
;IHS/CMI/LAB - fixed to exclude ER visits for BP's
NEW APCHD,APCHC
K APCHX
S APCHX="",APCHD="",APCHC=0
;S X=P_"^LAST 3 MEASUREMENTS BP" S E=$$START1^APCLDF(X,"APCHX(") G:E BPX I $D(APCHX(1)) D
S T=$O(^AUTTMSR("B","BP",""))
F S APCHD=$O(^AUPNVMSR("AA",P,T,APCHD)) Q:APCHD=""!(APCHC=3) D
.S M=0 F S M=$O(^AUPNVMSR("AA",P,T,APCHD,M)) Q:M'=+M!(APCHC=3) D
..S V=$P($G(^AUPNVMSR(M,0)),U,3) Q:'V
..Q:'$D(^AUPNVSIT(V,0))
..Q:$P($G(^AUPNVMSR(M,2)),U,1) ;entered in error
..Q:$$CLINIC^APCLV(V,"C")=30
..S APCHC=APCHC+1,APCHX(APCHC)=(9999999-APCHD)_U_$P(^AUPNVMSR(M,0),U,4)
..Q
.Q
I '$D(APCHX(1)) S APCHX(1)="None recorded"
BPX ;
K APCHD,APCHC
Q APCHX
GETHWB(P) ;get last height, height date, weight, weight date and BMI for patient P, return in APCHX("HT"),APCHX("HTD"),APCHX("WT"),APCHX("WTD"),APCHX("BMI")
K APCHX
S APCHX("HT")="",APCHX("HTD")="",APCHX("WT")="",APCHX("WTD")="",APCHX("BMI")="",APCHX("WC")="",APCHX("WCD")=""
LASTHT ;
Q:'$D(^AUPNVSIT("AC",P))
Q:'$D(^AUPNVMSR("AC",P))
NEW APCHY
S %=P_"^LAST MEAS HT" NEW X S E=$$START1^APCLDF(%,"APCHY(") S APCHX("HT")=$P($G(APCHY(1)),U,2),APCHX("HTD")=$$FMTE^XLFDT($P($G(APCHY(1)),U))
S APCHX("HT")=$S(APCHX("HT")]"":$J(APCHX("HT"),2,0),1:"")
LASTWT ;
K APCHY S %=P_"^LAST MEAS WT" NEW X S E=$$START1^APCLDF(%,"APCHY(") S APCHX("WT")=$P($G(APCHY(1)),U,2),APCHX("WTD")=$$FMTE^XLFDT($P($G(APCHY(1)),U))
LASTWC ;
K APCHY S %=P_"^LAST MEAS WC" NEW X S E=$$START1^APCLDF(%,"APCHY(") S APCHX("WC")=$P($G(APCHY(1)),U,2),APCHX("WCD")=$$FMTE^XLFDT($P($G(APCHY(1)),U))
BMI ;
I $$AGE^AUPNPAT(P)<19,(APCHX("WTD")'=APCHX("HTD")) Q
I APCHX("WT")=""!('APCHX("HT")) Q
S %=""
;S W=(APCHX("WT")/5)*2.3,H=(APCHX("HT")*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
S W=APCHX("WT")*.45359,H=(APCHX("HT")*0.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
S APCHX("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 S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
S T1=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",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 T1,$D(^ATXAX(T1,21,"B",G)) S %=V Q
I %]"" D Q %
.I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01) Q
.I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($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^APCHS9B4(P,"I")
I X]"",'$D(DOO(X)) S DOO(X)="Diabetes Register"
S DOO="" S X=$$PLDMDOO^APCHS9B4(P,"I")
I X]"" S DOO(X)="Problem List"
I $O(DOO(0))="" Q ""
S X=$O(DOO(0)) Q $$FMTE^XLFDT(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 APCH,X
K APCH
S (G,X,I)=""
;is depression on the problem list?
S T=$O(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.S I=$P($G(^AUPNPROB(X,0)),U)
.Q:'$$ICD^ATXAPI(I,T,9)
.;S G="Yes - Problem List "_$P(^ICD9(I,0),U) cmi/anch/maw 8/27/2007 orig line
.S G="Yes - Problem List "_$P($$ICDDX^ICDEX(I,,"I"),U,2) ;cmi/anch/maw 8/27/2007 code set versioning
.Q
I G]"" Q G
S (G,X,I)=""
;is depression on the BH problem list?
S T=$O(^ATXAX("B","DM AUDIT DEPRESSIVE 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)
.S I=$P($G(^AMHPROB(I,0)),U,5)
.Q:I=""
.S I=+$$IEN^ICDEX(I,80,1)
.Q:I=""
.Q:'$$ICD^ATXAPI(I,T,9)
.;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^ICDEX(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="APCH("
S X=P_"^LAST 2 DX [DM AUDIT DEPRESSIVE DISORDERS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(APCH(2)) Q "Yes 2 or more dxs in past year"
S APCH=0,APCHV="" I $D(APCH(1)) S APCH=1,APCHV=$P(APCH(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)!(APCH>1) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(APCH>1) D
.Q:'$D(^AMHREC(V,0))
.I $P(^AMHREC(V,0),U,16)]"",APCHV]"",$P(^AMHREC(V,0),U,16)=APCHV Q ;don't use same visit
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(APCH>1) S APCHP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'APCHP
..S APCHP=$P($G(^AMHPROB(APCHP,0)),U)
..I APCHP=14 S APCH=APCH+1 Q
..I APCHP=15 S APCH=APCH+1 Q
..I APCHP=18 S APCH=APCH+1 Q
..I APCHP=24 S APCH=APCH+1 Q
..I $E(APCHP,1,3)=296 S APCH=APCH+1 Q
..I $E(APCHP,1,3)=300 S APCH=APCH+1 Q
..I $E(APCHP,1,3)=309 S APCH=APCH+1 Q
..I APCHP="301.13" S APCH=APCH+1 Q
..I APCHP=308.3 S APCH=APCH+1 Q
..I APCHP="311." S APCH=APCH+1 Q
..Q
I APCH>1 Q "Yes 2 or more dxs in past year"
Q "No"
DEPSCR(P,BDATE,EDATE) ;EP
NEW X
I $G(P)="" Q ""
K APCH S APCHLAST=""
S Y="APCH("
S X=P_"^LAST DX V79.0;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(APCH(1)) S APCHLAST=$P(APCH(1),U)_U_"Yes V79.0"_" "_$$FMTE^XLFDT($P(APCH(1),U),5)
K APCH
S Y="APCH("
S X=P_"^LAST EXAM 36;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(APCH(1)),$P(APCH(1),U)>$P(APCHLAST,U) S APCHLAST=$P(APCH(1),U)_U_"Yes Exam 36-Dep Screen "_$$FMTE^XLFDT($P(APCH(1),U),5)
K APCH
S Y="APCH("
S X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I '$D(APCH(1)) G BHSCR
S (X,E)=0,%="",T="",D="" F S X=$O(APCH(X)) Q:X'=+X!(D) D
.S T=$P(^AUPNVPED(+$P(APCH(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="DEP-SCR",$P(APCH(X),U)>$P(APCHLAST,U) S APCHLAST=$P(APCH(X),U)_U_"Yes Pt Ed "_T_" "_$$FMTE^XLFDT($P(APCH(X),U),5)
K APCH
BHSCR ;
S APCHRF="",D=0,APCHC="",E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V D
.S APCHRF=$P($G(^AMHREC(V,14)),U,5) I APCHRF]"",$E(APCHRF)'="R",$E(APCHRF)'="U",(9999999-$P(D,"."))>$P(APCHLAST,U) S APCHLAST=(9999999-$P(D,"."))_U_"Yes BH Dep Scr "_$$FMTE^XLFDT((9999999-$P(D,".")),5) Q
.I APCHRF]"" S APCHRF=$$VAL^XBDIQ1(9002011,V,1405)_" on "_$$FMTE^XLFDT((9999999-$P(D,".")),5)
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(APCHC]"") S APCHP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'APCHP
..S APCHP=$P($G(^AMHPROB(APCHP,0)),U)
..I APCHP=14.1,(9999999-$P(D,"."))>$P(APCHLAST,U) S APCHLAST=(9999999-$P(D,"."))_U_"Yes BH 14.1 "_$$FMTE^XLFDT((9999999-$P(D,".")),5) Q
..I '$D(^AMHREDU("AD",V)) Q
..S Y=0 F S Y=$O(^AMHREDU("AD",V,Y)) Q:Y'=+Y D
...S T=$P(^AMHREDU(Y,0),U)
...Q:'T
...Q:'$D(^AUTTEDT(T,0))
...S T=$P(^AUTTEDT(T,0),U,2)
...I T="DEP-SCR",(9999999-$P(D,"."))>$P(APCHLAST,U) S APCHLAST=(9999999-$P(D,"."))_U_"Yes BH PT Ed "_T_" "_$$FMTE^XLFDT((9999999-$P(D,".")),5)
...Q
I APCHLAST]"" Q $P(APCHLAST,U,2,99)
;now check for refusals
S APCHC=$$REFDF^APCHS9B3(P,9999999.15,$O(^AUTTEXAM("B","DEPRESSION SCREENING",0)))
I APCHC]"" S X=$P(APCHC,"DEPRESSION SCREENING ",1)_$P(APCHC,"DEPRESSION SCREENING ",2) Q X
I APCHRF]"" Q APCHRF
Q "No"
APCHS9B1 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
+1 ;;2.0;IHS PCC SUITE;**2,4,5,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;IHS/CMI/LAB patch 3 many changes
+4 ;patch 14 added depression screening
+5 ;patch 14 added loinc code lookups
+6 ;cmi/anch/maw 8/27/2007 code set versioning in DMPN and DEPPL
+7 ;
EP ;EP - called from component
+1 IF '$GET(APCHSPAT)
QUIT
+2 ;IHS/CMI/LAB fixed for slave printing
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !!
SET DIR("A")="DIABETES SUMMARY WILL NOW BE DISPLAYED (^ TO EXIT, RETURN TO CONTINUE)"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET APCHSQIT=1
QUIT
+3 ;NEW X S X="BDMS9B1" X ^%ZOSF("TEST") I $T D ^BDMS9B1 D EOJ Q
+4 DO EP2(APCHSPAT)
W ;write out array
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL APCHQUIT
+3 SET APCHX=0
FOR
SET APCHX=$ORDER(^TMP("APCHS",$JOB,"DCS",APCHX))
IF APCHX'=+APCHX!($DATA(APCHQUIT))
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCHQUIT)
QUIT
+5 WRITE !,^TMP("APCHS",$JOB,"DCS",APCHX)
+6 QUIT
End DoDot:1
+7 IF $DATA(APCHQUIT)
SET APCHSQIT=1
+8 DO EOJ
+9 QUIT
+10 ;
EOJ ;
+1 KILL APCHX,APCHQUIT,APCHY,APCHSDFN,APCHSBEG,APCHSTOB,APCHSUPI,APCHSED,APCHTOBN,APCHTOB,APCHSTEX
+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 APCHQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,APCHSHDR,!
+3 WRITE !,"Diabetes Patient Care Summary - continued"
+4 WRITE !,"Patient: ",$PIECE(^DPT(APCHSPAT,0),U)," HRN: ",$$HRN^AUPNPAT(APCHSPAT,DUZ(2)),!
+5 QUIT
EP2(APCHSDFN) ;PEP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("APCHS",$J,"DCS"
+2 NEW X
SET X="BDMS9B1"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO EP2^BDMS9B1(APCHSDFN)
QUIT
+3 KILL ^TMP("APCHS",$JOB,"DCS")
+4 SET ^TMP("APCHS",$JOB,"DCS",0)=0
+5 IF '$DATA(APCHSCVD)
SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+6 DO SETARRAY
+7 QUIT
SETARRAY ;set up array containing dm care summary
+1 ;CHECK TO SEE IF START1^APCLDF EXISTS
+2 SET X="APCLDF"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+3 SET X="DIABETES PATIENT CARE SUMMARY Report Date: "_$$FMTE^XLFDT(DT)
DO S(X)
+4 SET X="Patient Name: "_$PIECE(^DPT(APCHSDFN,0),U)_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2))
DO S(X)
+5 IF $$DOD^AUPNPAT(APCHSDFN)]""
SET X="DATE OF DEATH: "_$$FMTE^XLFDT($$DOD^AUPNPAT(APCHSDFN))
DO S(X,1)
DO S(" ")
+6 SET X="Age: "_$$AGE^AUPNPAT(APCHSDFN)
SET $EXTRACT(X,15)="Sex: "_$$SEX^AUPNPAT(APCHSDFN)
SET $EXTRACT(X,31)="Date of DM Onset: "_$$DOO(APCHSDFN)
DO S(X)
+7 SET X=""
SET X="Dob: "_$$FMTE^XLFDT($$DOB^AUPNPAT(APCHSDFN))
SET Y=$$DMPN(APCHSDFN)
SET $EXTRACT(X,31)="DM Problem #: "_$SELECT(Y]"":Y,1:"*** NONE RECORDED ***")
DO S(X)
+8 SET X=""
IF '$$NOTREG(APCHSDFN)
SET X="**NOT ON DIABETES REGISTER**"
+9 SET $EXTRACT(X,31)="Designated PCP: "_$$VAL^XBDIQ1(9000001,APCHSDFN,.14)
DO S(X)
+10 DO GETHWB(APCHSDFN)
SET X="Last Height: "_APCHX("HT")_$SELECT(APCHX("HT")]"":" inches",1:"")
SET $EXTRACT(X,31)=APCHX("HTD")
DO S(X)
+11 SET X="Last Weight: "_$SELECT(APCHX("WT")]"":$JUSTIFY(APCHX("WT"),3,0),1:"")_$SELECT(APCHX("WT")]"":" lbs",1:"")
SET $EXTRACT(X,31)=APCHX("WTD")
SET $EXTRACT(X,45)="BMI: "_APCHX("BMI")
DO S(X)
+12 IF APCHX("WC")]""
SET X="Last Waist Circumference: "_APCHX("WC")
SET $EXTRACT(X,31)=APCHX("WCD")
DO S(X)
+13 DO TOBACCO^APCHS9B6
+14 SET X="Tobacco Use: "_$GET(APCHTOB)
DO S(X)
+15 SET X="HTN Diagnosed: "_$$HTN(APCHSDFN)
DO S(X)
+16 SET APCHSBEG=$$FMADD^XLFDT(DT,-(6*30.5))
+17 ;get date of last ACE in last year
SET %=$$ACE^APCHS9B5(APCHSDFN,APCHSBEG)
+18 SET X=""
SET X="ON ACE Inhibitor/ARB in past 6 months: "_%
DO S(X)
+19 KILL APCHSX
SET APCHSBEG=$$FMADD^XLFDT(DT,-365)
SET X="Aspirin Use/Anti-platelet (in past yr): "_$EXTRACT($$ASPIRIN(APCHSDFN,APCHSBEG),1,32)
DO S(X)
+20 SET X=""
SET X=$$ASPREF^APCHS9B5(APCHSDFN)
IF X]""
SET X=" "_X
DO S(X)
+21 SET APCHDEPP=$$DEPPL(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT)
+22 SET APCHDEPS=$$DEPSCR(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT)
+23 SET B=$$BP(APCHSDFN)
+24 SET X="Last 3 BP: "_$PIECE($GET(APCHX(1)),U,2)_" "_$$FMTE^XLFDT($PIECE($GET(APCHX(1)),U))
+25 SET $EXTRACT(X,40)="Is Depression on the Problem List?"
+26 DO S(X)
+27 SET X="(non ER)"
IF $DATA(APCHX(2))
SET $EXTRACT(X,13)=$PIECE(APCHX(2),U,2)_" "_$$FMTE^XLFDT($PIECE(APCHX(2),U))
+28 SET $EXTRACT(X,42)=APCHDEPP
+29 DO S(X)
+30 SET X=""
IF $DATA(APCHX(3))
SET X=""
SET $EXTRACT(X,13)=$PIECE(APCHX(3),U,2)_" "_$$FMTE^XLFDT($PIECE(APCHX(3),U))
+31 IF $EXTRACT(APCHDEPP,1)="N"
SET $EXTRACT(X,40)="If no, Depression Screening in past year?"
+32 DO S(X)
+33 SET X=""
IF $EXTRACT(APCHDEPP,1)="N"
SET $EXTRACT(X,42)=APCHDEPS
+34 DO S(X)
M12 ;
+1 ;determine date range
+2 SET APCHSBEG=$$FMADD^XLFDT(DT,-365)
+3 SET X="In past 12 months:"
DO S(X)
+4 SET X="Diabetic Foot Exam:"
SET $EXTRACT(X,23)=$$DFE^APCHS9B4(APCHSDFN,APCHSBEG)
DO S(X)
+5 SET X="Diabetic Eye Exam:"
SET $EXTRACT(X,23)=$$EYE^APCHS9B4(APCHSDFN,APCHSBEG)
DO S(X)
+6 SET X="Dental Exam:"
SET $EXTRACT(X,23)=$$DENTAL^APCHS9B6(APCHSDFN,APCHSBEG)
DO S(X)
+7 ;S X="Rectal Exam (age>40):",$E(X,27)=$$RECTAL^APCHS9B4(APCHSDFN,APCHSBEG) D S(X)
+8 KILL APCHSTEX,APCHSDAT,APCHX
+9 IF $PIECE(^DPT(APCHSDFN,0),U,2)="F"
Begin DoDot:1
+10 SET X="(Females Only)"
DO S(X)
+11 KILL APCHSTEX,APCHSDAT
+12 ;get date of last pap in pcc/refusal
SET APCHX=$$PAP^APCHS9B4(APCHSDFN)
+13 SET X="Last Pap Smear documented in PCC/WH: "_$$FMTE^XLFDT($PIECE(APCHX,U))
DO S(X)
+14 IF $PIECE(APCHX,U,2)]""
SET X=$PIECE(APCHX,U,2)
DO S(X)
+15 DO PAP^APCHS9B5
+16 SET X=""
SET $EXTRACT(X,17)="WH Cervical TX Need:"
SET $EXTRACT(X,38)=$GET(APCHSTEX(1))
DO S(X)
+17 SET X=""
SET Y=1
FOR
SET Y=$ORDER(APCHSTEX(Y))
IF Y=""
QUIT
SET X=""
SET $EXTRACT(X,12)=APCHSTEX(Y)
DO S(X)
+18 ;S X=" Breast exam:",$E(X,27)=$$BREAST^APCHS9B4(APCHSDFN,APCHSBEG) D S(X)
+19 KILL APCHSTEX,APCHSDAT
DO MAM^APCHS9B5
SET X="Mammogram:"
SET $EXTRACT(X,12)=$$FMTE^XLFDT(APCHSDAT)_" "_$GET(APCHSTEX(1))
DO S(X)
+20 SET X=""
SET Y=1
FOR
SET Y=$ORDER(APCHSTEX(Y))
IF Y=""
QUIT
SET X=""
SET $EXTRACT(X,23)=APCHSTEX(Y)
DO S(X)
End DoDot:1
+21 DO MORE^APCHS9B2
+22 ;IHS/CMI/LAB - X,3 to X,2
SET X=$PIECE(^DPT(APCHSDFN,0),U)
SET $EXTRACT(X,35)="DOB: "_$$DOB^AUPNPAT(APCHSDFN,"S")
SET $EXTRACT(X,55)="Chart #"_$$HRN^AUPNPAT(APCHSDFN,DUZ(2),2)
DO S(X,1)
+23 ;S X="" D S(X,1)
+24 QUIT
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
+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
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXAPI(Y,T,9)
SET I=1
+5 IF I
QUIT "Yes"
+6 NEW APCHX
+7 SET APCHX=""
+8 SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION"
SET E=$$START1^APCLDF(X,"APCHX(")
IF E
GOTO HTNX
IF $DATA(APCHX(3))
SET APCHX="Yes"
+9 IF $GET(APCHX)=""
SET APCHX="No"
HTNX ;
+1 QUIT APCHX
DMPN(P) ;return problem number of lowest DM code
+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
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 SET I=$PIECE(^AUPNPROB(X,0),U)
+7 IF $$ICD^ATXAPI(I,T,9)
Begin DoDot:2
+8 ;S D(+$P(^ICD9(I,0),U))=X cmi/anch/maw 8/27/2007 orig line
+9 ;cmi/anch/maw 8/27/2007 code set versioning
SET D(+$PIECE($$ICDDX^ICDEX(I,,,"I"),U,2))=X
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 SET D=$ORDER(D(""))
+13 IF D=""
QUIT D
+14 ;ien of problem now return problem #
SET X=D(D)
+15 NEW L
SET L=$PIECE(^AUPNPROB(X,0),U,6)
+16 NEW Y
SET Y=$SELECT(L:$PIECE(^AUTTLOC(L,0),U,7),1:"???")_$PIECE(^AUPNPROB(X,0),U,7)
+17 QUIT Y
BP(P) ;last 3 BPs
+1 ;IHS/CMI/LAB - fixed to exclude ER visits for BP's
+2 NEW APCHD,APCHC
+3 KILL APCHX
+4 SET APCHX=""
SET APCHD=""
SET APCHC=0
+5 ;S X=P_"^LAST 3 MEASUREMENTS BP" S E=$$START1^APCLDF(X,"APCHX(") G:E BPX I $D(APCHX(1)) D
+6 SET T=$ORDER(^AUTTMSR("B","BP",""))
+7 FOR
SET APCHD=$ORDER(^AUPNVMSR("AA",P,T,APCHD))
IF APCHD=""!(APCHC=3)
QUIT
Begin DoDot:1
+8 SET M=0
FOR
SET M=$ORDER(^AUPNVMSR("AA",P,T,APCHD,M))
IF M'=+M!(APCHC=3)
QUIT
Begin DoDot:2
+9 SET V=$PIECE($GET(^AUPNVMSR(M,0)),U,3)
IF 'V
QUIT
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 ;entered in error
IF $PIECE($GET(^AUPNVMSR(M,2)),U,1)
QUIT
+12 IF $$CLINIC^APCLV(V,"C")=30
QUIT
+13 SET APCHC=APCHC+1
SET APCHX(APCHC)=(9999999-APCHD)_U_$PIECE(^AUPNVMSR(M,0),U,4)
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF '$DATA(APCHX(1))
SET APCHX(1)="None recorded"
BPX ;
+1 KILL APCHD,APCHC
+2 QUIT APCHX
GETHWB(P) ;get last height, height date, weight, weight date and BMI for patient P, return in APCHX("HT"),APCHX("HTD"),APCHX("WT"),APCHX("WTD"),APCHX("BMI")
+1 KILL APCHX
+2 SET APCHX("HT")=""
SET APCHX("HTD")=""
SET APCHX("WT")=""
SET APCHX("WTD")=""
SET APCHX("BMI")=""
SET APCHX("WC")=""
SET APCHX("WCD")=""
LASTHT ;
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT
+2 IF '$DATA(^AUPNVMSR("AC",P))
QUIT
+3 NEW APCHY
+4 SET %=P_"^LAST MEAS HT"
NEW X
SET E=$$START1^APCLDF(%,"APCHY(")
SET APCHX("HT")=$PIECE($GET(APCHY(1)),U,2)
SET APCHX("HTD")=$$FMTE^XLFDT($PIECE($GET(APCHY(1)),U))
+5 SET APCHX("HT")=$SELECT(APCHX("HT")]"":$JUSTIFY(APCHX("HT"),2,0),1:"")
LASTWT ;
+1 KILL APCHY
SET %=P_"^LAST MEAS WT"
NEW X
SET E=$$START1^APCLDF(%,"APCHY(")
SET APCHX("WT")=$PIECE($GET(APCHY(1)),U,2)
SET APCHX("WTD")=$$FMTE^XLFDT($PIECE($GET(APCHY(1)),U))
LASTWC ;
+1 KILL APCHY
SET %=P_"^LAST MEAS WC"
NEW X
SET E=$$START1^APCLDF(%,"APCHY(")
SET APCHX("WC")=$PIECE($GET(APCHY(1)),U,2)
SET APCHX("WCD")=$$FMTE^XLFDT($PIECE($GET(APCHY(1)),U))
BMI ;
+1 IF $$AGE^AUPNPAT(P)<19
IF (APCHX("WTD")'=APCHX("HTD"))
QUIT
+2 IF APCHX("WT")=""!('APCHX("HT"))
QUIT
+3 SET %=""
+4 ;S W=(APCHX("WT")/5)*2.3,H=(APCHX("HT")*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
+5 SET W=APCHX("WT")*.45359
SET H=(APCHX("HT")*0.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+6 SET APCHX("BMI")=%
+7 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
SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+6 SET T1=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+7 IF 'T
QUIT ""
+8 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+9 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
+10 IF $DATA(^ATXAX(T,21,"B",G))
SET %=V
QUIT
+11 IF T1
IF $DATA(^ATXAX(T1,21,"B",G))
SET %=V
QUIT
End DoDot:2
End DoDot:1
+12 IF %]""
Begin DoDot:1
+13 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01)
QUIT
+14 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01)
QUIT
End DoDot:1
QUIT %
+15 QUIT "No"
DOO(P) ;get earliest date of onset
+1 NEW X,DOO
+2 SET X=$$CMSFDX^APCHS9B4(P,"I")
+3 IF X]""
IF '$DATA(DOO(X))
SET DOO(X)="Diabetes Register"
+4 SET DOO=""
SET X=$$PLDMDOO^APCHS9B4(P,"I")
+5 IF X]""
SET DOO(X)="Problem List"
+6 IF $ORDER(DOO(0))=""
QUIT ""
+7 SET X=$ORDER(DOO(0))
QUIT $$FMTE^XLFDT(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 APCH,X
+2 KILL APCH
+3 SET (G,X,I)=""
+4 ;is depression on the problem list?
+5 SET T=$ORDER(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))
+6 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+8 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
+9 IF '$$ICD^ATXAPI(I,T,9)
QUIT
+10 ;S G="Yes - Problem List "_$P(^ICD9(I,0),U) cmi/anch/maw 8/27/2007 orig line
+11 ;cmi/anch/maw 8/27/2007 code set versioning
SET G="Yes - Problem List "_$PIECE($$ICDDX^ICDEX(I,,"I"),U,2)
+12 QUIT
End DoDot:1
+13 IF G]""
QUIT G
+14 SET (G,X,I)=""
+15 ;is depression on the BH problem list?
+16 SET T=$ORDER(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))
+17 SET X=0
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+18 SET I=$PIECE($GET(^AMHPPROB(X,0)),U)
+19 SET I=$PIECE($GET(^AMHPROB(I,0)),U,5)
+20 IF I=""
QUIT
+21 SET I=+$$IEN^ICDEX(I,80,1)
+22 IF I=""
QUIT
+23 IF '$$ICD^ATXAPI(I,T,9)
QUIT
+24 ;S G="Yes - BH Problem List "_$P(^ICD9(I,0),U) cmi/anch/maw 8/27/2007 orig line
+25 ;cmi/anch/maw 8/27/2007 code set versioning
SET G="Yes - BH Problem List "_$PIECE($$ICDDX^ICDEX(I,,,"I"),U,2)
+26 QUIT
End DoDot:1
+27 IF G]""
QUIT G
+28 ;now check for 2 dxs in past year
+29 SET Y="APCH("
+30 SET X=P_"^LAST 2 DX [DM AUDIT DEPRESSIVE DISORDERS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+31 IF $DATA(APCH(2))
QUIT "Yes 2 or more dxs in past year"
+32 SET APCH=0
SET APCHV=""
IF $DATA(APCH(1))
SET APCH=1
SET APCHV=$PIECE(APCH(1),U,5)
+33 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+34 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+35 ;go through BH record file and find up to 2 visits in date range
+36 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(APCH>1)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(APCH>1)
QUIT
Begin DoDot:1
+37 IF '$DATA(^AMHREC(V,0))
QUIT
+38 ;don't use same visit
IF $PIECE(^AMHREC(V,0),U,16)]""
IF APCHV]""
IF $PIECE(^AMHREC(V,0),U,16)=APCHV
QUIT
+39 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(APCH>1)
QUIT
SET APCHP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+40 IF 'APCHP
QUIT
+41 SET APCHP=$PIECE($GET(^AMHPROB(APCHP,0)),U)
+42 IF APCHP=14
SET APCH=APCH+1
QUIT
+43 IF APCHP=15
SET APCH=APCH+1
QUIT
+44 IF APCHP=18
SET APCH=APCH+1
QUIT
+45 IF APCHP=24
SET APCH=APCH+1
QUIT
+46 IF $EXTRACT(APCHP,1,3)=296
SET APCH=APCH+1
QUIT
+47 IF $EXTRACT(APCHP,1,3)=300
SET APCH=APCH+1
QUIT
+48 IF $EXTRACT(APCHP,1,3)=309
SET APCH=APCH+1
QUIT
+49 IF APCHP="301.13"
SET APCH=APCH+1
QUIT
+50 IF APCHP=308.3
SET APCH=APCH+1
QUIT
+51 IF APCHP="311."
SET APCH=APCH+1
QUIT
+52 QUIT
End DoDot:2
End DoDot:1
+53 IF APCH>1
QUIT "Yes 2 or more dxs in past year"
+54 QUIT "No"
DEPSCR(P,BDATE,EDATE) ;EP
+1 NEW X
+2 IF $GET(P)=""
QUIT ""
+3 KILL APCH
SET APCHLAST=""
+4 SET Y="APCH("
+5 SET X=P_"^LAST DX V79.0;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+6 IF $DATA(APCH(1))
SET APCHLAST=$PIECE(APCH(1),U)_U_"Yes V79.0"_" "_$$FMTE^XLFDT($PIECE(APCH(1),U),5)
+7 KILL APCH
+8 SET Y="APCH("
+9 SET X=P_"^LAST EXAM 36;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+10 IF $DATA(APCH(1))
IF $PIECE(APCH(1),U)>$PIECE(APCHLAST,U)
SET APCHLAST=$PIECE(APCH(1),U)_U_"Yes Exam 36-Dep Screen "_$$FMTE^XLFDT($PIECE(APCH(1),U),5)
+11 KILL APCH
+12 SET Y="APCH("
+13 SET X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+14 IF '$DATA(APCH(1))
GOTO BHSCR
+15 SET (X,E)=0
SET %=""
SET T=""
SET D=""
FOR
SET X=$ORDER(APCH(X))
IF X'=+X!(D)
QUIT
Begin DoDot:1
+16 SET T=$PIECE(^AUPNVPED(+$PIECE(APCH(X),U,4),0),U)
+17 IF 'T
QUIT
+18 IF '$DATA(^AUTTEDT(T,0))
QUIT
+19 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+20 IF T="DEP-SCR"
IF $PIECE(APCH(X),U)>$PIECE(APCHLAST,U)
SET APCHLAST=$PIECE(APCH(X),U)_U_"Yes Pt Ed "_T_" "_$$FMTE^XLFDT($PIECE(APCH(X),U),5)
End DoDot:1
+21 KILL APCH
BHSCR ;
+1 SET APCHRF=""
SET D=0
SET APCHC=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
+2 SET APCHRF=$PIECE($GET(^AMHREC(V,14)),U,5)
IF APCHRF]""
IF $EXTRACT(APCHRF)'="R"
IF $EXTRACT(APCHRF)'="U"
IF (9999999-$PIECE(D,"."))>$PIECE(APCHLAST,U)
SET APCHLAST=(9999999-$PIECE(D,"."))_U_"Yes BH Dep Scr "_$$FMTE^XLFDT((9999999-$PIECE(D,".")),5)
QUIT
+3 IF APCHRF]""
SET APCHRF=$$VAL^XBDIQ1(9002011,V,1405)_" on "_$$FMTE^XLFDT((9999999-$PIECE(D,".")),5)
+4 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(APCHC]"")
QUIT
SET APCHP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+5 IF 'APCHP
QUIT
+6 SET APCHP=$PIECE($GET(^AMHPROB(APCHP,0)),U)
+7 IF APCHP=14.1
IF (9999999-$PIECE(D,"."))>$PIECE(APCHLAST,U)
SET APCHLAST=(9999999-$PIECE(D,"."))_U_"Yes BH 14.1 "_$$FMTE^XLFDT((9999999-$PIECE(D,".")),5)
QUIT
+8 IF '$DATA(^AMHREDU("AD",V))
QUIT
+9 SET Y=0
FOR
SET Y=$ORDER(^AMHREDU("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+10 SET T=$PIECE(^AMHREDU(Y,0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T="DEP-SCR"
IF (9999999-$PIECE(D,"."))>$PIECE(APCHLAST,U)
SET APCHLAST=(9999999-$PIECE(D,"."))_U_"Yes BH PT Ed "_T_" "_$$FMTE^XLFDT((9999999-$PIECE(D,".")),5)
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF APCHLAST]""
QUIT $PIECE(APCHLAST,U,2,99)
+17 ;now check for refusals
+18 SET APCHC=$$REFDF^APCHS9B3(P,9999999.15,$ORDER(^AUTTEXAM("B","DEPRESSION SCREENING",0)))
+19 IF APCHC]""
SET X=$PIECE(APCHC,"DEPRESSION SCREENING ",1)_$PIECE(APCHC,"DEPRESSION SCREENING ",2)
QUIT X
+20 IF APCHRF]""
QUIT APCHRF
+21 QUIT "No"
