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