source: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPAI.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1YTPAI ;ASF/ALB- PAI TEST ;7/14/00 10:26
2 ;;5.01;MENTAL HEALTH;**10,66**;Dec 30, 1994
3 ;
4 ;Reference to $$SQRT^XLFMTH supported by IA #10105
5 ;
6 S YSLFT=0,YSNOITEM="DONE^YTPAI"
7MAIN ;
8 S (R,S)="^",YSMX=4
9 D RD
10 I $L(X,"X")>18 D DTA^YTREPT W !!!!,"PAI: Too many missing items to score" D:IOST?1"C".E SCR^YTREPT G OUT
11 D SCOR,STND
12 D ^YTPAI1 ;profile
13 G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
14 D SUBS^YTPAI1
15 G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
16 D ADDIT
17 D FIT
18 G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
19 D CRIT ;critical items
20 G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
21OUT D DTA^YTREPT,IR^YTPAI1
22DONE K S,R,A,YSXBAR,YSYBAR,YSXSD,YSYSD Q
23RD S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)_^YTD(601.2,YSDFN,1,YSET,1,YSED,2) Q
24SCOR ;
25 F YSKK=2:1:53 I $D(^YTT(601,YSTEST,"S",YSKK,"K")) S Y=^YTT(601,YSTEST,"S",YSKK,"K",1,0),YSTL=0 D KK S $P(R,U,YSKK)=YSTL
26FS ;full scales
27 F I=5,9,13,17,21,25,29,33,38,44 S $P(R,U,I)=$P(R,U,I+1)+$P(R,U,I+2)+$P(R,U,I+3) S:I=33 $P(R,U,I)=$P(R,U,I)+$P(R,U,I+4)
28ICNR ;score ICN
29 S YSICN=0
30 S Y=(5-$E(X,75))-(5-$E(X,115)) D A
31 S Y=$E(X,4)-$E(X,44) D A
32 S Y=$E(X,60)-$E(X,100) D A
33 S Y=$E(X,145)-(5-$E(X,185)) D A
34 S Y=$E(X,65)-(5-$E(X,246)) D A
35 S Y=$E(X,102)-(5-$E(X,103)) D A
36 S Y=$E(X,22)-(5-$E(X,142)) D A
37 S Y=(5-$E(X,301))-$E(X,140) D A
38 S Y=5-(5-$E(X,270))-$E(X,53) D A
39 S Y=5-(5-$E(X,190))-$E(X,13) D A
40 S $P(R,U,1)=YSICN
41 S X=^YTT(601,YSTEST,"S",1,"M"),$P(S,U,1)=$J((YSICN-$P(X,U)/$P(X,U,2)*10+50),0,0)
42 Q
43A ;icn absolutes
44 S:Y<0 Y=-Y S YSICN=YSICN+Y Q
45KK S YSNUMX=0
46 F I=1:2 Q:$P(Y,U,I)="" S YSIT=$P(Y,U,I),A=$P(Y,U,I+1),B=$E(X,YSIT),YSTL=YSTL+$S(B="X":0,A="D":B-1,1:YSMX-B) S:B="X" YSNUMX=YSNUMX+1
47 I (YSNUMX/(I-1))>.2 S YSTL="X"
48 Q
49STND ;stanard T scores
50 F J=2:1:53 S A=$P(R,U,J) S:A?.N X=^YTT(601,YSTEST,"S",J,"M"),S(J)=$J((A-$P(X,U)/$P(X,U,2)*10+50),0,0) S:A="X" S(J)="X" S S=S_S(J)_U
51 Q
52ADDIT ;additional indexes
53 D DTA^YTREPT
54 S YSINDX=0
55 I $P(S,U,3)>109 S YSINDX=YSINDX+1
56 I $P(S,U,3)-$P(S,U,2)>19 S YSINDX=YSINDX+1
57 I $P(S,U,2)-$P(S,U,1)>14 S YSINDX=YSINDX+1 ;asf 7/14/00 =YSINDX+2
58 I $P(S,U,27)-$P(S,U,26)>14 S YSINDX=YSINDX+1
59 I $P(S,U,27)-$P(S,U,28)>14 S YSINDX=YSINDX+1
60 I $P(S,U,24)-$P(S,U,23)>14 S YSINDX=YSINDX+1
61 I ($P(S,U,17)>84)&($P(S,U,51)>44) S YSINDX=YSINDX+1
62 I $P(S,U,40)-$P(S,U,39)>9 S YSINDX=YSINDX+1
63 W !?2,"Malingering Index = ",YSINDX
64 S YSINDX=0 ; RESET
65 I $P(S,U,4)>44 S YSINDX=YSINDX+1 S:$P(S,U,4)>49 YSINDX=YSINDX+1
66 I $P(S,U,51)>44 S YSINDX=YSINDX+1
67 I $P(S,U,40)-$P(S,U,39)>9 S YSINDX=YSINDX+1
68 I $P(S,U,41)-$P(S,U,39)>9 S YSINDX=YSINDX+1
69 I $P(S,U,23)-$P(S,U,24)>9 S YSINDX=YSINDX+1
70 I $P(S,U,14)-$P(S,U,11)>9 S YSINDX=YSINDX+1
71 I $P(S,U,52)-$P(S,U,46)>14 S YSINDX=YSINDX+1
72 I $P(S,U,22)-$P(S,U,49)>9 S YSINDX=YSINDX+1
73 W !?2,"Defensivness Index = ",$J(YSINDX,3)
74XBAR ;
75 S YSINDX=0 F I=5,9,13,17,21,25,29,33,38,42,43 S YSINDX=YSINDX+$P(S,U,I)
76 W !?2,"Mean Clinical Elevation = ",$J(YSINDX/11,4,0)
77 Q
78FIT ;coeff of fit
79 W !!,"Database Profile",?30,"Coefficient of Fit"
80 K A F K=1:1:41 D FIT1
81 S N=0 F S N=$O(A(N)) Q:N'>0 S K=0 F S K=$O(A(N,K)) Q:K'>0 G DONE:YSLFT D:IOST?1"C-".E&($Y+4>IOSL) SCR^YTREPT D FITW
82 Q
83FITW W !,$P(^YTT(601,YSTEST,"G",1,1,K,0),U,1),?35,$J(9-N,6,3)
84 Q
85FIT1 S (X1,Y1,X12,Y12,YSXY)=0,N=1
86 S YSFIT=^YTT(601,YSTEST,"G",1,1,K,0)
87 F I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53 D FITLOOP
88 ;stanadrd dev t scores
89 S YSXBAR=X1/22
90 S YSXSD=$$SQRT^XLFMTH(X12/22-(YSXBAR*YSXBAR))
91 ;standard dev fit data
92 S YSYBAR=Y1/22
93 S YSYSD=$$SQRT^XLFMTH(Y12/22-(YSYBAR*YSYBAR))
94 ; CORR
95 S YSR=((YSXY/22)-(YSXBAR*YSYBAR))/(YSXSD*YSYSD)
96 S A(9-YSR,K)=""
97 Q
98FITLOOP ;get individual items
99 S N=N+1,X1=X1+$P(S,U,I),X12=X12+($P(S,U,I)*$P(S,U,I)),Y1=Y1+$P(YSFIT,U,N),Y12=Y12+($P(YSFIT,U,N)*$P(YSFIT,U,N)),YSXY=YSXY+($P(S,U,I)*$P(YSFIT,U,N))
100 Q
101CRIT ;
102 D RD,DTA^YTREPT
103 W !?10,"Critical Items",!!,"Delusions and Hallucinations"
104 F I=90,130,170,210,309 D CRITW
105 W !!,"Potential for Self-Harm" F I=100,183,206,220,340 D CRITW
106 W !!,"Potential for Aggression" F I=21,61,101,181 D CRITW
107 W !!,"Substance Abuse" F I=55,222 D CRITW
108 W !!,"Potential Malingering" F I=9,49,129,249 D CRITW
109 W !!,"Ureliability/Resistance" F I=31,71,311 D CRITW
110 W !!,"Traumatic Stressors" F I=34,114,194,274 D CRITW
111 Q
112CRITW ; write critical items
113 Q:$E(X,I)<2
114 W !,$S($E(X,I)=2:"ST",$E(X,I)=3:"MT",1:"VT")," "
115 W ^YTT(601,YSTEST,"Q",I,"T",1,0)
116 W:$D(^YTT(601,YSTEST,"Q",I,"T",2,0)) !?7,^YTT(601,YSTEST,"Q",I,"T",2,0)
117 Q
Note: See TracBrowser for help on using the repository browser.