YTSMPIR ;SLC/KCM - Score MMPI-2-RF ; 10/24/2015
;;5.01;MENTAL HEALTH;**123**;Dec 30, 1994;Build 73
;
SCORE(RSLT,ADMIN) ; Score instrument
; build tables if necessary
; build responses
; scan for overall results
; compute raw score for each scale
; compute adjusted scores, if necessary
; get T-scores for each scale
Q
SCAN(CNT,RSP) ; scan for overall statistics
N I
S CNT("trueCount")=0
S CNT("cannotSay")=0
S CNT("skipped")=""
S CNT("responses")=""
S I=0 F S I=$O(RSP(I)) Q:'I D
.I RSP(I)="T" S CNT("trueCount")=CNT("trueCount")+1
.I RSP(I)="" D
..S CNT("cannotSay")=CNT("cannotSay")+1
..S CNT("skipped")=CNT("skipped")_I_", "
;S CNT("trueCount")=CNT("trueCount")/(338-CNT("cannotSay")*100)
S CNT("trueCount")=$J((CNT("trueCount")/(338-CNT("cannotSay"))*100),0,0)
Q
;
; compute scores ---------------------------------------------------
SCORE1(RSLT,SCALE,RSP) ; set .RSLT subscripts for SCALE
; expects T (scoring tables)
; .RSLT: subscripts - raw,adjusted,count,percent,tscore
; SCALE: scale to calculate
; .RSP: set of responses -- RSP(q#)=answer
K RSLT
S RSLT("raw")=0,RSLT("count")=0
I SCALE="VRIN-r" D VRIN(.RSLT,.RSP) Q
I SCALE="TRIN-r" D TRIN(.RSLT,.RSP) Q
; all others
N QID
S QID=0 F S QID=$O(T("raw",SCALE,QID)) Q:'$L(QID) D
.I RSP(QID)=$P(T("raw",SCALE,QID),U,2) D INC(SCALE,"raw")
.I RSP(QID)'="" D INC(SCALE,"count")
D PERCENT(.RSLT,SCALE)
; compute adjusted raw score if response rate <90%
I T("info",SCALE,"adjust"),(RSLT("percent")<90) D RAWADJ(.RSLT,SCALE,.RSP)
D TSCORE(.RSLT,SCALE)
;set into array to save score
D SETSCORE(.SCR,.RSLT,SCALE)
Q
VRIN(RSLT,RSP) ; VRIN-r raw,count,percent,t-score
N QID,Q1,Q2,K1,K2,X
S QID=0 F S QID=$O(T("raw","VRIN-r",QID)) Q:'$L(QID) D
. S X=T("raw","VRIN-r",QID)
. S Q1=$P(X,U),K1=$P(X,U,2),Q2=$P(X,U,3),K2=$P(X,U,4)
. I RSP(Q1)=K1,(RSP(Q2)=K2) D INC(SCALE,"raw")
. I $P(T("raw","VRIN-r",QID),U,6)="B" Q ; pair, only count once
. I (RSP(Q1)="")!(RSP(Q2)="") Q ; only count if both present
. D INC(SCALE,"count")
D PERCENT(.RSLT,"VRIN-r")
; compute adjusted raw score if response rate <90%
I RSLT("percent")<90 D VRINADJ(.RSLT,.RSP)
D TSCORE(.RSLT,"VRIN-r")
;set into array to save score
D SETSCORE(.SCR,.RSLT,SCALE)
Q
TRIN(RSLT,RSP) ; TRIN-r raw,count,percent,t-score
N QID,Q1,Q2,K1,K1,DIFF,X
S QID=0 F S QID=$O(T("raw","TRIN-r",QID)) Q:'$L(QID) D
. S X=T("raw","TRIN-r",QID)
. S Q1=$P(X,U),K1=$P(X,U,2),Q2=$P(X,U,3),K2=$P(X,U,4)
. S DIFF=$S($P(X,U,5)="-":-1,1:1)
. I RSP(Q1)=K1,(RSP(Q2)=K2) D INC(SCALE,"raw",DIFF)
. Q:RSP(Q1)="" Q:RSP(Q2)="" D INC(SCALE,"count")
D INC(SCALE,"raw",11)
D PERCENT(.RSLT,"TRIN-r")
; compute adjusted raw score if response rate <90%
I RSLT("percent")<90,(RSLT("raw")'=11) D TRINADJ(.RSLT,.RSP)
D TSCORE(.RSLT,"TRIN-r")
;set into array to save score
D SETSCORE(.SCR,.RSLT,SCALE)
Q
TSCORE(RSLT,SCALE) ; add T-Score to .RSLT
N RAW
S RAW=$S($D(RSLT("adjraw")):RSLT("adjraw"),1:RSLT("raw"))
I $D(T("tscore",SCALE,RAW)) S RSLT("tscore")=T("tscore",SCALE,RAW) I 1
E S RSLT("tscore")=T("tscore",SCALE,"default")
Q
;
; compute adjusted scores (validity scales < 90% response) ---------
VRINADJ(RSLT,RSP) ; VRIN-r adjusted raw score
N QID,Q1,Q2,K1,K2,R1,R2,X
S RSLT("adjraw")=0
S QID=0 F S QID=$O(T("raw","VRIN-r",QID)) Q:'$L(QID) D
.S X=T("raw","VRIN-r",QID)
.S Q1=$P(X,U),K1=$P(X,U,2),Q2=$P(X,U,3),K2=$P(X,U,4)
.S R1=RSP(Q1),R2=RSP(Q2)
.I R1'="",(R2'="") D Q ; if nothing omitted, use original method
..I R1=K1,(R2=K2) D INC(SCALE,"adjraw")
.Q:$P(X,U,6)="S" ; skip "mate" in pair
.I $P(X,U,6)="B" D Q ; if both shared, omit either increments score
..I R1=""!(R2="") D INC(SCALE,"adjraw")
.I $P(X,U,6)="C" D Q ; if pair shares one common item
..N QA,QB,QC,KB,KC,RA,RB,RC
..S QA=$P(X,U,7),QB=$P(X,U,8),QC=$P(X,U,10),KB=$P(X,U,9),KC=$P(X,U,11)
..S RA=RSP(QA),RB=RSP(QB),RC=RSP(QC)
..I ((RA="")&((RB=KB)!(RB="")!(RC=KC)!(RC="")))!((RB="")&(RC="")) D INC(SCALE,"adjraw")
.I $P(X,U,6)="" D ; otherwise, set missing item to key
..S:R1="" R1=K1 S:R2="" R2=K2
.. I R1=K1,(R2=K2) D INC(SCALE,"adjraw")
Q
TRINADJ(RSLT,RSP) ; TRIN-r adjusted raw score
N QID,Q1,Q2,K1,K2,R1,R2,DIFF,X
N DFLT S DFLT=$S(RSLT("raw")<11:"F",1:"T")
S RSLT("adjraw")=11
S QID=0 F S QID=$O(T("raw","TRIN-r",QID)) Q:'$L(QID) D
.S X=T("raw","TRIN-r",QID)
.S Q1=$P(X,U),K1=$P(X,U,2),Q2=$P(X,U,3),K2=$P(X,U,4)
.S DIFF=$S($P(X,U,5)="-":-1,1:1)
.S R1=RSP(Q1),R2=RSP(Q2)
.S:R1="" R1=DFLT S:R2="" R2=DFLT
.I R1=K1,(R2=K2) D INC(SCALE,"adjraw",DIFF)
Q
RAWADJ(RSLT,SCALE,RSP) ; general case adjusted raw score
N R
S RSLT("adjraw")=0
S QID=0 F S QID=$O(T("raw",SCALE,QID)) Q:'$L(QID) D
.S R=RSP(QID) S:R="" R=$P(T("raw",SCALE,QID),U,2)
.I R=$P(T("raw",SCALE,QID),U,2) D INC(SCALE,"adjraw")
Q
;
; utility calls ----------------------------------------------------
PERCENT(RSLT,SCALE) ; compute percent and put back in .RSLT
; expects T (scoring tables)
S RSLT("percent")=$P((RSLT("count")/T("info",SCALE,"count")*100)+.5,".")
Q
INC(SCALE,SUB,VAL) ; increment (or decrement) subscript SUB by value VAL
S VAL=$G(VAL,1)
S RSLT(SUB)=RSLT(SUB)+VAL
Q
SETSCORE(SCR,RSLT,SCALE) ;
S SCR(SCALE)=RSLT("raw")_U_RSLT("tscore")_U_RSLT("percent")_U_RSLT("count")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSMPIR 5404 printed Nov 22, 2024@17:30:23 Page 2
YTSMPIR ;SLC/KCM - Score MMPI-2-RF ; 10/24/2015
+1 ;;5.01;MENTAL HEALTH;**123**;Dec 30, 1994;Build 73
+2 ;
SCORE(RSLT,ADMIN) ; Score instrument
+1 ; build tables if necessary
+2 ; build responses
+3 ; scan for overall results
+4 ; compute raw score for each scale
+5 ; compute adjusted scores, if necessary
+6 ; get T-scores for each scale
+7 QUIT
SCAN(CNT,RSP) ; scan for overall statistics
+1 NEW I
+2 SET CNT("trueCount")=0
+3 SET CNT("cannotSay")=0
+4 SET CNT("skipped")=""
+5 SET CNT("responses")=""
+6 SET I=0
FOR
SET I=$ORDER(RSP(I))
if 'I
QUIT
Begin DoDot:1
+7 IF RSP(I)="T"
SET CNT("trueCount")=CNT("trueCount")+1
+8 IF RSP(I)=""
Begin DoDot:2
+9 SET CNT("cannotSay")=CNT("cannotSay")+1
+10 SET CNT("skipped")=CNT("skipped")_I_", "
End DoDot:2
End DoDot:1
+11 ;S CNT("trueCount")=CNT("trueCount")/(338-CNT("cannotSay")*100)
+12 SET CNT("trueCount")=$JUSTIFY((CNT("trueCount")/(338-CNT("cannotSay"))*100),0,0)
+13 QUIT
+14 ;
+15 ; compute scores ---------------------------------------------------
SCORE1(RSLT,SCALE,RSP) ; set .RSLT subscripts for SCALE
+1 ; expects T (scoring tables)
+2 ; .RSLT: subscripts - raw,adjusted,count,percent,tscore
+3 ; SCALE: scale to calculate
+4 ; .RSP: set of responses -- RSP(q#)=answer
+5 KILL RSLT
+6 SET RSLT("raw")=0
SET RSLT("count")=0
+7 IF SCALE="VRIN-r"
DO VRIN(.RSLT,.RSP)
QUIT
+8 IF SCALE="TRIN-r"
DO TRIN(.RSLT,.RSP)
QUIT
+9 ; all others
+10 NEW QID
+11 SET QID=0
FOR
SET QID=$ORDER(T("raw",SCALE,QID))
if '$LENGTH(QID)
QUIT
Begin DoDot:1
+12 IF RSP(QID)=$PIECE(T("raw",SCALE,QID),U,2)
DO INC(SCALE,"raw")
+13 IF RSP(QID)'=""
DO INC(SCALE,"count")
End DoDot:1
+14 DO PERCENT(.RSLT,SCALE)
+15 ; compute adjusted raw score if response rate <90%
+16 IF T("info",SCALE,"adjust")
IF (RSLT("percent")<90)
DO RAWADJ(.RSLT,SCALE,.RSP)
+17 DO TSCORE(.RSLT,SCALE)
+18 ;set into array to save score
+19 DO SETSCORE(.SCR,.RSLT,SCALE)
+20 QUIT
VRIN(RSLT,RSP) ; VRIN-r raw,count,percent,t-score
+1 NEW QID,Q1,Q2,K1,K2,X
+2 SET QID=0
FOR
SET QID=$ORDER(T("raw","VRIN-r",QID))
if '$LENGTH(QID)
QUIT
Begin DoDot:1
+3 SET X=T("raw","VRIN-r",QID)
+4 SET Q1=$PIECE(X,U)
SET K1=$PIECE(X,U,2)
SET Q2=$PIECE(X,U,3)
SET K2=$PIECE(X,U,4)
+5 IF RSP(Q1)=K1
IF (RSP(Q2)=K2)
DO INC(SCALE,"raw")
+6 ; pair, only count once
IF $PIECE(T("raw","VRIN-r",QID),U,6)="B"
QUIT
+7 ; only count if both present
IF (RSP(Q1)="")!(RSP(Q2)="")
QUIT
+8 DO INC(SCALE,"count")
End DoDot:1
+9 DO PERCENT(.RSLT,"VRIN-r")
+10 ; compute adjusted raw score if response rate <90%
+11 IF RSLT("percent")<90
DO VRINADJ(.RSLT,.RSP)
+12 DO TSCORE(.RSLT,"VRIN-r")
+13 ;set into array to save score
+14 DO SETSCORE(.SCR,.RSLT,SCALE)
+15 QUIT
TRIN(RSLT,RSP) ; TRIN-r raw,count,percent,t-score
+1 NEW QID,Q1,Q2,K1,K1,DIFF,X
+2 SET QID=0
FOR
SET QID=$ORDER(T("raw","TRIN-r",QID))
if '$LENGTH(QID)
QUIT
Begin DoDot:1
+3 SET X=T("raw","TRIN-r",QID)
+4 SET Q1=$PIECE(X,U)
SET K1=$PIECE(X,U,2)
SET Q2=$PIECE(X,U,3)
SET K2=$PIECE(X,U,4)
+5 SET DIFF=$SELECT($PIECE(X,U,5)="-":-1,1:1)
+6 IF RSP(Q1)=K1
IF (RSP(Q2)=K2)
DO INC(SCALE,"raw",DIFF)
+7 if RSP(Q1)=""
QUIT
if RSP(Q2)=""
QUIT
DO INC(SCALE,"count")
End DoDot:1
+8 DO INC(SCALE,"raw",11)
+9 DO PERCENT(.RSLT,"TRIN-r")
+10 ; compute adjusted raw score if response rate <90%
+11 IF RSLT("percent")<90
IF (RSLT("raw")'=11)
DO TRINADJ(.RSLT,.RSP)
+12 DO TSCORE(.RSLT,"TRIN-r")
+13 ;set into array to save score
+14 DO SETSCORE(.SCR,.RSLT,SCALE)
+15 QUIT
TSCORE(RSLT,SCALE) ; add T-Score to .RSLT
+1 NEW RAW
+2 SET RAW=$SELECT($DATA(RSLT("adjraw")):RSLT("adjraw"),1:RSLT("raw"))
+3 IF $DATA(T("tscore",SCALE,RAW))
SET RSLT("tscore")=T("tscore",SCALE,RAW)
IF 1
+4 IF '$TEST
SET RSLT("tscore")=T("tscore",SCALE,"default")
+5 QUIT
+6 ;
+7 ; compute adjusted scores (validity scales < 90% response) ---------
VRINADJ(RSLT,RSP) ; VRIN-r adjusted raw score
+1 NEW QID,Q1,Q2,K1,K2,R1,R2,X
+2 SET RSLT("adjraw")=0
+3 SET QID=0
FOR
SET QID=$ORDER(T("raw","VRIN-r",QID))
if '$LENGTH(QID)
QUIT
Begin DoDot:1
+4 SET X=T("raw","VRIN-r",QID)
+5 SET Q1=$PIECE(X,U)
SET K1=$PIECE(X,U,2)
SET Q2=$PIECE(X,U,3)
SET K2=$PIECE(X,U,4)
+6 SET R1=RSP(Q1)
SET R2=RSP(Q2)
+7 ; if nothing omitted, use original method
IF R1'=""
IF (R2'="")
Begin DoDot:2
+8 IF R1=K1
IF (R2=K2)
DO INC(SCALE,"adjraw")
End DoDot:2
QUIT
+9 ; skip "mate" in pair
if $PIECE(X,U,6)="S"
QUIT
+10 ; if both shared, omit either increments score
IF $PIECE(X,U,6)="B"
Begin DoDot:2
+11 IF R1=""!(R2="")
DO INC(SCALE,"adjraw")
End DoDot:2
QUIT
+12 ; if pair shares one common item
IF $PIECE(X,U,6)="C"
Begin DoDot:2
+13 NEW QA,QB,QC,KB,KC,RA,RB,RC
+14 SET QA=$PIECE(X,U,7)
SET QB=$PIECE(X,U,8)
SET QC=$PIECE(X,U,10)
SET KB=$PIECE(X,U,9)
SET KC=$PIECE(X,U,11)
+15 SET RA=RSP(QA)
SET RB=RSP(QB)
SET RC=RSP(QC)
+16 IF ((RA="")&((RB=KB)!(RB="")!(RC=KC)!(RC="")))!((RB="")&(RC=""))
DO INC(SCALE,"adjraw")
End DoDot:2
QUIT
+17 ; otherwise, set missing item to key
IF $PIECE(X,U,6)=""
Begin DoDot:2
+18 if R1=""
SET R1=K1
if R2=""
SET R2=K2
+19 IF R1=K1
IF (R2=K2)
DO INC(SCALE,"adjraw")
End DoDot:2
End DoDot:1
+20 QUIT
TRINADJ(RSLT,RSP) ; TRIN-r adjusted raw score
+1 NEW QID,Q1,Q2,K1,K2,R1,R2,DIFF,X
+2 NEW DFLT
SET DFLT=$SELECT(RSLT("raw")<11:"F",1:"T")
+3 SET RSLT("adjraw")=11
+4 SET QID=0
FOR
SET QID=$ORDER(T("raw","TRIN-r",QID))
if '$LENGTH(QID)
QUIT
Begin DoDot:1
+5 SET X=T("raw","TRIN-r",QID)
+6 SET Q1=$PIECE(X,U)
SET K1=$PIECE(X,U,2)
SET Q2=$PIECE(X,U,3)
SET K2=$PIECE(X,U,4)
+7 SET DIFF=$SELECT($PIECE(X,U,5)="-":-1,1:1)
+8 SET R1=RSP(Q1)
SET R2=RSP(Q2)
+9 if R1=""
SET R1=DFLT
if R2=""
SET R2=DFLT
+10 IF R1=K1
IF (R2=K2)
DO INC(SCALE,"adjraw",DIFF)
End DoDot:1
+11 QUIT
RAWADJ(RSLT,SCALE,RSP) ; general case adjusted raw score
+1 NEW R
+2 SET RSLT("adjraw")=0
+3 SET QID=0
FOR
SET QID=$ORDER(T("raw",SCALE,QID))
if '$LENGTH(QID)
QUIT
Begin DoDot:1
+4 SET R=RSP(QID)
if R=""
SET R=$PIECE(T("raw",SCALE,QID),U,2)
+5 IF R=$PIECE(T("raw",SCALE,QID),U,2)
DO INC(SCALE,"adjraw")
End DoDot:1
+6 QUIT
+7 ;
+8 ; utility calls ----------------------------------------------------
PERCENT(RSLT,SCALE) ; compute percent and put back in .RSLT
+1 ; expects T (scoring tables)
+2 SET RSLT("percent")=$PIECE((RSLT("count")/T("info",SCALE,"count")*100)+.5,".")
+3 QUIT
INC(SCALE,SUB,VAL) ; increment (or decrement) subscript SUB by value VAL
+1 SET VAL=$GET(VAL,1)
+2 SET RSLT(SUB)=RSLT(SUB)+VAL
+3 QUIT
SETSCORE(SCR,RSLT,SCALE) ;
+1 SET SCR(SCALE)=RSLT("raw")_U_RSLT("tscore")_U_RSLT("percent")_U_RSLT("count")
+2 QUIT
