YTSMPI2V ;SLC/PIJ - Score MMPI-2-RF ; 01/08/2016
;;5.01;MENTAL HEALTH;**123**;DEC 30,1994;Build 73
;
;Public, Supported ICRs
; #2056 - Fileman API - $$GET1^DIQ
;
Q
; MMPI-2-RF VALIDITY SCALES
;
;Scale^RawScore^TScore^CountofAnsweredQuestiona
SETSCR ;
;TScores --- From TSARR array, piece 3
N SCALE,TS
F SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r" D
.S TS=$P(TSARR(SCALE),U,3)
.I SCALE="VRIN" S V=TS
.I SCALE="TRIN" S T=TS
.I SCALE="F-r" S F=TS
.I SCALE="Fp-r" S FP=TS
.I SCALE="Fs" S FS=TS
.I SCALE="FBS-r" S FB=TS
.I SCALE="RBS" S RB=TS
.I SCALE="L-r" S L=TS
.I SCALE="K-r" S K=TS
Q
BLDGRPH ; draw Validity Scale graph
N I,J,NUMBER,PCENT,TLINE,VALSP,SCLINE,SCALE,GRPH
N V,T,F,FP,FS,FB,RB,L,K
S GRPH=""
D SETVAR
F I=25:-1:0 S TLINE="",NUMBER="" D
.I (I#5)=0 D NUM
.I (I#5)'=0 S NUMBER=NUMBER_" :"
.S TLINE=NUMBER
.I (I=8)!(I=0) D
..F J=6:1:72 S TLINE=TLINE_"_"
.E F J=6:1:72 S TLINE=TLINE_" "
.S (V,T,F,FP,FS,FB,RB)=120,L=105,K=72
.D DMINMX(I)
.S V=34,T=50,(F,FP,FS)=42,FB=26,RB=29,L=37,K=24
.D DMINMX(I)
.D SETSCR
.D SETSTAR
.I $L(TLINE)>72 S TLINE=$E(TLINE,1,72)
.S GRPH=GRPH_"|"_TLINE
S TXT=TXT_GRPH
S TXT=TXT_VALSP_"|"_SCLINE_"|"
Q
NUM ;
S NUMBER=((I*4)+20)_"-:"
I $L(NUMBER)<5 S NUMBER=" "_NUMBER
Q
SETVAR ;
N SP1,L,SC
S PCENT=0,SCALE="",TLINE=" ",SCLINE=" "
S SP1=" ",L=":"
S VALSP="| "_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L
F SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r" D
.S SC=SCALE,PCENT=$P(TSARR(SCALE),U,4) I PCENT<90 S SC="*"_SC
.I $L(SC)<3 S SC=$$ADDSP^YTSMPI2U(SC,3)
.S SCLINE=SCLINE_$$PAD^YTSMPI2U(SC,6)
Q
;
DMINMX(I) ;
N K1
F K1=0:1:3 D
.I (I*4+(20-K1))=V D ; VRIN-r
..S $E(TLINE,11,13)="---"
.I (I*4+(20-K1))=T D ; TRIN-r
..S $E(TLINE,17,19)="---"
.I (I*4+(20-K1))=F D ; F-r
..S $E(TLINE,24,26)="---"
.I (I*4+(20-K1))=FP D ; Fp-r
..S $E(TLINE,31,33)="---"
.I (I*4+(20-K1))=FS D ; Fs
..S $E(TLINE,38,40)="---"
.I (I*4+(20-K1))=FB D ; FBS-r
..S $E(TLINE,44,46)="---"
.I (I*4+(20-K1))=RB D ; RBS
..S $E(TLINE,52,54)="---"
.I (I*4+(20-K1))=L D ; L-r
..S $E(TLINE,59,61)="---"
.I (I*4+(20-K1))=K D ; K-r
..S $E(TLINE,66,68)="---"
Q
;
SETSTAR ;
N K1
F K1=0:1:3 D
.I (I*4+(20-K1))=V D ; VRIN-r
..S $E(TLINE,12)="*"
.I (I*4+(20-K1))=T D ; TRIN-r
..S $E(TLINE,18)="*"
.I (I*4+(20-K1))=F D ; F-r
..S $E(TLINE,25)="*"
.I (I*4+(20-K1))=FP D ; Fp-r
..S $E(TLINE,32)="*"
.I (I*4+(20-K1))=FS D ; Fs
..S $E(TLINE,39)="*"
.I (I*4+(20-K1))=FB D ; FBS-r
..S $E(TLINE,45)="*"
.I (I*4+(20-K1))=RB D ; RBS
..S $E(TLINE,53)="*"
.I (I*4+(20-K1))=L D ; L-r
..S $E(TLINE,60)="*"
.I (I*4+(20-K1))=K D ; K-r
..S $E(TLINE,67)="*"
Q
;
DSPSCOR ;
N DATA,SCALE
S TXT=TXT_"|"_$$ADDSP^YTSMPI2U("Raw ",9)
F SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r" D
.S DATA=$$ADDSP^YTSMPI2U($P(TSARR(SCALE),U,2),7)
.S TXT=TXT_DATA
S TXT=TXT_"|"_$$ADDSP^YTSMPI2U("T Score ",9)
F SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r" D
.S DATA=$$ADDSP^YTSMPI2U($P(TSARR(SCALE),U,3),7)
.S TXT=TXT_DATA
S TXT=TXT_"|"_$$ADDSP^YTSMPI2U("Resp % ",9)
F SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r" D
.S DATA=$$ADDSP^YTSMPI2U($P(TSARR(SCALE),U,4),7)
.S TXT=TXT_DATA
Q
;
VLDTYSC ;
S TXT=TXT_"||| MMPI-2-RF VALIDITY SCALES |"
;build graph/chart
D BLDGRPH
;display Raw, T Score, and % answered
D DSPSCOR
S TXT=TXT_"||Cannot Say (Raw) "_CNT("cannotSay")
S TXT=TXT_" Percent True of items answered "_CNT("trueCount")
;
S TXT=TXT_"|"_FNOTE
S TXT=TXT_"||VRIN-r Variable Response Inconsistency Fs Infrequent Somatic Responses"
S TXT=TXT_"|TRIN-r True Response Inconsistency FBS-r Symptom Validity"
S TXT=TXT_"|F-r Infrequent Responses RBS Response Bias Scale"
S TXT=TXT_"|L-r Uncommon Virtues Fp-r Infrequent Psychopathology Responses"
S TXT=TXT_"|K-r Adjustment Validity"
S TXT=TXT_"||***eop***"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSMPI2V 4174 printed Apr 09, 2024@21:22:38 Page 2
YTSMPI2V ;SLC/PIJ - Score MMPI-2-RF ; 01/08/2016
+1 ;;5.01;MENTAL HEALTH;**123**;DEC 30,1994;Build 73
+2 ;
+3 ;Public, Supported ICRs
+4 ; #2056 - Fileman API - $$GET1^DIQ
+5 ;
+6 QUIT
+7 ; MMPI-2-RF VALIDITY SCALES
+8 ;
+9 ;Scale^RawScore^TScore^CountofAnsweredQuestiona
SETSCR ;
+1 ;TScores --- From TSARR array, piece 3
+2 NEW SCALE,TS
+3 FOR SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r"
Begin DoDot:1
+4 SET TS=$PIECE(TSARR(SCALE),U,3)
+5 IF SCALE="VRIN"
SET V=TS
+6 IF SCALE="TRIN"
SET T=TS
+7 IF SCALE="F-r"
SET F=TS
+8 IF SCALE="Fp-r"
SET FP=TS
+9 IF SCALE="Fs"
SET FS=TS
+10 IF SCALE="FBS-r"
SET FB=TS
+11 IF SCALE="RBS"
SET RB=TS
+12 IF SCALE="L-r"
SET L=TS
+13 IF SCALE="K-r"
SET K=TS
End DoDot:1
+14 QUIT
BLDGRPH ; draw Validity Scale graph
+1 NEW I,J,NUMBER,PCENT,TLINE,VALSP,SCLINE,SCALE,GRPH
+2 NEW V,T,F,FP,FS,FB,RB,L,K
+3 SET GRPH=""
+4 DO SETVAR
+5 FOR I=25:-1:0
SET TLINE=""
SET NUMBER=""
Begin DoDot:1
+6 IF (I#5)=0
DO NUM
+7 IF (I#5)'=0
SET NUMBER=NUMBER_" :"
+8 SET TLINE=NUMBER
+9 IF (I=8)!(I=0)
Begin DoDot:2
+10 FOR J=6:1:72
SET TLINE=TLINE_"_"
End DoDot:2
+11 IF '$TEST
FOR J=6:1:72
SET TLINE=TLINE_" "
+12 SET (V,T,F,FP,FS,FB,RB)=120
SET L=105
SET K=72
+13 DO DMINMX(I)
+14 SET V=34
SET T=50
SET (F,FP,FS)=42
SET FB=26
SET RB=29
SET L=37
SET K=24
+15 DO DMINMX(I)
+16 DO SETSCR
+17 DO SETSTAR
+18 IF $LENGTH(TLINE)>72
SET TLINE=$EXTRACT(TLINE,1,72)
+19 SET GRPH=GRPH_"|"_TLINE
End DoDot:1
+20 SET TXT=TXT_GRPH
+21 SET TXT=TXT_VALSP_"|"_SCLINE_"|"
+22 QUIT
NUM ;
+1 SET NUMBER=((I*4)+20)_"-:"
+2 IF $LENGTH(NUMBER)<5
SET NUMBER=" "_NUMBER
+3 QUIT
SETVAR ;
+1 NEW SP1,L,SC
+2 SET PCENT=0
SET SCALE=""
SET TLINE=" "
SET SCLINE=" "
+3 SET SP1=" "
SET L=":"
+4 SET VALSP="| "_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L_SP1_L
+5 FOR SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r"
Begin DoDot:1
+6 SET SC=SCALE
SET PCENT=$PIECE(TSARR(SCALE),U,4)
IF PCENT<90
SET SC="*"_SC
+7 IF $LENGTH(SC)<3
SET SC=$$ADDSP^YTSMPI2U(SC,3)
+8 SET SCLINE=SCLINE_$$PAD^YTSMPI2U(SC,6)
End DoDot:1
+9 QUIT
+10 ;
DMINMX(I) ;
+1 NEW K1
+2 FOR K1=0:1:3
Begin DoDot:1
+3 ; VRIN-r
IF (I*4+(20-K1))=V
Begin DoDot:2
+4 SET $EXTRACT(TLINE,11,13)="---"
End DoDot:2
+5 ; TRIN-r
IF (I*4+(20-K1))=T
Begin DoDot:2
+6 SET $EXTRACT(TLINE,17,19)="---"
End DoDot:2
+7 ; F-r
IF (I*4+(20-K1))=F
Begin DoDot:2
+8 SET $EXTRACT(TLINE,24,26)="---"
End DoDot:2
+9 ; Fp-r
IF (I*4+(20-K1))=FP
Begin DoDot:2
+10 SET $EXTRACT(TLINE,31,33)="---"
End DoDot:2
+11 ; Fs
IF (I*4+(20-K1))=FS
Begin DoDot:2
+12 SET $EXTRACT(TLINE,38,40)="---"
End DoDot:2
+13 ; FBS-r
IF (I*4+(20-K1))=FB
Begin DoDot:2
+14 SET $EXTRACT(TLINE,44,46)="---"
End DoDot:2
+15 ; RBS
IF (I*4+(20-K1))=RB
Begin DoDot:2
+16 SET $EXTRACT(TLINE,52,54)="---"
End DoDot:2
+17 ; L-r
IF (I*4+(20-K1))=L
Begin DoDot:2
+18 SET $EXTRACT(TLINE,59,61)="---"
End DoDot:2
+19 ; K-r
IF (I*4+(20-K1))=K
Begin DoDot:2
+20 SET $EXTRACT(TLINE,66,68)="---"
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
SETSTAR ;
+1 NEW K1
+2 FOR K1=0:1:3
Begin DoDot:1
+3 ; VRIN-r
IF (I*4+(20-K1))=V
Begin DoDot:2
+4 SET $EXTRACT(TLINE,12)="*"
End DoDot:2
+5 ; TRIN-r
IF (I*4+(20-K1))=T
Begin DoDot:2
+6 SET $EXTRACT(TLINE,18)="*"
End DoDot:2
+7 ; F-r
IF (I*4+(20-K1))=F
Begin DoDot:2
+8 SET $EXTRACT(TLINE,25)="*"
End DoDot:2
+9 ; Fp-r
IF (I*4+(20-K1))=FP
Begin DoDot:2
+10 SET $EXTRACT(TLINE,32)="*"
End DoDot:2
+11 ; Fs
IF (I*4+(20-K1))=FS
Begin DoDot:2
+12 SET $EXTRACT(TLINE,39)="*"
End DoDot:2
+13 ; FBS-r
IF (I*4+(20-K1))=FB
Begin DoDot:2
+14 SET $EXTRACT(TLINE,45)="*"
End DoDot:2
+15 ; RBS
IF (I*4+(20-K1))=RB
Begin DoDot:2
+16 SET $EXTRACT(TLINE,53)="*"
End DoDot:2
+17 ; L-r
IF (I*4+(20-K1))=L
Begin DoDot:2
+18 SET $EXTRACT(TLINE,60)="*"
End DoDot:2
+19 ; K-r
IF (I*4+(20-K1))=K
Begin DoDot:2
+20 SET $EXTRACT(TLINE,67)="*"
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
DSPSCOR ;
+1 NEW DATA,SCALE
+2 SET TXT=TXT_"|"_$$ADDSP^YTSMPI2U("Raw ",9)
+3 FOR SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r"
Begin DoDot:1
+4 SET DATA=$$ADDSP^YTSMPI2U($PIECE(TSARR(SCALE),U,2),7)
+5 SET TXT=TXT_DATA
End DoDot:1
+6 SET TXT=TXT_"|"_$$ADDSP^YTSMPI2U("T Score ",9)
+7 FOR SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r"
Begin DoDot:1
+8 SET DATA=$$ADDSP^YTSMPI2U($PIECE(TSARR(SCALE),U,3),7)
+9 SET TXT=TXT_DATA
End DoDot:1
+10 SET TXT=TXT_"|"_$$ADDSP^YTSMPI2U("Resp % ",9)
+11 FOR SCALE="VRIN","TRIN","F-r","Fp-r","Fs","FBS-r","RBS","L-r","K-r"
Begin DoDot:1
+12 SET DATA=$$ADDSP^YTSMPI2U($PIECE(TSARR(SCALE),U,4),7)
+13 SET TXT=TXT_DATA
End DoDot:1
+14 QUIT
+15 ;
VLDTYSC ;
+1 SET TXT=TXT_"||| MMPI-2-RF VALIDITY SCALES |"
+2 ;build graph/chart
+3 DO BLDGRPH
+4 ;display Raw, T Score, and % answered
+5 DO DSPSCOR
+6 SET TXT=TXT_"||Cannot Say (Raw) "_CNT("cannotSay")
+7 SET TXT=TXT_" Percent True of items answered "_CNT("trueCount")
+8 ;
+9 SET TXT=TXT_"|"_FNOTE
+10 SET TXT=TXT_"||VRIN-r Variable Response Inconsistency Fs Infrequent Somatic Responses"
+11 SET TXT=TXT_"|TRIN-r True Response Inconsistency FBS-r Symptom Validity"
+12 SET TXT=TXT_"|F-r Infrequent Responses RBS Response Bias Scale"
+13 SET TXT=TXT_"|L-r Uncommon Virtues Fp-r Infrequent Psychopathology Responses"
+14 SET TXT=TXT_"|K-r Adjustment Validity"
+15 SET TXT=TXT_"||***eop***"
+16 QUIT
