YTSF36 ;ALBANY/ASF SF-36 HEALTH SURVEY ;1/12/96 10:33
;;5.01;MENTAL HEALTH;**10,19**;Dec 30, 1994
SCOR ;GET RESPONSES
S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
;ARRAY SET
F I=1:1:36 S YSX(I)=$E(X,I)
RV ;REVERSE SCORE 10 ITEMS
F I=21,22,1,34,36,23,27,20,26,30 I YSX(I)'="X" S YSMX=$P(^YTT(601,YSTEST,"Q",I,0),U,2),YSMX=$E(YSMX,$L(YSMX)-1)+1,YSX(I)=YSMX-YSX(I)
;RECODE 3 ITEMS
S YSX(1)=YSX(1)+$S($E(X,1)=2:.4,$E(X,1)=3:.4,1:0)
S:YSX(21)'="X" YSX(21)=YSX(21)+$S($E(X,21)=2:.4,$E(X,21)=3:.2,$E(X,21)=4:.1,$E(X,21)=5:.2,1:0)
I ($E(X,22)=1)&($E(X,21)=1) S YSX(22)=6
I $E(X,21)="X"&(YSX(22)'="X") S YSX(22)=YSX(22)+$S($E(X,22)=1:1,$E(X,22)=2:.75,$E(X,22)=3:.5,$E(X,22)=4:.25,1:0)
RAWER ;RAW CALCULATIONS
K S S R="" F J=1:1:9 S YSN=0,YSXN=0 D RAW1 D:YSXN>0 MISS
G STND Q
RAW1 S YSKK=^YTT(601,YSTEST,"S",J,"K",1,0)
F I=1:2 S A=$P(YSKK,U,I) Q:A="" D RAW2
Q
RAW2 S $P(R,U,J)=$P(R,U,J)+YSX(A)
I YSX(A)="X" S YSXN=YSXN+1
S YSN=YSN+1
Q
MISS ;MISSING ITEM RECODE BY MEANS
S B=$P("10^4^2^5^4^2^3^5^1",U,J)
I YSXN/B>.5 S $P(R,U,J)="*" Q
S Y=$P(R,U,J)/(YSN-YSXN)
S $P(R,U,J)=$P(R,U,J)+(Y*YSXN)
Q
STND ;
S S="",J=1,P="M"
ST ;
S A=$P(R,U,J) G:A=""!(J=9) REPT
S X=^YTT(601,YSTEST,"S",J,P),S=S_$J((A-$P(X,U)/$P(X,U,2)*100),0,2)_"^",J=J+1 G ST
REPT ;
S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),L1=58-A\2,L2=L1+A+7 S:A<9 A=9
D DTA^YTREPT W !!?(72-$L(X)\2),X,!!!?(A-9\2+L1),"S C A L E",?(L2+1),"RAW 0-100",!
F J=1:1 S YSRS=$P(R,U,J) Q:YSRS="" D
. D:IOST?1"C-".E&($Y>21) SCR Q:YSTOUT!YSUOUT
. W !?L1,$P(^YTT(601,YSTEST,"S",J,0),U,2)
. W ?L2,$S(YSRS="*":" *",1:$J(YSRS,6,2))
. I YSRS="*" W ?(L2+10)," *"
. I $P(^YTT(601,YSTEST,"S",J,0),U,2)="Reported Health Transition" D LS Q
. W ?(L2+10),$J($P(S,U,J),6,2)
W !! F YSZZ=0:1 S YSTXT=$T(TEXT+YSZZ) Q:YSTXT="" W ?7,$P(YSTXT,";;",2),!
S YSNOITEM="ITMS^YTSF36"
Q
;
LS ;
W ?(L2+10),$S(YSRS=1:"Much Better",YSRS=2:"Somewhat Better",YSRS=3:"About the Same",YSRS=4:"Somewhat Worse",YSRS=5:"Much Worse",1:" ")
Q
;
ITMS ;ITEM OUTPUT
W:$Y>5 @IOF D DTA^YTREPT S (YSOUT,YSUOUT)=0,A=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
W !!?15,"Item Responses",!
S K=0 F I=1:1 S K=$O(^YTT(601,YSTEST,"G",K)) Q:K'>0 D ITMS1
Q
ITMS1 S J=0 F I=1:1 S J=$O(^YTT(601,YSTEST,"G",K,1,J)) Q:J'>0 S YSX=^(J,0) D:IOST?1"C-".E&($Y>21) SCR Q:YSOUT!YSUOUT D ITMS2
Q
ITMS2 I YSX?1N.E S YSN=+YSX W !,YSX Q
I (J=1)&(YSX?1U.E) W !!?15,"<<<",YSX,">>>" Q
I YSX?1"^".E W !?5,"Answer= ",$P(YSX,"^",$E(A,YSN)+1) Q
W !,YSX
Q
DONE ;
K YSTY,X,Y,A,B,K,YSKK,YSXN,YSN,YSX,L,L1,L2,M,J,YSIT,YSRS,I,P,YSMX,YSTL,YSTTL,YSTXT,YSZZ
Q
;
SCR ;
N A,B,B1,C,D,E,E1,F,F1,G,G1,H,I,J,J1,J2,J3,J4,K,L,L1,L2,M,N
N N1,N2,N3,N4,P,P0,P1,P3,R,R1,S,S1,T,T1,T2,TT,V,V1,V2,V3
N V4,V5,V6,W,X,X0,X1,X2,X3,X4,X7,X8,X9,Y,Y1,Y2,Z,Z1,Z3
;
F I0=1:1:(IOSL-$Y-2) W !
N DTOUT,DUOUT,DIRUT,X
S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT),YSLFT=$D(DIRUT)
W @IOF Q
;
TEXT ;
;;The numbers for all but the last scale reflect the degree to
;;which the individual has given answers in the direction of
;;good health. The 0-100 column will contain a zero if none
;;of the answers are in the direction of good health, and 100
;;if all the answers are in the direction of good health.
;;The last scale reflects how individuals rate the change in
;;their health over the prior year and ranges from 1 (Much Better)
;;to 5 (Much Worse).
;;
;
EOR ;YTSF36
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSF36 3472 printed Dec 13, 2024@02:19:48 Page 2
YTSF36 ;ALBANY/ASF SF-36 HEALTH SURVEY ;1/12/96 10:33
+1 ;;5.01;MENTAL HEALTH;**10,19**;Dec 30, 1994
SCOR ;GET RESPONSES
+1 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
+2 ;ARRAY SET
+3 FOR I=1:1:36
SET YSX(I)=$EXTRACT(X,I)
RV ;REVERSE SCORE 10 ITEMS
+1 FOR I=21,22,1,34,36,23,27,20,26,30
IF YSX(I)'="X"
SET YSMX=$PIECE(^YTT(601,YSTEST,"Q",I,0),U,2)
SET YSMX=$EXTRACT(YSMX,$LENGTH(YSMX)-1)+1
SET YSX(I)=YSMX-YSX(I)
+2 ;RECODE 3 ITEMS
+3 SET YSX(1)=YSX(1)+$SELECT($EXTRACT(X,1)=2:.4,$EXTRACT(X,1)=3:.4,1:0)
+4 if YSX(21)'="X"
SET YSX(21)=YSX(21)+$SELECT($EXTRACT(X,21)=2:.4,$EXTRACT(X,21)=3:.2,$EXTRACT(X,21)=4:.1,$EXTRACT(X,21)=5:.2,1:0)
+5 IF ($EXTRACT(X,22)=1)&($EXTRACT(X,21)=1)
SET YSX(22)=6
+6 IF $EXTRACT(X,21)="X"&(YSX(22)'="X")
SET YSX(22)=YSX(22)+$SELECT($EXTRACT(X,22)=1:1,$EXTRACT(X,22)=2:.75,$EXTRACT(X,22)=3:.5,$EXTRACT(X,22)=4:.25,1:0)
RAWER ;RAW CALCULATIONS
+1 KILL S
SET R=""
FOR J=1:1:9
SET YSN=0
SET YSXN=0
DO RAW1
if YSXN>0
DO MISS
+2 GOTO STND
QUIT
RAW1 SET YSKK=^YTT(601,YSTEST,"S",J,"K",1,0)
+1 FOR I=1:2
SET A=$PIECE(YSKK,U,I)
if A=""
QUIT
DO RAW2
+2 QUIT
RAW2 SET $PIECE(R,U,J)=$PIECE(R,U,J)+YSX(A)
+1 IF YSX(A)="X"
SET YSXN=YSXN+1
+2 SET YSN=YSN+1
+3 QUIT
MISS ;MISSING ITEM RECODE BY MEANS
+1 SET B=$PIECE("10^4^2^5^4^2^3^5^1",U,J)
+2 IF YSXN/B>.5
SET $PIECE(R,U,J)="*"
QUIT
+3 SET Y=$PIECE(R,U,J)/(YSN-YSXN)
+4 SET $PIECE(R,U,J)=$PIECE(R,U,J)+(Y*YSXN)
+5 QUIT
STND ;
+1 SET S=""
SET J=1
SET P="M"
ST ;
+1 SET A=$PIECE(R,U,J)
if A=""!(J=9)
GOTO REPT
+2 SET X=^YTT(601,YSTEST,"S",J,P)
SET S=S_$JUSTIFY((A-$PIECE(X,U)/$PIECE(X,U,2)*100),0,2)_"^"
SET J=J+1
GOTO ST
REPT ;
+1 SET X=$PIECE(^YTT(601,YSTEST,"P"),U)
SET A=$PIECE(^("P"),U,2)
SET L1=58-A\2
SET L2=L1+A+7
if A<9
SET A=9
+2 DO DTA^YTREPT
WRITE !!?(72-$LENGTH(X)\2),X,!!!?(A-9\2+L1),"S C A L E",?(L2+1),"RAW 0-100",!
+3 FOR J=1:1
SET YSRS=$PIECE(R,U,J)
if YSRS=""
QUIT
Begin DoDot:1
+4 if IOST?1"C-".E&($Y>21)
DO SCR
if YSTOUT!YSUOUT
QUIT
+5 WRITE !?L1,$PIECE(^YTT(601,YSTEST,"S",J,0),U,2)
+6 WRITE ?L2,$SELECT(YSRS="*":" *",1:$JUSTIFY(YSRS,6,2))
+7 IF YSRS="*"
WRITE ?(L2+10)," *"
+8 IF $PIECE(^YTT(601,YSTEST,"S",J,0),U,2)="Reported Health Transition"
DO LS
QUIT
+9 WRITE ?(L2+10),$JUSTIFY($PIECE(S,U,J),6,2)
End DoDot:1
+10 WRITE !!
FOR YSZZ=0:1
SET YSTXT=$TEXT(TEXT+YSZZ)
if YSTXT=""
QUIT
WRITE ?7,$PIECE(YSTXT,";;",2),!
+11 SET YSNOITEM="ITMS^YTSF36"
+12 QUIT
+13 ;
LS ;
+1 WRITE ?(L2+10),$SELECT(YSRS=1:"Much Better",YSRS=2:"Somewhat Better",YSRS=3:"About the Same",YSRS=4:"Somewhat Worse",YSRS=5:"Much Worse",1:" ")
+2 QUIT
+3 ;
ITMS ;ITEM OUTPUT
+1 if $Y>5
WRITE @IOF
DO DTA^YTREPT
SET (YSOUT,YSUOUT)=0
SET A=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
+2 WRITE !!?15,"Item Responses",!
+3 SET K=0
FOR I=1:1
SET K=$ORDER(^YTT(601,YSTEST,"G",K))
if K'>0
QUIT
DO ITMS1
+4 QUIT
ITMS1 SET J=0
FOR I=1:1
SET J=$ORDER(^YTT(601,YSTEST,"G",K,1,J))
if J'>0
QUIT
SET YSX=^(J,0)
if IOST?1"C-".E&($Y>21)
DO SCR
if YSOUT!YSUOUT
QUIT
DO ITMS2
+1 QUIT
ITMS2 IF YSX?1N.E
SET YSN=+YSX
WRITE !,YSX
QUIT
+1 IF (J=1)&(YSX?1U.E)
WRITE !!?15,"<<<",YSX,">>>"
QUIT
+2 IF YSX?1"^".E
WRITE !?5,"Answer= ",$PIECE(YSX,"^",$EXTRACT(A,YSN)+1)
QUIT
+3 WRITE !,YSX
+4 QUIT
DONE ;
+1 KILL YSTY,X,Y,A,B,K,YSKK,YSXN,YSN,YSX,L,L1,L2,M,J,YSIT,YSRS,I,P,YSMX,YSTL,YSTTL,YSTXT,YSZZ
+2 QUIT
+3 ;
SCR ;
+1 NEW A,B,B1,C,D,E,E1,F,F1,G,G1,H,I,J,J1,J2,J3,J4,K,L,L1,L2,M,N
+2 NEW N1,N2,N3,N4,P,P0,P1,P3,R,R1,S,S1,T,T1,T2,TT,V,V1,V2,V3
+3 NEW V4,V5,V6,W,X,X0,X1,X2,X3,X4,X7,X8,X9,Y,Y1,Y2,Z,Z1,Z3
+4 ;
+5 FOR I0=1:1:(IOSL-$Y-2)
WRITE !
+6 NEW DTOUT,DUOUT,DIRUT,X
+7 SET DIR(0)="E"
DO ^DIR
KILL DIR
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(DUOUT)
SET YSLFT=$DATA(DIRUT)
+8 WRITE @IOF
QUIT
+9 ;
TEXT ;
+1 ;;The numbers for all but the last scale reflect the degree to
+2 ;;which the individual has given answers in the direction of
+3 ;;good health. The 0-100 column will contain a zero if none
+4 ;;of the answers are in the direction of good health, and 100
+5 ;;if all the answers are in the direction of good health.
+6 ;;The last scale reflects how individuals rate the change in
+7 ;;their health over the prior year and ranges from 1 (Much Better)
+8 ;;to 5 (Much Worse).
+9 ;;
+10 ;
EOR ;YTSF36
