YSMTI3 ;ALB/ASF-PSYCH TEST DOWNLOAD MMPI2 ;6/20/03 13:32
;;5.01;MENTAL HEALTH;**53,71,76,70**;Dec 30, 1994
S J=1,(YSTR,YSFR,YSQR)=0 F I=1:1:3 I $D(^YTD(601.2,YSDFN,1,YSET,1,YSED,I)) S X=^(I),L=$L(X) F K=1:1:L S:$E(X,K)="X" YSQR=YSQR+1 S:$E(X,K)="T" YSTR=YSTR+1 S:$E(X,K)="F" YSFR=YSFR+1
T0 S L=200,M=0,YSKK=1,YSTL=0 D RD
T01X I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S A(J)=YSTL,J=J+1 G T0:J<14,RD1
S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
T03X S YSIT=$P(Y,"^",P) I YSIT="" S YSKK=YSKK+1 G T01X
S B=$P(Y,"^",P+1),P=P+2
T3 I YSIT>L S L=L+200,M=M+200 D RD G T3
S:$E(X,YSIT-M)=B YSTL=YSTL+1 G T03X
RD S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q
RD1 ;
MF ;SCALE 5 FIX
S YSND=$S(YSSX="F":"FK",1:"MK"),Y=^YTT(601,YSTEST,"S",8,YSND)
F P=1,3,5,7 S YSIT=$P(Y,U,P),B=$P(Y,U,P+1) S X=$S(YSIT>200:$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,2),YSIT-200),1:$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSIT)) S:X=B A(8)=A(8)+1
S R="" F I=1:1:13 S R=R_A(I)_U
K A
K ;CORRECTION SCALE MODIFIER
S NONKR=R
S X=$P(R,U,3) S $P(R,U,4)=$P(R,U,4)+$J(X*.5,0,0) S $P(R,U,7)=$P(R,U,7)+$J(X*.4,0,0) S $P(R,U,10)=$P(R,U,10)+X S $P(R,U,11)=$P(R,U,11)+X S $P(R,U,12)=$P(R,U,12)+$J(X*.2,0,0)
ST S S="",J=1,P=YSSX
LK S A=$P(R,"^",J) G:A="" K0 S L1=$P(^YTT(601,YSTEST,"S",J,P),"^",1) I A<L1 S YSTVL=$P(^(P),"^",2) G LK1
S YSTVL=$P(^YTT(601,YSTEST,"S",J,P),"^",A+2-L1) I YSTVL="" S YSTVL=$P(^(P),"^",$L(^(P),"^"))
LK1 S S=S_YSTVL_"^",J=J+1 G LK
K0 K YSTVL S (YSSCALEB,YSSCALE)=S,YSRAW=NONKR,S(1)=S,R(1)=NONKR
G:YSTN="MMP2S" END
SUP ;SUPPLEMENTARY SCALES
K A S (R,S)="" F J=14:1:17,20:1:28 D T0^YTMMPI2A
D TRIN^YTMMPI2A,STS^YTMMPI2A S S(2)=S,R(2)=R
CNTNT ;CONTENT SCALES
K A S (R,S)="" F J=29:1:43 D T0^YTMMPI2A
D STC^YTMMPI2A S S(3)=S,R(3)=R
HL1 ;HARIS LINGOS #1 D THRU PD
S (R,S)="" F J=44:1:58 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
K A,YSTVL S YSSCALE=S,YSRAW=R,S(4)=S,R(4)=R
HL2 ;HARRIS LINGOS #2 PA THRU MA
S (R,S)="" F J=59:1:71 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
K A,YSTVL S YSSCALE=S,YSRAW=R,S(5)=S,R(5)=R
SI ;SOCIAL INTOVERSION/ OBVIOUS SUBTLE
S (R,S)="" F J=72:1:84 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
K A,YSTVL S YSSCALE=S,YSRAW=R,S(6)=S,R(6)=R,(R,S)=""
PLACER1 ;PLACE HOLDERS
S (R,S)="" F J=85:1:100 S R=R_"0"_U,S=S_"0"_U
S YSSCALE=S,YSRAW=R,S(7)=S,R(7)=R,(R,S)=""
NONK ;non K-CORRECTED
;S (R,S)="" F J=101:1:105 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
S (R,S)="",K=100 F J=4,7,10,11,12 S K=K+1 D T0^YTMMPI2A S A(K)=A(J) K A(J)
F J=101:1:105 S P=YSSX D LK^YTMMPI2A
K A,YSTVL S YSSCALE=S,YSRAW=R,S(8)=S,R(8)=R,(R,S)=""
PLACER2 ;
S R="0^",S=R,S(9)=S,R(9)=R,YSSCALE=S,YSRAW=R,(R,S)="" ;105
ADDED ;ADDITIONAL SUPLEMENTARY SCORES '### ASF 1/11/01
S (R,S)="" F J=107:1:113 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A ;113 on 4/18/01 by ASF
K A,YSTVL S YSSCALE=S,YSRAW=R,S(10)=S,R(10)=R,(R,S)=""
PSY5 ;PSY-5 SCALES ADDED 8/29/02 ### ASF
S (R,S)="" F J=114:1:118 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A ;113 on 4/18/01 by ASF
K A,YSTVL S YSSCALE=S,YSRAW=R,S(11)=S,R(11)=R,(R,S)=""
RCCLIN ;resturctured clinical ; added 6/20/03
S (R,S)="" F J=119:1:127 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
K A,YSTVL S YSSCALE=S,YSRAW=R,S(12)=S,R(12)=R,(R,S)=""
END K A,B,C,G,H,I,J,K,L,L1,M,N,P,V,X,X1,X2,X3,Y,YSAST,YSB1,YSB2,YSBV,YSCNT,YSF,YSFR,YSHS,YSINC,YSIN2,YSIT,YSIT1,YSIT2,YSKK,YSKY,YSLE,YSLL,YSLM,YSLV,YSND,YSNS,YSOFF,YSQR,YSRAW,YSSCALE,YSSCALEB,NONKR
K YSSK,YSSNM,YSSNM1,YSTL,YSTR,YSTV,YSTVL,YSULON,YSULOF,YSVS Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI3 3445 printed Apr 09, 2024@21:23:54 Page 2
YSMTI3 ;ALB/ASF-PSYCH TEST DOWNLOAD MMPI2 ;6/20/03 13:32
+1 ;;5.01;MENTAL HEALTH;**53,71,76,70**;Dec 30, 1994
+2 SET J=1
SET (YSTR,YSFR,YSQR)=0
FOR I=1:1:3
IF $DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED,I))
SET X=^(I)
SET L=$LENGTH(X)
FOR K=1:1:L
if $EXTRACT(X,K)="X"
SET YSQR=YSQR+1
if $EXTRACT(X,K)="T"
SET YSTR=YSTR+1
if $EXTRACT(X,K)="F"
SET YSFR=YSFR+1
T0 SET L=200
SET M=0
SET YSKK=1
SET YSTL=0
DO RD
T01X IF '$DATA(^YTT(601,YSTEST,"S",J,"K",YSKK,0))
SET A(J)=YSTL
SET J=J+1
if J<14
GOTO T0
GOTO RD1
+1 SET Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0)
SET P=1
T03X SET YSIT=$PIECE(Y,"^",P)
IF YSIT=""
SET YSKK=YSKK+1
GOTO T01X
+1 SET B=$PIECE(Y,"^",P+1)
SET P=P+2
T3 IF YSIT>L
SET L=L+200
SET M=M+200
DO RD
GOTO T3
+1 if $EXTRACT(X,YSIT-M)=B
SET YSTL=YSTL+1
GOTO T03X
RD SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)
QUIT
RD1 ;
MF ;SCALE 5 FIX
+1 SET YSND=$SELECT(YSSX="F":"FK",1:"MK")
SET Y=^YTT(601,YSTEST,"S",8,YSND)
+2 FOR P=1,3,5,7
SET YSIT=$PIECE(Y,U,P)
SET B=$PIECE(Y,U,P+1)
SET X=$SELECT(YSIT>200:$EXTRACT(^YTD(601.2,YSDFN,1,YSET,1,YSED,2),YSIT-200),1:$EXTRACT(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSIT))
if X=B
SET A(8)=A(8)+1
+3 SET R=""
FOR I=1:1:13
SET R=R_A(I)_U
+4 KILL A
K ;CORRECTION SCALE MODIFIER
+1 SET NONKR=R
+2 SET X=$PIECE(R,U,3)
SET $PIECE(R,U,4)=$PIECE(R,U,4)+$JUSTIFY(X*.5,0,0)
SET $PIECE(R,U,7)=$PIECE(R,U,7)+$JUSTIFY(X*.4,0,0)
SET $PIECE(R,U,10)=$PIECE(R,U,10)+X
SET $PIECE(R,U,11)=$PIECE(R,U,11)+X
SET $PIECE(R,U,12)=$PIECE(R,U,12)+$JUSTIFY(X*.2,0,0)
ST SET S=""
SET J=1
SET P=YSSX
LK SET A=$PIECE(R,"^",J)
if A=""
GOTO K0
SET L1=$PIECE(^YTT(601,YSTEST,"S",J,P),"^",1)
IF A<L1
SET YSTVL=$PIECE(^(P),"^",2)
GOTO LK1
+1 SET YSTVL=$PIECE(^YTT(601,YSTEST,"S",J,P),"^",A+2-L1)
IF YSTVL=""
SET YSTVL=$PIECE(^(P),"^",$LENGTH(^(P),"^"))
LK1 SET S=S_YSTVL_"^"
SET J=J+1
GOTO LK
K0 KILL YSTVL
SET (YSSCALEB,YSSCALE)=S
SET YSRAW=NONKR
SET S(1)=S
SET R(1)=NONKR
+1 if YSTN="MMP2S"
GOTO END
SUP ;SUPPLEMENTARY SCALES
+1 KILL A
SET (R,S)=""
FOR J=14:1:17,20:1:28
DO T0^YTMMPI2A
+2 DO TRIN^YTMMPI2A
DO STS^YTMMPI2A
SET S(2)=S
SET R(2)=R
CNTNT ;CONTENT SCALES
+1 KILL A
SET (R,S)=""
FOR J=29:1:43
DO T0^YTMMPI2A
+2 DO STC^YTMMPI2A
SET S(3)=S
SET R(3)=R
HL1 ;HARIS LINGOS #1 D THRU PD
+1 SET (R,S)=""
FOR J=44:1:58
DO T0^YTMMPI2A
SET P=YSSX
DO LK^YTMMPI2A
+2 KILL A,YSTVL
SET YSSCALE=S
SET YSRAW=R
SET S(4)=S
SET R(4)=R
HL2 ;HARRIS LINGOS #2 PA THRU MA
+1 SET (R,S)=""
FOR J=59:1:71
DO T0^YTMMPI2A
SET P=YSSX
DO LK^YTMMPI2A
+2 KILL A,YSTVL
SET YSSCALE=S
SET YSRAW=R
SET S(5)=S
SET R(5)=R
SI ;SOCIAL INTOVERSION/ OBVIOUS SUBTLE
+1 SET (R,S)=""
FOR J=72:1:84
DO T0^YTMMPI2A
SET P=YSSX
DO LK^YTMMPI2A
+2 KILL A,YSTVL
SET YSSCALE=S
SET YSRAW=R
SET S(6)=S
SET R(6)=R
SET (R,S)=""
PLACER1 ;PLACE HOLDERS
+1 SET (R,S)=""
FOR J=85:1:100
SET R=R_"0"_U
SET S=S_"0"_U
+2 SET YSSCALE=S
SET YSRAW=R
SET S(7)=S
SET R(7)=R
SET (R,S)=""
NONK ;non K-CORRECTED
+1 ;S (R,S)="" F J=101:1:105 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
+2 SET (R,S)=""
SET K=100
FOR J=4,7,10,11,12
SET K=K+1
DO T0^YTMMPI2A
SET A(K)=A(J)
KILL A(J)
+3 FOR J=101:1:105
SET P=YSSX
DO LK^YTMMPI2A
+4 KILL A,YSTVL
SET YSSCALE=S
SET YSRAW=R
SET S(8)=S
SET R(8)=R
SET (R,S)=""
PLACER2 ;
+1 ;105
SET R="0^"
SET S=R
SET S(9)=S
SET R(9)=R
SET YSSCALE=S
SET YSRAW=R
SET (R,S)=""
ADDED ;ADDITIONAL SUPLEMENTARY SCORES '### ASF 1/11/01
+1 ;113 on 4/18/01 by ASF
SET (R,S)=""
FOR J=107:1:113
DO T0^YTMMPI2A
SET P=YSSX
DO LK^YTMMPI2A
+2 KILL A,YSTVL
SET YSSCALE=S
SET YSRAW=R
SET S(10)=S
SET R(10)=R
SET (R,S)=""
PSY5 ;PSY-5 SCALES ADDED 8/29/02 ### ASF
+1 ;113 on 4/18/01 by ASF
SET (R,S)=""
FOR J=114:1:118
DO T0^YTMMPI2A
SET P=YSSX
DO LK^YTMMPI2A
+2 KILL A,YSTVL
SET YSSCALE=S
SET YSRAW=R
SET S(11)=S
SET R(11)=R
SET (R,S)=""
RCCLIN ;resturctured clinical ; added 6/20/03
+1 SET (R,S)=""
FOR J=119:1:127
DO T0^YTMMPI2A
SET P=YSSX
DO LK^YTMMPI2A
+2 KILL A,YSTVL
SET YSSCALE=S
SET YSRAW=R
SET S(12)=S
SET R(12)=R
SET (R,S)=""
END KILL A,B,C,G,H,I,J,K,L,L1,M,N,P,V,X,X1,X2,X3,Y,YSAST,YSB1,YSB2,YSBV,YSCNT,YSF,YSFR,YSHS,YSINC,YSIN2,YSIT,YSIT1,YSIT2,YSKK,YSKY,YSLE,YSLL,YSLM,YSLV,YSND,YSNS,YSOFF,YSQR,YSRAW,YSSCALE,YSSCALEB,NONKR
+1 KILL YSSK,YSSNM,YSSNM1,YSTL,YSTR,YSTV,YSTVL,YSULON,YSULOF,YSVS
QUIT
