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