YTMMPI2A ;ALB/ASF-MMPI2 REPORT; ;4/21/92 08:54
;;5.01;MENTAL HEALTH;;Dec 30, 1994
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 Q
S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
T03X ;
S YSIT=$P(Y,U,P) I YSIT="" S YSKK=YSKK+1 G T01X
S B=$P(Y,U,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
SUP ;SUPPLEMENTARY SCALES
K A S (R,S)="" F J=14:1:17,20:1:28 D T0
D TRIN,STS,HDS Q:YSLFT
CNTNT ;CONTENT SCALES
K A S (R,S)="" F J=29:1:43 D T0
D STC,HDC Q:YSLFT
D ^YTMMPI2B Q
HDC ;
S YSNS=15,YSSK="C",YSSNM="ANX,FRS,OBS,DEP,HEA,BIZ,ANG,CYN,ASP,TPA,LSE,SOD,FAM,WRK,TRT" W @IOF,!!?25,"Content Scales Profile",!?15,"Butcher, Graham, Williams, and Ben-Porath (1989)",!
D ^YTMMPI2P Q:YSLFT D BOTTM Q
TRIN ;TRUE RESPONSE SCALE
S X1=^YTD(601.2,YSDFN,1,YSET,1,YSED,1),X2=^(2),X3=^(3)
S A(18)=9 F J=1:1 Q:'$D(^YTT(601,YSTEST,"S",18,"K",J,0)) S G=^(0) F I=1:1:$L(G,"^") D INCON S:YSF&(YSB1="T") A(18)=A(18)+1 S:YSF&(YSB1="F") A(18)=A(18)-1
VRIN ;VARIABLE RESPONSE SCALE
S A(19)=0 F J=1:1 Q:'$D(^YTT(601,YSTEST,"S",19,"K",J,0)) S G=^(0) F I=1:1:$L(G,"^") D INCON S:YSF A(19)=A(19)+1
Q
STS ;
S (R,S)="",P=YSSX F J=14:1:28 D LK
K YSTVL S YSSCALE=S,YSRAW=R Q
STC ;
S (R,S)="",P=YSSX F J=29:1:43 D LK
K YSTVL S YSSCALE=S,YSRAW=R Q
HDS ;
S YSNS=15,YSSK="S",YSSNM="A ,R ,Es,FB,TR,VR,OH,Do,RE,Mt,GM,GF,PK,PS,MAC-R"
W @IOF,!!?25,"Supplementary Scales Profile",! D ^YTMMPI2P Q:YSLFT D BOTTM Q
BOTTM ;
W !?YSLM+6 F I=1:1:YSNS W $E($P(YSSNM,",",I)_" ",1,4)
W:YSSK="S" "R" W !,"Raw",!,"Score: " F I=1:1:YSNS W $J($P(YSRAW,U,I),4)
W !!,"T Score: " F I=1:1:YSNS W $J($P(S,U,I),4)
W !! D DTA^YTMMPI2P,WAIT^YTMMPI2P:IOST?1"C-".E Q
INCON ;
S Y=$P(G,U,I),YSIT1=+Y,YSB1=$P(Y,","),YSB1=$E(YSB1,$L(YSB1)),YSIT2=+$P(Y,",",2),YSB2=$E(Y,$L(Y))
S YSF=0,X=$S(YSIT1>400:3,YSIT1>200:2,1:1) S Y=@("X"_X),YSOFF=X-1*200,Y=$E(Y,YSIT1-YSOFF) Q:Y'=YSB1 S YSF=1
S YSF=0,X=$S(YSIT2>400:3,YSIT2>200:2,1:1) S Y=@("X"_X),YSOFF=X-1*200,Y=$E(Y,YSIT2-YSOFF) S:Y=YSB2 YSF=1 Q
LK S A=A(J),R=R_A_U,L1=$P(^YTT(601,YSTEST,"S",J,P),U) I A<L1 S YSTVL=$P(^(P),U,2) G LK1
S YSTVL=$P(^(P),U,A+2-L1) I YSTVL="" S YSTVL=$P(^(P),U,$L(^(P),"^"))
LK1 ;
S S=S_YSTVL_"^" Q
SHORT ;MOVE MMPI2 INCOMPLETE TO SHORT FORM
S S=$O(^YTT(601,"B","MMP2S",0)),C=$O(^YTT(601,"B","CLERK",0)),F=$O(^YTT(601,"B","MMPI2",0))
D ^YSLRP Q:YSDFN'>0 I '$D(^YTD(601.4,YSDFN,1,C))!($P(^(C,0),U,6)'=F) W !!,"No Incomplete MMPI-2 found for this patient" H 3 Q
I '$D(^YTD(601.4,YSDFN,1,C,2))!($L(^(2))<170) W !,"Patient did not answer the required 370 questions" H 3 Q
L +^YTD(601.4,YSDFN) S ^YTD(601.4,YSDFN,1,S,0)=^YTD(601.4,YSDFN,1,C,0),YSORD=$P(^(0),U,7),^YTD(601.4,YSDFN,1,S,1)=^YTD(601.4,YSDFN,1,C,1),^YTD(601.4,YSDFN,1,S,2)=$E(^YTD(601.4,YSDFN,1,C,2),1,170)
L -^YTD(601.4,YSDFN) S DIK="^YTD(601.4,YSDFN,1,",DA=C,DA(1)=YSDFN D ^DIK K DA,DIK
S YSRP="",(YSEN,YSTEST)=S D ^YTFILE W !,"DONE",$C(7) H 1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTMMPI2A 3047 printed Dec 13, 2024@02:17:47 Page 2
YTMMPI2A ;ALB/ASF-MMPI2 REPORT; ;4/21/92 08:54
+1 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
T0 ;
+1 SET L=200
SET M=0
SET YSKK=1
SET YSTL=0
DO RD
T01X ;
+1 IF '$DATA(^YTT(601,YSTEST,"S",J,"K",YSKK,0))
SET A(J)=YSTL
QUIT
+2 SET Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0)
SET P=1
T03X ;
+1 SET YSIT=$PIECE(Y,U,P)
IF YSIT=""
SET YSKK=YSKK+1
GOTO T01X
+2 SET B=$PIECE(Y,U,P+1)
SET P=P+2
T3 ;
+1 IF YSIT>L
SET L=L+200
SET M=M+200
DO RD
GOTO T3
+2 if $EXTRACT(X,YSIT-M)=B
SET YSTL=YSTL+1
GOTO T03X
RD ;
+1 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)
QUIT
SUP ;SUPPLEMENTARY SCALES
+1 KILL A
SET (R,S)=""
FOR J=14:1:17,20:1:28
DO T0
+2 DO TRIN
DO STS
DO HDS
if YSLFT
QUIT
CNTNT ;CONTENT SCALES
+1 KILL A
SET (R,S)=""
FOR J=29:1:43
DO T0
+2 DO STC
DO HDC
if YSLFT
QUIT
+3 DO ^YTMMPI2B
QUIT
HDC ;
+1 SET YSNS=15
SET YSSK="C"
SET YSSNM="ANX,FRS,OBS,DEP,HEA,BIZ,ANG,CYN,ASP,TPA,LSE,SOD,FAM,WRK,TRT"
WRITE @IOF,!!?25,"Content Scales Profile",!?15,"Butcher, Graham, Williams, and Ben-Porath (1989)",!
+2 DO ^YTMMPI2P
if YSLFT
QUIT
DO BOTTM
QUIT
TRIN ;TRUE RESPONSE SCALE
+1 SET X1=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
SET X2=^(2)
SET X3=^(3)
+2 SET A(18)=9
FOR J=1:1
if '$DATA(^YTT(601,YSTEST,"S",18,"K",J,0))
QUIT
SET G=^(0)
FOR I=1:1:$LENGTH(G,"^")
DO INCON
if YSF&(YSB1="T")
SET A(18)=A(18)+1
if YSF&(YSB1="F")
SET A(18)=A(18)-1
VRIN ;VARIABLE RESPONSE SCALE
+1 SET A(19)=0
FOR J=1:1
if '$DATA(^YTT(601,YSTEST,"S",19,"K",J,0))
QUIT
SET G=^(0)
FOR I=1:1:$LENGTH(G,"^")
DO INCON
if YSF
SET A(19)=A(19)+1
+2 QUIT
STS ;
+1 SET (R,S)=""
SET P=YSSX
FOR J=14:1:28
DO LK
+2 KILL YSTVL
SET YSSCALE=S
SET YSRAW=R
QUIT
STC ;
+1 SET (R,S)=""
SET P=YSSX
FOR J=29:1:43
DO LK
+2 KILL YSTVL
SET YSSCALE=S
SET YSRAW=R
QUIT
HDS ;
+1 SET YSNS=15
SET YSSK="S"
SET YSSNM="A ,R ,Es,FB,TR,VR,OH,Do,RE,Mt,GM,GF,PK,PS,MAC-R"
+2 WRITE @IOF,!!?25,"Supplementary Scales Profile",!
DO ^YTMMPI2P
if YSLFT
QUIT
DO BOTTM
QUIT
BOTTM ;
+1 WRITE !?YSLM+6
FOR I=1:1:YSNS
WRITE $EXTRACT($PIECE(YSSNM,",",I)_" ",1,4)
+2 if YSSK="S"
WRITE "R"
WRITE !,"Raw",!,"Score: "
FOR I=1:1:YSNS
WRITE $JUSTIFY($PIECE(YSRAW,U,I),4)
+3 WRITE !!,"T Score: "
FOR I=1:1:YSNS
WRITE $JUSTIFY($PIECE(S,U,I),4)
+4 WRITE !!
DO DTA^YTMMPI2P
if IOST?1"C-".E
DO WAIT^YTMMPI2P
QUIT
INCON ;
+1 SET Y=$PIECE(G,U,I)
SET YSIT1=+Y
SET YSB1=$PIECE(Y,",")
SET YSB1=$EXTRACT(YSB1,$LENGTH(YSB1))
SET YSIT2=+$PIECE(Y,",",2)
SET YSB2=$EXTRACT(Y,$LENGTH(Y))
+2 SET YSF=0
SET X=$SELECT(YSIT1>400:3,YSIT1>200:2,1:1)
SET Y=@("X"_X)
SET YSOFF=X-1*200
SET Y=$EXTRACT(Y,YSIT1-YSOFF)
if Y'=YSB1
QUIT
SET YSF=1
+3 SET YSF=0
SET X=$SELECT(YSIT2>400:3,YSIT2>200:2,1:1)
SET Y=@("X"_X)
SET YSOFF=X-1*200
SET Y=$EXTRACT(Y,YSIT2-YSOFF)
if Y=YSB2
SET YSF=1
QUIT
LK SET A=A(J)
SET R=R_A_U
SET L1=$PIECE(^YTT(601,YSTEST,"S",J,P),U)
IF A<L1
SET YSTVL=$PIECE(^(P),U,2)
GOTO LK1
+1 SET YSTVL=$PIECE(^(P),U,A+2-L1)
IF YSTVL=""
SET YSTVL=$PIECE(^(P),U,$LENGTH(^(P),"^"))
LK1 ;
+1 SET S=S_YSTVL_"^"
QUIT
SHORT ;MOVE MMPI2 INCOMPLETE TO SHORT FORM
+1 SET S=$ORDER(^YTT(601,"B","MMP2S",0))
SET C=$ORDER(^YTT(601,"B","CLERK",0))
SET F=$ORDER(^YTT(601,"B","MMPI2",0))
+2 DO ^YSLRP
if YSDFN'>0
QUIT
IF '$DATA(^YTD(601.4,YSDFN,1,C))!($PIECE(^(C,0),U,6)'=F)
WRITE !!,"No Incomplete MMPI-2 found for this patient"
HANG 3
QUIT
+3 IF '$DATA(^YTD(601.4,YSDFN,1,C,2))!($LENGTH(^(2))<170)
WRITE !,"Patient did not answer the required 370 questions"
HANG 3
QUIT
+4 LOCK +^YTD(601.4,YSDFN)
SET ^YTD(601.4,YSDFN,1,S,0)=^YTD(601.4,YSDFN,1,C,0)
SET YSORD=$PIECE(^(0),U,7)
SET ^YTD(601.4,YSDFN,1,S,1)=^YTD(601.4,YSDFN,1,C,1)
SET ^YTD(601.4,YSDFN,1,S,2)=$EXTRACT(^YTD(601.4,YSDFN,1,C,2),1,170)
+5 LOCK -^YTD(601.4,YSDFN)
SET DIK="^YTD(601.4,YSDFN,1,"
SET DA=C
SET DA(1)=YSDFN
DO ^DIK
KILL DA,DIK
+6 SET YSRP=""
SET (YSEN,YSTEST)=S
DO ^YTFILE
WRITE !,"DONE",$CHAR(7)
HANG 1
QUIT
