YTCESD ;ALB/ASF- CESD DEPRESSION SCALE ;7/17/03 10:20
;;5.01;MENTAL HEALTH;**70**;Dec 30, 1994
;
N I,X,N,YSLFT,YSOUT,YTOUT,YSNX
S YSNOITEM="DONE^YTREPT"
S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
S R=0,S=""
F I=1,2,3,5,6,7,9,10,11,13,14,15,17,18,19,20 S R=R+$E(X,I)
F I=4,8,12,16 S:($E(X,I)'="X") R=R+(3-$E(X,I))
S YSNX=$L(X,"X")-1
Q:YSTY'["*"
D DTA^YTREPT
W !!?10,$P(^YTT(601,YSET,"P"),U)
W !!,"CES-D score= ",R," A score of 16 or more is considered depressed."
W:YSNX>3 !!,"Screen invalid: ",YSNX," missing items"
W !
F I=1:1:20 D
. D:$Y+4>IOSL WAIT
. W !?3,$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),I)
. I (I=4)!(I=8)!(I=12)!(I=16) W "-"
. W ?6,^YTT(601,YSET,"Q",I,"T",1,0)
. W:I=3 "..."
W !!,"0= less than a day 1= 1-2 days 2= 3-4 days 3= 5-7 days"
D:$Y+4>IOSL WAIT
DONE Q
CESD5 ;5 item screen
N I,X,N,YSLFT,YSOUT,YTOUT,YSNX
S YSNOITEM="DONE^YTREPT"
S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
S R=0,S=""
F I=1,2,3,4 S R=R+$E(X,I)
S:($E(X,5)'="X") R=R+(3-$E(X,5))
Q:YSTY'["*"
D DTA^YTREPT
W !!?10,$P(^YTT(601,YSET,"P"),U)
W !!,"CES-D5 score= ",R," A score of 4 or more is a positive depression screen."
W !
F I=1:1:5 D
. D:$Y+4>IOSL WAIT
. W !?3,$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),I)
. I (I=5) W "-"
. W ?6,$E(^YTT(601,YSET,"Q",I,"T",1,0),1,45)
. W:I=1 " ..."
W !!,"0= less than a day 1= 1-2 days 2= 3-4 days 3= 5-7 days"
D:$Y+4>IOSL WAIT
Q
WAIT ;
; Added 5/6/94 LJA
;
F I0=1:1:(IOSL-$Y-2) W !
N DTOUT,DUOUT,DIRUT
S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT),YSLFT=$D(DIRUT)
W @IOF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTCESD 1603 printed Dec 13, 2024@02:17:06 Page 2
YTCESD ;ALB/ASF- CESD DEPRESSION SCALE ;7/17/03 10:20
+1 ;;5.01;MENTAL HEALTH;**70**;Dec 30, 1994
+2 ;
+3 NEW I,X,N,YSLFT,YSOUT,YTOUT,YSNX
+4 SET YSNOITEM="DONE^YTREPT"
+5 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
+6 SET R=0
SET S=""
+7 FOR I=1,2,3,5,6,7,9,10,11,13,14,15,17,18,19,20
SET R=R+$EXTRACT(X,I)
+8 FOR I=4,8,12,16
if ($EXTRACT(X,I)'="X")
SET R=R+(3-$EXTRACT(X,I))
+9 SET YSNX=$LENGTH(X,"X")-1
+10 if YSTY'["*"
QUIT
+11 DO DTA^YTREPT
+12 WRITE !!?10,$PIECE(^YTT(601,YSET,"P"),U)
+13 WRITE !!,"CES-D score= ",R," A score of 16 or more is considered depressed."
+14 if YSNX>3
WRITE !!,"Screen invalid: ",YSNX," missing items"
+15 WRITE !
+16 FOR I=1:1:20
Begin DoDot:1
+17 if $Y+4>IOSL
DO WAIT
+18 WRITE !?3,$EXTRACT(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),I)
+19 IF (I=4)!(I=8)!(I=12)!(I=16)
WRITE "-"
+20 WRITE ?6,^YTT(601,YSET,"Q",I,"T",1,0)
+21 if I=3
WRITE "..."
End DoDot:1
+22 WRITE !!,"0= less than a day 1= 1-2 days 2= 3-4 days 3= 5-7 days"
+23 if $Y+4>IOSL
DO WAIT
DONE QUIT
CESD5 ;5 item screen
+1 NEW I,X,N,YSLFT,YSOUT,YTOUT,YSNX
+2 SET YSNOITEM="DONE^YTREPT"
+3 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
+4 SET R=0
SET S=""
+5 FOR I=1,2,3,4
SET R=R+$EXTRACT(X,I)
+6 if ($EXTRACT(X,5)'="X")
SET R=R+(3-$EXTRACT(X,5))
+7 if YSTY'["*"
QUIT
+8 DO DTA^YTREPT
+9 WRITE !!?10,$PIECE(^YTT(601,YSET,"P"),U)
+10 WRITE !!,"CES-D5 score= ",R," A score of 4 or more is a positive depression screen."
+11 WRITE !
+12 FOR I=1:1:5
Begin DoDot:1
+13 if $Y+4>IOSL
DO WAIT
+14 WRITE !?3,$EXTRACT(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),I)
+15 IF (I=5)
WRITE "-"
+16 WRITE ?6,$EXTRACT(^YTT(601,YSET,"Q",I,"T",1,0),1,45)
+17 if I=1
WRITE " ..."
End DoDot:1
+18 WRITE !!,"0= less than a day 1= 1-2 days 2= 3-4 days 3= 5-7 days"
+19 if $Y+4>IOSL
DO WAIT
+20 QUIT
WAIT ;
+1 ; Added 5/6/94 LJA
+2 ;
+3 FOR I0=1:1:(IOSL-$Y-2)
WRITE !
+4 NEW DTOUT,DUOUT,DIRUT
+5 SET DIR(0)="E"
DO ^DIR
KILL DIR
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(DUOUT)
SET YSLFT=$DATA(DIRUT)
+6 WRITE @IOF
QUIT
