source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSMTI1.m@ 794

YSMTI1 ;ALB/ASF-PSYCH TEST DOWNLOAD REPORT MULTIPLE INST ;4/18/01  16:41
 ;;5.01;MENTAL HEALTH;**53,66,71**;Dec 30, 1994
BPRS S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
 S R="" F J=1:1:18 S R=R_$E(X,J)_"^"
 S R1=0 F J=4,12,15 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=2,5,9 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=10,11,14 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=3,13,16 S R1=R1+$E(X,J)
 S R=R_R1_"^",R1=0 F J=1:1:16 S R1=R1+$E(X,J)
 S R=R_R1 Q
DOM ;depression screen ; asf 7/14/00
 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
 S R=0,S="negative"
 S:$E(X,1)="Y" R=1,S="positive"
 S:($E(X,2)="Y")&($E(X,3)="Y")&($E(X,4)>1) R=1,S="positive"
 Q
FIRO S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) F I=1:1:6 D FSCR
 S X=",",Y=R(1)_X_R(2)_X_R(3)_X_R(4)_X_R(5)_X_R(6) K R S R=Y Q
FSCR S R(I)=0,Y=^YTT(601,YSTEST,"S",I,"K",1,0) F J=1:2:17 S YSIT=$P(Y,"^",J),YSIX=$P(Y,"^",J+1) S:YSIX[$E(X,YSIT) R(I)=R(I)+1
 Q
BDI S R=0,Z(1)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1) F I=1:1:18,21,22 S R=R+$E(Z(1),I)
 S:$E(Z(1),20)="N" R=R+$E(Z(1),19) K Z
 S S=$S(R<10:"asymptomatic",R<19:"mild-moderate",R<30:"moderate-severe",R>29:"extremely severe",1:"")
 Q
BECK S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1),R=0 F I=1:1:21 S R=$S($E(X,I)'="X":R+$E(X,I)-1,1:R)
 Q
MATE S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) F I=1:1:10 D MATE2
 S YSRR="" F I=1,3,5,6,8,10,2,4,7,9 S YSRR=YSRR_R(I)_","
 K R S R=YSRR K I,YSIT,YSIX,J,YSKK,YSRR,X,Y Q
MATE2 S R(I)=0,J=I S:I>5 J=J-5 S Y=^YTT(601,YSTEST,"S",J,"K",1,0) F J=1:2:17 S YSIT=$P(Y,"^",J),YSIX=$P(Y,"^",J+1) S:I>5 YSIT=YSIT+45 S:YSIX[$E(X,YSIT) R(I)=R(I)+1
 Q
MCMI S YSTY="TL" D ^YTREPT,YSSRT^YTMCMI
 I $E(YSSR,1)=4!($E(YSSR,1,2)["7") F J=9:1:13,15 S YSRR(J)=YSRR(J)+$S(J=9!(J=11):8,J=10:16,1:28),YSAS(J)=$S(J=9!(J=11):8,J=10:16,1:28)
 I $E(YSSR,1,2)["2"!($E(YSSR,1,2)["8") F J=9:1:11 S YSRR(J)=YSRR(J)-9 S:$D(YSAS(J)) YSAS(J)=YSAS(J)-9 S:'$D(YSAS(J)) YSAS(J)=-9
 S K=0 F J=1:1:8 S K=K+$P(R,"^",J)
 S YSAD=$S(K<110:110-K,K<132:0,1:131-K/3) I YSAD#1 S YSAD=YSAD\1-1
 I YSAD F J=9:1:20 S YSRR(J)=YSRR(J)+YSAD,YSWF(J)=YSAD
BOTH S S="" F J=1:1:21 S S=S_YSRR(J)_"^"
 K A,B,I,J,K,X,YSAD,YSAS,YSBR,YSII,YSIT,YSKK,YSNAM,YSRR,YSRS,YSSC,YSSR,YSTY,YSXR,YSXX,YSWF Q
MILL S YSTY="TL" D ^YTREPT,YSSRT^YTMILL
 S K=+$E(YSSR,1),YSAD=$S(K=4:10,K=7:15,K=2:-10,K=8:-10,1:0)
 S K=$E(YSSR,1,2) I K="28"!(K="82") S YSAD=-15
 I YSAD F J=9:1:14 S YSRR(J)=YSRR(J)+YSAD
 G BOTH ; MCMI LOGIC AND CLEAN
SCII S YSRM="",X3=^YTT(601,YSTEST,"G",1,1,1,0),X1=^YTD(601.2,YSDFN,1,YSET,1,YSED,1),X2=^(2) F I=1:1:29 D TSCR
 S R(1)=$P(YSRM,U,1,6),R(2)=$P(YSRM,U,7,15),R(3)=$P(YSRM,U,16,99),R=""
 K A,G,YSLNE,I,YSIT,J,K,YSKK,L,M,N,P,YSPT,YSRM,YS10,YS25,YS50,YS75,YS90,YSBOX,YSOCNM,YSOCP,YSOCSX,YSOCAT,T,V,S,X,X1,X2,X3,X4,Y Q
TSCR S YSKK=1,T=0
S1 I $D(^YTT(601,YSTEST,"S",I,"K",YSKK,0))#2=0 S X=^YTT(601,YSTEST,"S",I,"M"),T=$J((T-$P(X,"^",1)/$P(X,"^",2)*10+50),0,0) K Y S YSRM=YSRM_T_"^" Q:I#60  S YSRM="" Q
 S Y=^YTT(601,YSTEST,"S",I,"K",YSKK,0),P=1
T1 S YSIT=$P(Y,"^",P) I YSIT="" S YSKK=YSKK+1 G S1
 S A=$P(Y,"^",P+1),P=P+2,M=$S(YSIT<201:$E(X1,YSIT),1:$E(X2,YSIT-200)) S:M?1N T=T+$E(A,M)-1 G T1
MYER S YSRP=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) F J=1:1:4,7,8 D SCR
 G:YSSX="F" V0 F J=5,6 D SCR
 S R(5)=R(5)+1 G V1
V0 F J=9,10 D SCR
 S R(5)=R(9),R(6)=R(10)
V1 S K="" F J=1:1:8 S K=K_R(J)_"^"
 I R(1)>R(2) S YSTY=" E",YSRT=R(1)-R(2)*2-1
 E  S YSTY=" I",YSRT=R(2)-R(1)*2+1
 I R(3)>R(4) S YSTY=YSTY_" S",YSRT=YSRT_"^"_(R(3)-R(4)*2-1)
 E  S YSTY=YSTY_" N",YSRT=YSRT_"^"_(R(4)-R(3)*2+1)
 I R(5)>R(6) S YSTY=YSTY_" T",YSRT=YSRT_"^"_(R(5)-R(6)*2-1)
 E  S YSTY=YSTY_" F",YSRT=YSRT_"^"_(R(6)-R(5)*2+1)
 I R(7)>R(8) S YSTY=YSTY_" J",YSRT=YSRT_"^"_(R(7)-R(8)*2-1)
 E  S YSTY=YSTY_" P",YSRT=YSRT_"^"_(R(8)-R(7)*2+1)
 K R,S S R="",R(1)=YSRT,S="",S(1)=$E(YSTY,2)_U_$E(YSTY,4)_U_$E(YSTY,6)_U_$E(YSTY,8)
END K I,YSIT,J,K,YSKK,L,P,YSRP,YSRT,T1,YSTY,W,X,Y,Z Q
SCR S R(J)=0,Y=^YTT(601,YSTEST,"S",J,"K",1,0)
 F Z=1:1 S YSIT=$P(Y,",",Z) Q:YSIT=""  S L=$L(YSIT),W=$E(YSIT,L),P=$E(YSIT,L-1),YSIT=+YSIT S:$E(YSRP,YSIT)=P R(J)=R(J)+W
 Q