- 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 Feb 18, 2025@23:46: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