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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1YSMTI1 ;ALB/ASF-PSYCH TEST DOWNLOAD REPORT MULTIPLE INST ;4/18/01 16:41
2 ;;5.01;MENTAL HEALTH;**53,66,71**;Dec 30, 1994
3BPRS S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
4 S R="" F J=1:1:18 S R=R_$E(X,J)_"^"
5 S R1=0 F J=4,12,15 S R1=R1+$E(X,J)
6 S R=R_R1_"^",R1=0 F J=2,5,9 S R1=R1+$E(X,J)
7 S R=R_R1_"^",R1=0 F J=10,11,14 S R1=R1+$E(X,J)
8 S R=R_R1_"^",R1=0 F J=3,13,16 S R1=R1+$E(X,J)
9 S R=R_R1_"^",R1=0 F J=1:1:16 S R1=R1+$E(X,J)
10 S R=R_R1 Q
11DOM ;depression screen ; asf 7/14/00
12 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
13 S R=0,S="negative"
14 S:$E(X,1)="Y" R=1,S="positive"
15 S:($E(X,2)="Y")&($E(X,3)="Y")&($E(X,4)>1) R=1,S="positive"
16 Q
17FIRO S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) F I=1:1:6 D FSCR
18 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
19FSCR 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
20 Q
21BDI 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)
22 S:$E(Z(1),20)="N" R=R+$E(Z(1),19) K Z
23 S S=$S(R<10:"asymptomatic",R<19:"mild-moderate",R<30:"moderate-severe",R>29:"extremely severe",1:"")
24 Q
25BECK 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)
26 Q
27MATE S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) F I=1:1:10 D MATE2
28 S YSRR="" F I=1,3,5,6,8,10,2,4,7,9 S YSRR=YSRR_R(I)_","
29 K R S R=YSRR K I,YSIT,YSIX,J,YSKK,YSRR,X,Y Q
30MATE2 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
31 Q
32MCMI S YSTY="TL" D ^YTREPT,YSSRT^YTMCMI
33 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)
34 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
35 S K=0 F J=1:1:8 S K=K+$P(R,"^",J)
36 S YSAD=$S(K<110:110-K,K<132:0,1:131-K/3) I YSAD#1 S YSAD=YSAD\1-1
37 I YSAD F J=9:1:20 S YSRR(J)=YSRR(J)+YSAD,YSWF(J)=YSAD
38BOTH S S="" F J=1:1:21 S S=S_YSRR(J)_"^"
39 K A,B,I,J,K,X,YSAD,YSAS,YSBR,YSII,YSIT,YSKK,YSNAM,YSRR,YSRS,YSSC,YSSR,YSTY,YSXR,YSXX,YSWF Q
40MILL S YSTY="TL" D ^YTREPT,YSSRT^YTMILL
41 S K=+$E(YSSR,1),YSAD=$S(K=4:10,K=7:15,K=2:-10,K=8:-10,1:0)
42 S K=$E(YSSR,1,2) I K="28"!(K="82") S YSAD=-15
43 I YSAD F J=9:1:14 S YSRR(J)=YSRR(J)+YSAD
44 G BOTH ; MCMI LOGIC AND CLEAN
45SCII 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
46 S R(1)=$P(YSRM,U,1,6),R(2)=$P(YSRM,U,7,15),R(3)=$P(YSRM,U,16,99),R=""
47 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
48TSCR S YSKK=1,T=0
49S1 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
50 S Y=^YTT(601,YSTEST,"S",I,"K",YSKK,0),P=1
51T1 S YSIT=$P(Y,"^",P) I YSIT="" S YSKK=YSKK+1 G S1
52 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
53MYER S YSRP=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) F J=1:1:4,7,8 D SCR
54 G:YSSX="F" V0 F J=5,6 D SCR
55 S R(5)=R(5)+1 G V1
56V0 F J=9,10 D SCR
57 S R(5)=R(9),R(6)=R(10)
58V1 S K="" F J=1:1:8 S K=K_R(J)_"^"
59 I R(1)>R(2) S YSTY=" E",YSRT=R(1)-R(2)*2-1
60 E S YSTY=" I",YSRT=R(2)-R(1)*2+1
61 I R(3)>R(4) S YSTY=YSTY_" S",YSRT=YSRT_"^"_(R(3)-R(4)*2-1)
62 E S YSTY=YSTY_" N",YSRT=YSRT_"^"_(R(4)-R(3)*2+1)
63 I R(5)>R(6) S YSTY=YSTY_" T",YSRT=YSRT_"^"_(R(5)-R(6)*2-1)
64 E S YSTY=YSTY_" F",YSRT=YSRT_"^"_(R(6)-R(5)*2+1)
65 I R(7)>R(8) S YSTY=YSTY_" J",YSRT=YSRT_"^"_(R(7)-R(8)*2-1)
66 E S YSTY=YSTY_" P",YSRT=YSRT_"^"_(R(8)-R(7)*2+1)
67 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)
68END K I,YSIT,J,K,YSKK,L,P,YSRP,YSRT,T1,YSTY,W,X,Y,Z Q
69SCR S R(J)=0,Y=^YTT(601,YSTEST,"S",J,"K",1,0)
70 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
71 Q
Note: See TracBrowser for help on using the repository browser.