YTMCMI3 ;ALB/ASF-MCMI3 ;9/3/02  15:35
 ;;5.01;MENTAL HEALTH;**76**;Dec 30, 1994
MAIN ;
 N A,B,G,I,L1,L2,N,X,YSANS,YSDAS,YSDAS1,YSIN,YSSID,YSTOUT,YSUOUT,YSVFLAG
 D PTVAR^YSLRP
 D RD
 D RAW
 D VALIDITY
 D BR
 D DCA,LIMIT
 D ADA,LIMIT
 D INPTAD,LIMIT
 D DENIAL,LIMIT
 D:YSTY["*" REPT^YTMCMI3R
 Q
RD S X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
 S YSINPT=$E(X,176),YSDUR=$E(X,177)
 Q
VALIDITY ;check if ok to score
 S YSVFLAG=0
 I $L(X,"X")>11 S YSVFLAG="too many missing" Q
 I $P(R,U)>1 S YSVFLAG="V scale" Q
 I ($P(R,U,2)>178)!($P(R,U,2)<34) S YSVFLAG="X scale" Q
 I (YSAGE<18) S YSVFLAG="too young" Q
 Q
RAW ; raw scores
 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"
 F N=1,3:1:28 D
 . S G=^YTT(601,YSTEST,"S",N,"K",1,0),I=1
 . 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
 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)
 S G=$P(R,U,2) S $P(R,U,2)=$S(G#1>.49999999:G\1+1,1:G\1)
 Q
BR ;base rate scores
 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"
 F I=3:1:28 S $P(S,U,I)=$P(^YTT(601,YSTEST,"S",I,YSSEX),U,$P(R,U,I)+1)
 I $P(R,U,2)<40 S $P(S,U,2)=0 Q
 I $P(R,U,2)>169 S $P(S,U,2)=100 Q
 I $P(R,U,2)<100 S $P(S,U,2)=$P(^YTT(601,YSTEST,"S",2,"M"),U,$P(R,U,2)-39)
 I $P(R,U,2)>99 S $P(S,U,2)=$P(^YTT(601,YSTEST,"S",2,"MS"),U,$P(R,U,2)-99)
 Q
DCA ;disclosure adjustment
 ;1-8B
 S G=^YTT(601,YSTEST,"S",2,"MK")
 S X=$P(R,U,2)
 I X<37 S YSDVA=20
 I (X>36)&(X<61) S YSDVA=$P(G,U,X-36)
 I (X>60)&(X<124) S YSDVA=0
 I (X>123)&(X<172) S YSDVA=$P(G,U,X-98)*-1
 S:X>171 YSDVA=-20
 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
 ;S-PP
 S G=^YTT(601,YSTEST,"S",2,"FK")
 I X<39 S YSDVA1=10
 I (X>38)&(X<61) S YSDVA1=$P(G,U,X-38)
 I (X>60)&(X<124) S YSDVA1=0
 I (X>123)&(X<172) S YSDVA1=$P(G,U,X-100)*-1
 S:X>171 YSDVA1=-11
 F I=16:1:28 S $P(S,U,I)=$P(S,U,I)+YSDVA1
 Q
ADA ;anxiety/depression adjust
 S YSAX=$P(S,U,19),YSDD=$P(S,U,22)
 I (YSAX<75)&(YSDD<75) Q  ;-->out
 I (YSAX>74)&(YSDD<75) S YSADA=YSAX-75
 I (YSDD>74)&(YSAX<75) S YSADA=YSDD-75
 I (YSAX>74)&(YSDD>74) S YSADA=(YSAX-75)+(YSDD-75)
 I (YSINPT'="I")!(YSDUR>2) D T2
 I (YSINPT="I")&(YSDUR=1) D T3
 I (YSINPT="I")&(YSDUR=2) D T4
 I (YSINPT="I")&(YSDUR=0) D T2
 Q
T2 ;non inpt/long axis1
 S X=YSADA
 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)
 F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
 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)
 F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
 Q
T3 ;inpt dur<1 week
 S X=YSADA
 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)
 F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
 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)
 F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
 Q
T4 ;inpt dur1-4
 S X=YSADA
 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)
 F I=7,15,17 S $P(S,U,I)=$P(S,U,I)-X1
 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)
 F I=6,16 S $P(S,U,I)=$P(S,U,I)-X1
 Q
LIMIT ;set 0-115 range
 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
 Q
INPTAD ;inpatient adjustment
 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
 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
 Q
DENIAL ;denial/complaint
 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
 Q:(YSHI'=9)&(YSHI'=10)&(YSHI'=13)
 S YSBR="",YSHI="" F I=13,9,10 S:$P(S,U,I)>YSBR YSBR=$P(S,U,I),YSHI=I
 S $P(S,U,YSHI)=$P(S,U,YSHI)+8