YTSMPI2E ;SLC/LLH - 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 EXTERNALIZING, INTERPERSONAL and INTEREST SCALES
;
;Scale^RawScore^TScore^CountofAnsweredQuestiona
;
SETSCR ;
;TScores --- From TSARR array, piece 3
N SCALE,TS
F SCALE="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC" D
.S TS=$P(TSARR(SCALE),U,3)
.I SCALE="JCP" S JCP=TS
.I SCALE="SUB" S S=TS
.I SCALE="AGG" S A=TS
.I SCALE="ACT" S ACT=TS
.I SCALE="FML" S F=TS
.I SCALE="IPP" S IPP=TS
.I SCALE="SAV" S SAV=TS
.I SCALE="SHY" S SHY=TS
.I SCALE="DSF" S D=TS
.I SCALE="AES" S AES=TS
.I SCALE="MEC" S M=TS
Q
BLDGRPH ; draw Validity Scale graph
N I,J,NUMBER,PCENT,TLINE,VALSP,SCLINE,SCALE,GRPH
N JCP,S,A,ACT,F,IPP,SAV,SHY,D,AES,M
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=12)!(I=8)!(I=5)!(I=0) D
..F J=6:1:82 S TLINE=TLINE_"_"
.E F J=6:1:82 S TLINE=TLINE_" "
.S $E(TLINE,35)=":"
.S $E(TLINE,70)=":"
.S JCP=84,S=93,A=92,ACT=83,F=90,IPP=81,SAV=80,SHY=75,D=100,AES=73,M=78
.D DMINMX(I)
.S JCP=40,S=41,A=37,ACT=33,F=37,IPP=34,SAV=36,SHY=37,D=44,AES=33,M=38
.D DMINMX(I)
.D SETSCR
.D SETSTAR
.I $L(TLINE)>82 S TLINE=$E(TLINE,1,82)
.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 SC,SP1,L
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_SP1_L_SP1_L
F SCALE="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC" 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))=JCP D ; JCP
..S $E(TLINE,10,12)="---"
.I (I*4+(20-K1))=S D ; SUB
..S $E(TLINE,17,19)="---"
.I (I*4+(20-K1))=A D ; AGG
..S $E(TLINE,24,26)="---"
.I (I*4+(20-K1))=ACT D ; ACT
..S $E(TLINE,31,33)="---"
.I (I*4+(20-K1))=F D ; FML
..S $E(TLINE,38,40)="---"
.I (I*4+(20-K1))=IPP D ; IPP
..S $E(TLINE,45,47)="---"
.I (I*4+(20-K1))=SAV D ; SAV
..S $E(TLINE,52,54)="---"
.I (I*4+(20-K1))=SHY D ; SHY
..S $E(TLINE,59,61)="---"
.I (I*4+(20-K1))=D D ; DFS
..S $E(TLINE,66,68)="---"
.I (I*4+(20-K1))=AES D ; AES
..S $E(TLINE,73,75)="---"
.I (I*4+(20-K1))=M D ; MEC
..S $E(TLINE,80,82)="---"
Q
SETSTAR ;
N K1
F K1=0:1:3 D
.I (I*4+(20-K1))=JCP D ; JCP
..S $E(TLINE,11)="*"
.I (I*4+(20-K1))=S D ; SUB
..S $E(TLINE,18)="*"
.I (I*4+(20-K1))=A D ; AGG
..S $E(TLINE,25)="*"
.I (I*4+(20-K1))=ACT D ; ACT
..S $E(TLINE,32)="*"
.I (I*4+(20-K1))=F D ; FML
..S $E(TLINE,39)="*"
.I (I*4+(20-K1))=IPP D ; IPP
..S $E(TLINE,46)="*"
.I (I*4+(20-K1))=SAV D ; SAV
..S $E(TLINE,53)="*"
.I (I*4+(20-K1))=SHY D ; SHY
..S $E(TLINE,60)="*"
.I (I*4+(20-K1))=D D ; DFS
..S $E(TLINE,67)="*"
.I (I*4+(20-K1))=AES D ; AES
..S $E(TLINE,74)="*"
.I (I*4+(20-K1))=M D ; MEC
..S $E(TLINE,81)="*"
Q
;
DSPSCOR ;
N DATA,SCALE
S TXT=TXT_"|"_$$ADDSP^YTSMPI2U("Raw ",9)
F SCALE="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC" 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="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC" D
.S DATA=$$ADDSP^YTSMPI2U($P(TSARR(SCALE),U,3),7)
.S TXT=TXT_DATA
S TXT=TXT_"|"_$$ADDSP^YTSMPI2U("Resp % ",9)
F SCALE="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC" D
.S DATA=$$ADDSP^YTSMPI2U($P(TSARR(SCALE),U,4),7)
.S TXT=TXT_DATA
Q
EIISC ;
S TXT=TXT_"|| MMPI-2-RF EXTERNALIZING, INTERPERSONAL and INTEREST SCALES |"
S TXT=TXT_"| Externalizing Interpersonal Interest"
;build graph/chart
D BLDGRPH
;display Raw, T Score, and % answered
D DSPSCOR
S TXT=TXT_"|"_FNOTE
S TXT=TXT_"||JCP Juvenile Conduct Problems FML Family Problems AES Aesthetic-Literary Interests"
S TXT=TXT_"|SUB Substance Abuse IPP Interpersonal Passivity MEC Mechanical-Physical Interests"
S TXT=TXT_"|AGG Aggression SAV Social Avoidance"
S TXT=TXT_"|ACT Activation SHY Shyness"
S TXT=TXT_"| DSF Disaffiliativeness"
S TXT=TXT_"|***eop***"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSMPI2E 4670 printed Dec 13, 2024@02:20:13 Page 2
YTSMPI2E ;SLC/LLH - 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 EXTERNALIZING, INTERPERSONAL and INTEREST SCALES
+8 ;
+9 ;Scale^RawScore^TScore^CountofAnsweredQuestiona
+10 ;
SETSCR ;
+1 ;TScores --- From TSARR array, piece 3
+2 NEW SCALE,TS
+3 FOR SCALE="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC"
Begin DoDot:1
+4 SET TS=$PIECE(TSARR(SCALE),U,3)
+5 IF SCALE="JCP"
SET JCP=TS
+6 IF SCALE="SUB"
SET S=TS
+7 IF SCALE="AGG"
SET A=TS
+8 IF SCALE="ACT"
SET ACT=TS
+9 IF SCALE="FML"
SET F=TS
+10 IF SCALE="IPP"
SET IPP=TS
+11 IF SCALE="SAV"
SET SAV=TS
+12 IF SCALE="SHY"
SET SHY=TS
+13 IF SCALE="DSF"
SET D=TS
+14 IF SCALE="AES"
SET AES=TS
+15 IF SCALE="MEC"
SET M=TS
End DoDot:1
+16 QUIT
BLDGRPH ; draw Validity Scale graph
+1 NEW I,J,NUMBER,PCENT,TLINE,VALSP,SCLINE,SCALE,GRPH
+2 NEW JCP,S,A,ACT,F,IPP,SAV,SHY,D,AES,M
+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=12)!(I=8)!(I=5)!(I=0)
Begin DoDot:2
+10 FOR J=6:1:82
SET TLINE=TLINE_"_"
End DoDot:2
+11 IF '$TEST
FOR J=6:1:82
SET TLINE=TLINE_" "
+12 SET $EXTRACT(TLINE,35)=":"
+13 SET $EXTRACT(TLINE,70)=":"
+14 SET JCP=84
SET S=93
SET A=92
SET ACT=83
SET F=90
SET IPP=81
SET SAV=80
SET SHY=75
SET D=100
SET AES=73
SET M=78
+15 DO DMINMX(I)
+16 SET JCP=40
SET S=41
SET A=37
SET ACT=33
SET F=37
SET IPP=34
SET SAV=36
SET SHY=37
SET D=44
SET AES=33
SET M=38
+17 DO DMINMX(I)
+18 DO SETSCR
+19 DO SETSTAR
+20 IF $LENGTH(TLINE)>82
SET TLINE=$EXTRACT(TLINE,1,82)
+21 SET GRPH=GRPH_"|"_TLINE
End DoDot:1
+22 SET TXT=TXT_GRPH
+23 SET TXT=TXT_VALSP_"|"_SCLINE_"|"
+24 QUIT
NUM ;
+1 SET NUMBER=((I*4)+20)_"-:"
+2 IF $LENGTH(NUMBER)<5
SET NUMBER=" "_NUMBER
+3 QUIT
SETVAR ;
+1 NEW SC,SP1,L
+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_SP1_L_SP1_L
+5 FOR SCALE="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC"
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 ; JCP
IF (I*4+(20-K1))=JCP
Begin DoDot:2
+4 SET $EXTRACT(TLINE,10,12)="---"
End DoDot:2
+5 ; SUB
IF (I*4+(20-K1))=S
Begin DoDot:2
+6 SET $EXTRACT(TLINE,17,19)="---"
End DoDot:2
+7 ; AGG
IF (I*4+(20-K1))=A
Begin DoDot:2
+8 SET $EXTRACT(TLINE,24,26)="---"
End DoDot:2
+9 ; ACT
IF (I*4+(20-K1))=ACT
Begin DoDot:2
+10 SET $EXTRACT(TLINE,31,33)="---"
End DoDot:2
+11 ; FML
IF (I*4+(20-K1))=F
Begin DoDot:2
+12 SET $EXTRACT(TLINE,38,40)="---"
End DoDot:2
+13 ; IPP
IF (I*4+(20-K1))=IPP
Begin DoDot:2
+14 SET $EXTRACT(TLINE,45,47)="---"
End DoDot:2
+15 ; SAV
IF (I*4+(20-K1))=SAV
Begin DoDot:2
+16 SET $EXTRACT(TLINE,52,54)="---"
End DoDot:2
+17 ; SHY
IF (I*4+(20-K1))=SHY
Begin DoDot:2
+18 SET $EXTRACT(TLINE,59,61)="---"
End DoDot:2
+19 ; DFS
IF (I*4+(20-K1))=D
Begin DoDot:2
+20 SET $EXTRACT(TLINE,66,68)="---"
End DoDot:2
+21 ; AES
IF (I*4+(20-K1))=AES
Begin DoDot:2
+22 SET $EXTRACT(TLINE,73,75)="---"
End DoDot:2
+23 ; MEC
IF (I*4+(20-K1))=M
Begin DoDot:2
+24 SET $EXTRACT(TLINE,80,82)="---"
End DoDot:2
End DoDot:1
+25 QUIT
SETSTAR ;
+1 NEW K1
+2 FOR K1=0:1:3
Begin DoDot:1
+3 ; JCP
IF (I*4+(20-K1))=JCP
Begin DoDot:2
+4 SET $EXTRACT(TLINE,11)="*"
End DoDot:2
+5 ; SUB
IF (I*4+(20-K1))=S
Begin DoDot:2
+6 SET $EXTRACT(TLINE,18)="*"
End DoDot:2
+7 ; AGG
IF (I*4+(20-K1))=A
Begin DoDot:2
+8 SET $EXTRACT(TLINE,25)="*"
End DoDot:2
+9 ; ACT
IF (I*4+(20-K1))=ACT
Begin DoDot:2
+10 SET $EXTRACT(TLINE,32)="*"
End DoDot:2
+11 ; FML
IF (I*4+(20-K1))=F
Begin DoDot:2
+12 SET $EXTRACT(TLINE,39)="*"
End DoDot:2
+13 ; IPP
IF (I*4+(20-K1))=IPP
Begin DoDot:2
+14 SET $EXTRACT(TLINE,46)="*"
End DoDot:2
+15 ; SAV
IF (I*4+(20-K1))=SAV
Begin DoDot:2
+16 SET $EXTRACT(TLINE,53)="*"
End DoDot:2
+17 ; SHY
IF (I*4+(20-K1))=SHY
Begin DoDot:2
+18 SET $EXTRACT(TLINE,60)="*"
End DoDot:2
+19 ; DFS
IF (I*4+(20-K1))=D
Begin DoDot:2
+20 SET $EXTRACT(TLINE,67)="*"
End DoDot:2
+21 ; AES
IF (I*4+(20-K1))=AES
Begin DoDot:2
+22 SET $EXTRACT(TLINE,74)="*"
End DoDot:2
+23 ; MEC
IF (I*4+(20-K1))=M
Begin DoDot:2
+24 SET $EXTRACT(TLINE,81)="*"
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
DSPSCOR ;
+1 NEW DATA,SCALE
+2 SET TXT=TXT_"|"_$$ADDSP^YTSMPI2U("Raw ",9)
+3 FOR SCALE="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC"
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="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC"
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="JCP","SUB","AGG","ACT","FML","IPP","SAV","SHY","DSF","AES","MEC"
Begin DoDot:1
+12 SET DATA=$$ADDSP^YTSMPI2U($PIECE(TSARR(SCALE),U,4),7)
+13 SET TXT=TXT_DATA
End DoDot:1
+14 QUIT
EIISC ;
+1 SET TXT=TXT_"|| MMPI-2-RF EXTERNALIZING, INTERPERSONAL and INTEREST SCALES |"
+2 SET TXT=TXT_"| Externalizing Interpersonal Interest"
+3 ;build graph/chart
+4 DO BLDGRPH
+5 ;display Raw, T Score, and % answered
+6 DO DSPSCOR
+7 SET TXT=TXT_"|"_FNOTE
+8 SET TXT=TXT_"||JCP Juvenile Conduct Problems FML Family Problems AES Aesthetic-Literary Interests"
+9 SET TXT=TXT_"|SUB Substance Abuse IPP Interpersonal Passivity MEC Mechanical-Physical Interests"
+10 SET TXT=TXT_"|AGG Aggression SAV Social Avoidance"
+11 SET TXT=TXT_"|ACT Activation SHY Shyness"
+12 SET TXT=TXT_"| DSF Disaffiliativeness"
+13 SET TXT=TXT_"|***eop***"
+14 QUIT
