YTSCL9R ;ALB/ASF-SCL90 R SCORING ; 8/17/10 10:51am
;;5.01;MENTAL HEALTH;**10,96**;Dec 30, 1994;Build 46
;No external references
MAIN ;
D RD
D VALIDITY Q:YSVFLAG
D SS
D GSI,PST,PSDI
D TSCORE
D ^YTSCL9R1 ;graphit
D BOTTOM^YTSCL9R1 ;graph legend
D REPT
D:IOST?1"C-".E SCR^YTREPT Q:YSTOUT!YSUOUT
D NOTE^YTSCL9R1 ;symptoms of note
D END
Q
RD S X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
Q
SS ;symptom scales
S (R,S,S(1),S(2),S(3),YSTOTAL)=""
F YSI=1:1:10 D SS1
Q
SS1 ;
S YSK=^YTT(601,YSTEST,"S",YSI,"K",1,0)
S YSDIV=0,YSMIS=0
F J=1:2 S YSITEM=$P(YSK,U,J) Q:YSITEM="" S:$E(X,YSITEM)="X" YSMIS=YSMIS+1 S:$E(X,YSITEM)'="X" YSDIV=YSDIV+1,$P(R,U,YSI)=$P(R,U,YSI)+$E(X,YSITEM),YSTOTAL=YSTOTAL+$E(X,YSITEM)
;divide by number of non omitted in scale
S:YSDIV>0 $P(R,U,YSI)=$J($P(R,U,YSI)/YSDIV,0,2)
;set tscore to 0 if more than 40% ommitted
I YSMIS/(YSMIS+YSDIV)>.4 S $P(S(1),U,YSI)=0,$P(S(2),U,YSI)=0,$P(S(3),U,YSI)=0
Q
GSI ;global severity index
I YSTOTAL=0 S $P(R,U,11)=$J(0,0,2) Q ;-->out ASF 8/17/2010
S $P(R,U,11)=$J(YSTOTAL/(90-($L(X,"X")-1)),0,2)
Q
PST ;positive symptom total
S $P(R,U,13)=($L(X,4)-1)+($L(X,3)-1)+($L(X,2)-1)+($L(X,1)-1)
Q
PSDI ;positive symptom distress index
I YSTOTAL=0 S $P(R,U,12)=$J(0,0,2) Q ;-->out ASF 8/17/2010
S $P(R,U,12)=$J(YSTOTAL/$P(R,U,13),0,2)
Q
VALIDITY ;
S YSVFLAG=0
I $L(X,"X")>19 W !!,"Administration invalid: More than 18 items were omitted",!! S YSVFLAG=1 Q
I YSAGE<18 W !!,"Norms for this age group not available",!! S YSVFLAG=1 Q
I $L(X,4)=91!($L(X,3)=91)!($L(X,2)=91)!($L(X,1)=91)!($L(X,0)=91) W !!,"Administration invalid: all questions were answered the same",!! S YSVFLAG=1 Q
Q
TSCORE ; 1=outpatient, 2=nonpatients, 3= inpatients
F YSNORM=1,2,3 D TS1,TPST,EXTREME
Q
TS1 F YSI=1:1:9,11,12 D LKUP
Q
LKUP ;
S YSRAW=+$P(R,U,YSI)
S N=0 F S N=$O(^YTT(601,YSTEST,YSSEX,YSNORM,1,N)) Q:N'>0 S YSROW=^(N,0),YSVALUE=+YSROW I YSVALUE=YSRAW!(YSVALUE>YSRAW) D LKUP1 Q
Q
LKUP1 ;
Q:$P(S(YSNORM),U,YSI)=0 ;already taged invalid
S YSLKP=$S(YSI>9:YSI-1,1:YSI)
S YSTNOW=$P(YSROW,U,YSLKP+1)
Q:'+YSTNOW ;its an extreme
I +YSVALUE=+$P(R,U,YSI) S $P(S(YSNORM),U,YSI)=YSTNOW Q
IF YSRAW<YSVALUE D:N>1 TRANS
Q
TRANS ;
Q:N=1
S YSROWP=^YTT(601,YSTEST,YSSEX,YSNORM,1,N-1,0)
S YSVOLD=+YSROWP,YSTOLD=$P(YSROWP,U,YSLKP+1)
Q:'+YSTOLD ;its an extreme
S YST=((YSTNOW-YSTOLD)/(YSVALUE-YSVOLD))*(YSRAW-YSVOLD)+YSTOLD
S $P(S(YSNORM),U,YSI)=$J(YST,0,0)
Q
TPST ; tscores for pst
Q:$P(R,U,13)=0 ;-->out ASF 8/17/10
S YSROW=^YTT(601,YSTEST,YSSEX,4,1,$P(R,U,13),0)
S $P(S(YSNORM),U,13)=$P(YSROW,U,YSNORM+1)
Q
EXTREME ;
F YSI=1:1:9,11,12 D EX1
Q
EX1 ;
Q:$P(S(YSNORM),U,YSI)'=""
S YSRAW=$P(R,U,YSI),X=$S(YSRAW>1.2:2,1:1)
S $P(S(YSNORM),U,YSI)=$P(^YTT(601,YSTEST,YSSEX,YSNORM+4,1,X,0),U,YSI)
Q
REPT ;
S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),B=$P(^("P"),U,3),L1=58-A\2,L2=L1+A+4 S:A<9 A=9
D DTA^YTREPT W !!?(72-$L(X)\2),X,!!!?3,"S C A L E",?37,"RAW Outpatients Nonpatients Inpatients"
F YSI=1:1:9,11,12,13 D REPT1
Q
REPT1 ;
S YSRS=$P(R,U,YSI),S1=$P(S(1),U,YSI),S2=$P(S(2),U,YSI),S3=$P(S(3),U,YSI)
D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
W !?3,$P($P(^YTT(601,YSTEST,"S",YSI,0),U,2),";",2),?37,$S(YSI=13:$J(YSRS,4,0),1:$J(YSRS,4,2)),$J(S1,8,0),$J(S2,13,0),$J(S3,13,0)
W:YSI=9 !!
Q
END K L1,L2,N,R,S,X,S1,S2,S3,YSDIV,YSI,YSITEM,YSK,YSLKP,YSLV,YSMIS,YSNORM,YSNS,YSRAW,YSROW,YSROWP,YSRS,YST,YSTNOW,YSTOLD,YSTOTAL,YSVALUE,YSVFLAG,YSVOLD
Q
MULT ;multiple scoring returns Outpt norms
D ENPT^YSUTL Q:YSAGE<18
D RD
D SS
D GSI,PST,PSDI
D TSCORE
S S=S(1) ;change to 2 or 3 for non and inPt
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSCL9R 3693 printed Oct 16, 2024@18:20:15 Page 2
YTSCL9R ;ALB/ASF-SCL90 R SCORING ; 8/17/10 10:51am
+1 ;;5.01;MENTAL HEALTH;**10,96**;Dec 30, 1994;Build 46
+2 ;No external references
MAIN ;
+1 DO RD
+2 DO VALIDITY
if YSVFLAG
QUIT
+3 DO SS
+4 DO GSI
DO PST
DO PSDI
+5 DO TSCORE
+6 ;graphit
DO ^YTSCL9R1
+7 ;graph legend
DO BOTTOM^YTSCL9R1
+8 DO REPT
+9 if IOST?1"C-".E
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
+10 ;symptoms of note
DO NOTE^YTSCL9R1
+11 DO END
+12 QUIT
RD SET X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
+1 QUIT
SS ;symptom scales
+1 SET (R,S,S(1),S(2),S(3),YSTOTAL)=""
+2 FOR YSI=1:1:10
DO SS1
+3 QUIT
SS1 ;
+1 SET YSK=^YTT(601,YSTEST,"S",YSI,"K",1,0)
+2 SET YSDIV=0
SET YSMIS=0
+3 FOR J=1:2
SET YSITEM=$PIECE(YSK,U,J)
if YSITEM=""
QUIT
if $EXTRACT(X,YSITEM)="X"
SET YSMIS=YSMIS+1
if $EXTRACT(X,YSITEM)'="X"
SET YSDIV=YSDIV+1
SET $PIECE(R,U,YSI)=$PIECE(R,U,YSI)+$EXTRACT(X,YSITEM)
SET YSTOTAL=YSTOTAL+$EXTRACT(X,YSITEM)
+4 ;divide by number of non omitted in scale
+5 if YSDIV>0
SET $PIECE(R,U,YSI)=$JUSTIFY($PIECE(R,U,YSI)/YSDIV,0,2)
+6 ;set tscore to 0 if more than 40% ommitted
+7 IF YSMIS/(YSMIS+YSDIV)>.4
SET $PIECE(S(1),U,YSI)=0
SET $PIECE(S(2),U,YSI)=0
SET $PIECE(S(3),U,YSI)=0
+8 QUIT
GSI ;global severity index
+1 ;-->out ASF 8/17/2010
IF YSTOTAL=0
SET $PIECE(R,U,11)=$JUSTIFY(0,0,2)
QUIT
+2 SET $PIECE(R,U,11)=$JUSTIFY(YSTOTAL/(90-($LENGTH(X,"X")-1)),0,2)
+3 QUIT
PST ;positive symptom total
+1 SET $PIECE(R,U,13)=($LENGTH(X,4)-1)+($LENGTH(X,3)-1)+($LENGTH(X,2)-1)+($LENGTH(X,1)-1)
+2 QUIT
PSDI ;positive symptom distress index
+1 ;-->out ASF 8/17/2010
IF YSTOTAL=0
SET $PIECE(R,U,12)=$JUSTIFY(0,0,2)
QUIT
+2 SET $PIECE(R,U,12)=$JUSTIFY(YSTOTAL/$PIECE(R,U,13),0,2)
+3 QUIT
VALIDITY ;
+1 SET YSVFLAG=0
+2 IF $LENGTH(X,"X")>19
WRITE !!,"Administration invalid: More than 18 items were omitted",!!
SET YSVFLAG=1
QUIT
+3 IF YSAGE<18
WRITE !!,"Norms for this age group not available",!!
SET YSVFLAG=1
QUIT
+4 IF $LENGTH(X,4)=91!($LENGTH(X,3)=91)!($LENGTH(X,2)=91)!($LENGTH(X,1)=91)!($LENGTH(X,0)=91)
WRITE !!,"Administration invalid: all questions were answered the same",!!
SET YSVFLAG=1
QUIT
+5 QUIT
TSCORE ; 1=outpatient, 2=nonpatients, 3= inpatients
+1 FOR YSNORM=1,2,3
DO TS1
DO TPST
DO EXTREME
+2 QUIT
TS1 FOR YSI=1:1:9,11,12
DO LKUP
+1 QUIT
LKUP ;
+1 SET YSRAW=+$PIECE(R,U,YSI)
+2 SET N=0
FOR
SET N=$ORDER(^YTT(601,YSTEST,YSSEX,YSNORM,1,N))
if N'>0
QUIT
SET YSROW=^(N,0)
SET YSVALUE=+YSROW
IF YSVALUE=YSRAW!(YSVALUE>YSRAW)
DO LKUP1
QUIT
+3 QUIT
LKUP1 ;
+1 ;already taged invalid
if $PIECE(S(YSNORM),U,YSI)=0
QUIT
+2 SET YSLKP=$SELECT(YSI>9:YSI-1,1:YSI)
+3 SET YSTNOW=$PIECE(YSROW,U,YSLKP+1)
+4 ;its an extreme
if '+YSTNOW
QUIT
+5 IF +YSVALUE=+$PIECE(R,U,YSI)
SET $PIECE(S(YSNORM),U,YSI)=YSTNOW
QUIT
+6 IF YSRAW<YSVALUE
if N>1
DO TRANS
+7 QUIT
TRANS ;
+1 if N=1
QUIT
+2 SET YSROWP=^YTT(601,YSTEST,YSSEX,YSNORM,1,N-1,0)
+3 SET YSVOLD=+YSROWP
SET YSTOLD=$PIECE(YSROWP,U,YSLKP+1)
+4 ;its an extreme
if '+YSTOLD
QUIT
+5 SET YST=((YSTNOW-YSTOLD)/(YSVALUE-YSVOLD))*(YSRAW-YSVOLD)+YSTOLD
+6 SET $PIECE(S(YSNORM),U,YSI)=$JUSTIFY(YST,0,0)
+7 QUIT
TPST ; tscores for pst
+1 ;-->out ASF 8/17/10
if $PIECE(R,U,13)=0
QUIT
+2 SET YSROW=^YTT(601,YSTEST,YSSEX,4,1,$PIECE(R,U,13),0)
+3 SET $PIECE(S(YSNORM),U,13)=$PIECE(YSROW,U,YSNORM+1)
+4 QUIT
EXTREME ;
+1 FOR YSI=1:1:9,11,12
DO EX1
+2 QUIT
EX1 ;
+1 if $PIECE(S(YSNORM),U,YSI)'=""
QUIT
+2 SET YSRAW=$PIECE(R,U,YSI)
SET X=$SELECT(YSRAW>1.2:2,1:1)
+3 SET $PIECE(S(YSNORM),U,YSI)=$PIECE(^YTT(601,YSTEST,YSSEX,YSNORM+4,1,X,0),U,YSI)
+4 QUIT
REPT ;
+1 SET X=$PIECE(^YTT(601,YSTEST,"P"),U)
SET A=$PIECE(^("P"),U,2)
SET B=$PIECE(^("P"),U,3)
SET L1=58-A\2
SET L2=L1+A+4
if A<9
SET A=9
+2 DO DTA^YTREPT
WRITE !!?(72-$LENGTH(X)\2),X,!!!?3,"S C A L E",?37,"RAW Outpatients Nonpatients Inpatients"
+3 FOR YSI=1:1:9,11,12,13
DO REPT1
+4 QUIT
REPT1 ;
+1 SET YSRS=$PIECE(R,U,YSI)
SET S1=$PIECE(S(1),U,YSI)
SET S2=$PIECE(S(2),U,YSI)
SET S3=$PIECE(S(3),U,YSI)
+2 if IOST?1"C-".E&($Y>21)
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
+3 WRITE !?3,$PIECE($PIECE(^YTT(601,YSTEST,"S",YSI,0),U,2),";",2),?37,$SELECT(YSI=13:$JUSTIFY(YSRS,4,0),1:$JUSTIFY(YSRS,4,2)),$JUSTIFY(S1,8,0),$JUSTIFY(S2,13,0),$JUSTIFY(S3,13,0)
+4 if YSI=9
WRITE !!
+5 QUIT
END KILL L1,L2,N,R,S,X,S1,S2,S3,YSDIV,YSI,YSITEM,YSK,YSLKP,YSLV,YSMIS,YSNORM,YSNS,YSRAW,YSROW,YSROWP,YSRS,YST,YSTNOW,YSTOLD,YSTOTAL,YSVALUE,YSVFLAG,YSVOLD
+1 QUIT
MULT ;multiple scoring returns Outpt norms
+1 DO ENPT^YSUTL
if YSAGE<18
QUIT
+2 DO RD
+3 DO SS
+4 DO GSI
DO PST
DO PSDI
+5 DO TSCORE
+6 ;change to 2 or 3 for non and inPt
SET S=S(1)
+7 QUIT
