source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMCMI3.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1YTMCMI3 ;ALB/ASF-MCMI3 ;9/3/02 15:35
2 ;;5.01;MENTAL HEALTH;**76**;Dec 30, 1994
3MAIN ;
4 N A,B,G,I,L1,L2,N,X,YSANS,YSDAS,YSDAS1,YSIN,YSSID,YSTOUT,YSUOUT,YSVFLAG
5 D PTVAR^YSLRP
6 D RD
7 D RAW
8 D VALIDITY
9 D BR
10 D DCA,LIMIT
11 D ADA,LIMIT
12 D INPTAD,LIMIT
13 D DENIAL,LIMIT
14 D:YSTY["*" REPT^YTMCMI3R
15 Q
16RD S X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
17 S YSINPT=$E(X,176),YSDUR=$E(X,177)
18 Q
19VALIDITY ;check if ok to score
20 S YSVFLAG=0
21 I $L(X,"X")>11 S YSVFLAG="too many missing" Q
22 I $P(R,U)>1 S YSVFLAG="V scale" Q
23 I ($P(R,U,2)>178)!($P(R,U,2)<34) S YSVFLAG="X scale" Q
24 I (YSAGE<18) S YSVFLAG="too young" Q
25 Q
26RAW ; raw scores
27 S R="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
28 F N=1,3:1:28 D
29 . S G=^YTT(601,YSTEST,"S",N,"K",1,0),I=1
30 . F S YSIN=$P(G,U,I),YSANS=$E($P(G,U,I+1),1),YSWT=$P($P(G,U,I+1),";",2),I=I+2 Q:YSIN="" S:$E(X,YSIN)=YSANS $P(R,U,N)=$P(R,U,N)+YSWT
31 F I=5:1:15 S:I'=10 $P(R,U,2)=$P(R,U,2)+$P(R,U,I) S:I=10 $P(R,U,2)=$P(R,U,2)+($P(R,U,I)*.666666)
32 S G=$P(R,U,2) S $P(R,U,2)=$S(G#1>.49999999:G\1+1,1:G\1)
33 Q
34BR ;base rate scores
35 S S="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
36 F I=3:1:28 S $P(S,U,I)=$P(^YTT(601,YSTEST,"S",I,YSSEX),U,$P(R,U,I)+1)
37 I $P(R,U,2)<40 S $P(S,U,2)=0 Q
38 I $P(R,U,2)>169 S $P(S,U,2)=100 Q
39 I $P(R,U,2)<100 S $P(S,U,2)=$P(^YTT(601,YSTEST,"S",2,"M"),U,$P(R,U,2)-39)
40 I $P(R,U,2)>99 S $P(S,U,2)=$P(^YTT(601,YSTEST,"S",2,"MS"),U,$P(R,U,2)-99)
41 Q
42DCA ;disclosure adjustment
43 ;1-8B
44 S G=^YTT(601,YSTEST,"S",2,"MK")
45 S X=$P(R,U,2)
46 I X<37 S YSDVA=20
47 I (X>36)&(X<61) S YSDVA=$P(G,U,X-36)
48 I (X>60)&(X<124) S YSDVA=0
49 I (X>123)&(X<172) S YSDVA=$P(G,U,X-98)*-1
50 S:X>171 YSDVA=-20
51 F I=5:1:15 S $P(S,U,I)=$P(S,U,I)+YSDVA S:$P(S,U,I)<0 $P(S,U,I)=0 S:$P(S,U,I)>115 $P(S,U,I)=115
52 ;S-PP
53 S G=^YTT(601,YSTEST,"S",2,"FK")
54 I X<39 S YSDVA1=10
55 I (X>38)&(X<61) S YSDVA1=$P(G,U,X-38)
56 I (X>60)&(X<124) S YSDVA1=0
57 I (X>123)&(X<172) S YSDVA1=$P(G,U,X-100)*-1
58 S:X>171 YSDVA1=-11
59 F I=16:1:28 S $P(S,U,I)=$P(S,U,I)+YSDVA1
60 Q
61ADA ;anxiety/depression adjust
62 S YSAX=$P(S,U,19),YSDD=$P(S,U,22)
63 I (YSAX<75)&(YSDD<75) Q ;-->out
64 I (YSAX>74)&(YSDD<75) S YSADA=YSAX-75
65 I (YSDD>74)&(YSAX<75) S YSADA=YSDD-75
66 I (YSAX>74)&(YSDD>74) S YSADA=(YSAX-75)+(YSDD-75)
67 I (YSINPT'="I")!(YSDUR>2) D T2
68 I (YSINPT="I")&(YSDUR=1) D T3
69 I (YSINPT="I")&(YSDUR=2) D T4
70 I (YSINPT="I")&(YSDUR=0) D T2
71 Q
72T2 ;non inpt/long axis1
73 S X=YSADA
74 S X1=$S(X<10:1,X<15:2,X<20:3,X<25:4,X<30:5,X<35:6,X<40:7,X<45:8,X<50:9,X<55:10,X<60:11,X<65:12,X<70:13,X<75:14,X<81:15,1:0)
75 F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
76 S X1=$S(X<16:1,X<24:2,X<32:3,X<40:4,X<48:5,X<56:6,X<64:7,X<72:8,X<80:9,X=80:10,1:0)
77 F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
78 Q
79T3 ;inpt dur<1 week
80 S X=YSADA
81 S X1=$S(X<5:1,X<8:2,X<10:3,X<13:4,X<15:5,X<18:6,X<20:7,X<23:8,X<25:9,X<28:10,X<30:11,X<33:12,X<35:13,X<38:14,X<81:15,1:0)
82 F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
83 S X1=$S(X<8:1,X<12:2,X<16:3,X<20:4,X<24:5,X<28:6,X<32:7,X<36:8,X<40:9,X<44:10,X<48:11,X<53:12,X<56:13,X<60:14,X<81:15,1:0)
84 F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
85 Q
86T4 ;inpt dur1-4
87 S X=YSADA
88 S X1=$S(X<7:1,X<10:2,X<14:3,X<17:4,X<20:5,X<24:6,X<27:7,X<30:8,X<34:9,X<37:10,X<40:11,X<44:12,X<47:13,X<50:14,X<81:15,1:0)
89 F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
90 S X1=$S(X<11:1,X<16:2,X<22:3,X<27:4,X<32:5,X<38:6,X<43:7,X<48:8,X<54:9,X<59:10,X<64:11,X<70:12,X<75:13,X<80:14,X=80:15,1:0)
91 F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
92 Q
93LIMIT ;set 0-115 range
94 F I=1:1:28 S:$P(S,U,I)<0 $P(S,U,I)=0 S:$P(S,U,I)>115 $P(S,U,I)=115
95 Q
96INPTAD ;inpatient adjustment
97 I (YSINPT="I")&(YSDUR=1) S $P(S,U,26)=$P(S,U,26)+6,$P(S,U,27)=$P(S,U,27)+10,$P(S,U,28)=$P(S,U,28)+4
98 I (YSINPT="I")&(YSDUR=2) S $P(S,U,26)=$P(S,U,26)+4,$P(S,U,27)=$P(S,U,27)+8,$P(S,U,28)=$P(S,U,28)+2
99 Q
100DENIAL ;denial/complaint
101 S YSBR="",YSHI="" F I=7,11,15,12,6,14,13,9,10,8,5 S:$P(S,U,I)>YSBR YSBR=$P(S,U,I),YSHI=I
102 Q:(YSHI'=9)&(YSHI'=10)&(YSHI'=13)
103 S YSBR="",YSHI="" F I=13,9,10 S:$P(S,U,I)>YSBR YSBR=$P(S,U,I),YSHI=I
104 S $P(S,U,YSHI)=$P(S,U,YSHI)+8
Note: See TracBrowser for help on using the repository browser.