source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2A.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1YTMMPI2A ;ALB/ASF-MMPI2 REPORT; ;4/21/92 08:54
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3T0 ;
4 S L=200,M=0,YSKK=1,YSTL=0 D RD
5T01X ;
6 I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S A(J)=YSTL Q
7 S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
8T03X ;
9 S YSIT=$P(Y,U,P) I YSIT="" S YSKK=YSKK+1 G T01X
10 S B=$P(Y,U,P+1),P=P+2
11T3 ;
12 I YSIT>L S L=L+200,M=M+200 D RD G T3
13 S:$E(X,YSIT-M)=B YSTL=YSTL+1 G T03X
14RD ;
15 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q
16SUP ;SUPPLEMENTARY SCALES
17 K A S (R,S)="" F J=14:1:17,20:1:28 D T0
18 D TRIN,STS,HDS Q:YSLFT
19CNTNT ;CONTENT SCALES
20 K A S (R,S)="" F J=29:1:43 D T0
21 D STC,HDC Q:YSLFT
22 D ^YTMMPI2B Q
23HDC ;
24 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)",!
25 D ^YTMMPI2P Q:YSLFT D BOTTM Q
26TRIN ;TRUE RESPONSE SCALE
27 S X1=^YTD(601.2,YSDFN,1,YSET,1,YSED,1),X2=^(2),X3=^(3)
28 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
29VRIN ;VARIABLE RESPONSE SCALE
30 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
31 Q
32STS ;
33 S (R,S)="",P=YSSX F J=14:1:28 D LK
34 K YSTVL S YSSCALE=S,YSRAW=R Q
35STC ;
36 S (R,S)="",P=YSSX F J=29:1:43 D LK
37 K YSTVL S YSSCALE=S,YSRAW=R Q
38HDS ;
39 S YSNS=15,YSSK="S",YSSNM="A ,R ,Es,FB,TR,VR,OH,Do,RE,Mt,GM,GF,PK,PS,MAC-R"
40 W @IOF,!!?25,"Supplementary Scales Profile",! D ^YTMMPI2P Q:YSLFT D BOTTM Q
41BOTTM ;
42 W !?YSLM+6 F I=1:1:YSNS W $E($P(YSSNM,",",I)_" ",1,4)
43 W:YSSK="S" "R" W !,"Raw",!,"Score: " F I=1:1:YSNS W $J($P(YSRAW,U,I),4)
44 W !!,"T Score: " F I=1:1:YSNS W $J($P(S,U,I),4)
45 W !! D DTA^YTMMPI2P,WAIT^YTMMPI2P:IOST?1"C-".E Q
46INCON ;
47 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))
48 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
49 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
50LK 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
51 S YSTVL=$P(^(P),U,A+2-L1) I YSTVL="" S YSTVL=$P(^(P),U,$L(^(P),"^"))
52LK1 ;
53 S S=S_YSTVL_"^" Q
54SHORT ;MOVE MMPI2 INCOMPLETE TO SHORT FORM
55 S S=$O(^YTT(601,"B","MMP2S",0)),C=$O(^YTT(601,"B","CLERK",0)),F=$O(^YTT(601,"B","MMPI2",0))
56 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
57 I '$D(^YTD(601.4,YSDFN,1,C,2))!($L(^(2))<170) W !,"Patient did not answer the required 370 questions" H 3 Q
58 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)
59 L -^YTD(601.4,YSDFN) S DIK="^YTD(601.4,YSDFN,1,",DA=C,DA(1)=YSDFN D ^DIK K DA,DIK
60 S YSRP="",(YSEN,YSTEST)=S D ^YTFILE W !,"DONE",$C(7) H 1 Q
Note: See TracBrowser for help on using the repository browser.