source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2.m@ 724

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1YTMMPI2 ;ALB/ASF-MMPI2 REPORT; ;4/21/92 08:53
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;
4 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
5T0 ;
6 S L=200,M=0,YSKK=1,YSTL=0 D RD
7T01X ;
8 I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S A(J)=YSTL,J=J+1 G T0:J<14,RD1
9 S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
10T03X ;
11 S YSIT=$P(Y,U,P) I YSIT="" S YSKK=YSKK+1 G T01X
12 S B=$P(Y,U,P+1),P=P+2
13T3 ;
14 I YSIT>L S L=L+200,M=M+200 D RD G T3
15 S:$E(X,YSIT-M)=B YSTL=YSTL+1 G T03X
16RD ;
17 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q
18RD1 ;
19MF ;SCALE 5 FIX
20 S YSND=$S(YSSX="F":"FK",1:"MK"),Y=^YTT(601,YSTEST,"S",8,YSND)
21 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
22 S R="" F I=1:1:13 S R=R_A(I)_U
23 K A S YSRNK=R
24K ;CORRECTION SCALE MODIFIER
25 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)
26ST ;
27 S S="",J=1,P=YSSX
28LK ;
29 S A=$P(R,U,J) G:A="" K0 S L1=$P(^YTT(601,YSTEST,"S",J,P),U) I A<L1 S YSTVL=$P(^(P),U,2) G LK1
30 S YSTVL=$P(^(P),U,A+2-L1) I YSTVL="" S YSTVL=$P(^(P),U,$L(^(P),"^"))
31LK1 ;
32 S S=S_YSTVL_"^",J=J+1 G LK
33K0 ;
34 K YSTVL S (YSSCALEB,YSSCALE)=S,YSRAW=R
35HD ;
36 S DOT=YSHD,YSNS=13,V(3)="",YSSK="B",YSSNM="L ,F ,K ,HS,D ,HY,PD,MF,PA,PT,SC,MA,SI"
37 S X=" M M P I 2 P R O F I L E ",Y=70-$L(X)\2 W @IOF,!!?Y,X,$P(^YTT(601,YSTEST,0),U) D ^YTMMPI2P G:YSLFT END
38BOTTM ;
39 W !?YSLM+6 F I=1:1:YSNS W $E($P(YSSNM,",",I)_" ",1,4)
40 W !?2,"Raw Score:" F I=1:1:YSNS W $J($P(YSRNK,U,I),4) W:I=3 " "
41 S X=$P(R,U,3) W !!?2,"K Corr.",?27,$J(X*.5,2,0),?$X+10,$J(X*.4,2,0),?$X+10,$J(X,2)," ",$J(X,2)," ",$J(X*.2,2,0)
42 W !!?2,"T Score: " F I=1:1:YSNS W $J($P(S,U,I),4) W:I=3 " "
43 W !!?2,"? Cannot Say (Raw): ",YSQR,?35,"F-K (Raw): ",$P(R,U,2)-$P(R,U,3)
44 W !?2,"Percent True:",$J(YSTR/$P(^YTT(601,YSTEST,0),U,11)*100,3,0),?$X+7,"Percent False:",$J(YSFR/$P(^YTT(601,YSTEST,0),U,11)*100,3,0),?$X+7,"Profile Elev.:"
45 S X=0 F I=4,5,6,7,9,10,11,12 S X=X+$P(S,U,I)
46 W $J(X/8,5,1)
47WC ;WELSH CODE
48 S YSULON="",YSULOF="",Z=2
49 ;I IO=0 S YSULON="*27,*91,*52,*109",YSULOF=HL ; *** PC ***
50 ;I IO>0 S YSULON="*27,*45,1",YSULOF="*27,*45,0"
51 I $D(^%ZIS(2,IO,6)) S YSULON=$P(^%ZIS(2,IO,6),U,4),YSULOF=$P(^(6),U,5)
52 K ^UTILITY($J,"YTMMPI2") F I=4:1:13 S X=999-$P(S,U,I),X1=$S(I=13:0,1:I-3) S:'$D(^UTILITY($J,"YTMMPI2",X)) ^(X)="" S ^(X)=^(X)_X1
53 W !!?2,"Welsh Code (new): " S X=0,Z=2
54 F S X=$O(^UTILITY($J,"YTMMPI2",X)) Q:'X S X1=^(X),X2=999-X,Y=X,Y=$O(^UTILITY($J,"YTMMPI2",Y)) S:Y Y=999-Y D UL:$L(X1)>1!(X2-Y<2) W X1 S Z1=Z D:(X2-Y>1) ULOF:Z1=1,NUL:Z1'=1 D WCM
55 K ^UTILITY($J,"YTMMPI2") F I=1,2,3 S X=999-$P(S,U,I),X1=$S(I=1:"L",I=2:"F",1:"K") S:'$D(^UTILITY($J,"YTMMPI2",X)) ^(X)="" S ^(X)=^(X)_X1
56 W " " S X=0,Z=2
57 F S X=$O(^UTILITY($J,"YTMMPI2",X)) Q:'X S X1=^(X),X2=999-X,Y=X,Y=$O(^UTILITY($J,"YTMMPI2",Y)) S:Y Y=999-Y D UL:$L(X1)>1!(X2-Y<2) W X1 S Z1=Z D:(X2-Y>1) ULOF:Z1=1,NUL:Z1'=1 D WCM
58 W:YSULON="" " unable to show ties"
59 W !! D DTA^YTMMPI2P,WAIT^YTMMPI2P G:YSLFT END
60OUT ;
61 K X1,X2,X3,DIC D:^YTT(601,YSTEST,0)?1"MMPI2".E SUP^YTMMPI2A
62END ;
63 K A,B,C,G,H,I,J,K,L,L1,M,N,P,R,S,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,YSN,YSND,YSNS,YSOFF,YSQR,YSRAW,YSRNK,YSSCALE,YSSCALEB
64 K YSSK,YSSNM,YSSNM1,YSTL,YSTR,YSTV,YSTVL,YSULON,YSULOF,YSVS Q
65UL ;
66 W:Z=0 " " W:$L(YSULON) @YSULON S Z=1 Q
67ULOF ;
68 W:$L(YSULOF) @YSULOF S Z=0 Q
69NUL ;
70 S Z=2 Q
71WCM ;
72 S N=0 F K=100:-10:30 S N=N+1 I (X2>(K-1))&(Y<K) W $P("**^*^""^'^-^/^:^#",U,N) S:Z=0 Z=2 Q:Y<1
Note: See TracBrowser for help on using the repository browser.