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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI1 4016 printed Dec 13, 2024@02:14:46 Page 2
YSMTI1 ;ALB/ASF-PSYCH TEST DOWNLOAD REPORT MULTIPLE INST ;4/18/01 16:41
+1 ;;5.01;MENTAL HEALTH;**53,66,71**;Dec 30, 1994
BPRS SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
+1 SET R=""
FOR J=1:1:18
SET R=R_$EXTRACT(X,J)_"^"
+2 SET R1=0
FOR J=4,12,15
SET R1=R1+$EXTRACT(X,J)
+3 SET R=R_R1_"^"
SET R1=0
FOR J=2,5,9
SET R1=R1+$EXTRACT(X,J)
+4 SET R=R_R1_"^"
SET R1=0
FOR J=10,11,14
SET R1=R1+$EXTRACT(X,J)
+5 SET R=R_R1_"^"
SET R1=0
FOR J=3,13,16
SET R1=R1+$EXTRACT(X,J)
+6 SET R=R_R1_"^"
SET R1=0
FOR J=1:1:16
SET R1=R1+$EXTRACT(X,J)
+7 SET R=R_R1
QUIT
DOM ;depression screen ; asf 7/14/00
+1 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
+2 SET R=0
SET S="negative"
+3 if $EXTRACT(X,1)="Y"
SET R=1
SET S="positive"
+4 if ($EXTRACT(X,2)="Y")&($EXTRACT(X,3)="Y")&($EXTRACT(X,4)>1)
SET R=1
SET S="positive"
+5 QUIT
FIRO SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
FOR I=1:1:6
DO FSCR
+1 SET X=","
SET Y=R(1)_X_R(2)_X_R(3)_X_R(4)_X_R(5)_X_R(6)
KILL R
SET R=Y
QUIT
FSCR SET R(I)=0
SET Y=^YTT(601,YSTEST,"S",I,"K",1,0)
FOR J=1:2:17
SET YSIT=$PIECE(Y,"^",J)
SET YSIX=$PIECE(Y,"^",J+1)
if YSIX[$EXTRACT(X,YSIT)
SET R(I)=R(I)+1
+1 QUIT
BDI SET R=0
SET Z(1)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
FOR I=1:1:18,21,22
SET R=R+$EXTRACT(Z(1),I)
+1 if $EXTRACT(Z(1),20)="N"
SET R=R+$EXTRACT(Z(1),19)
KILL Z
+2 SET S=$SELECT(R<10:"asymptomatic",R<19:"mild-moderate",R<30:"moderate-severe",R>29:"extremely severe",1:"")
+3 QUIT
BECK SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
SET R=0
FOR I=1:1:21
SET R=$SELECT($EXTRACT(X,I)'="X":R+$EXTRACT(X,I)-1,1:R)
+1 QUIT
MATE SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
FOR I=1:1:10
DO MATE2
+1 SET YSRR=""
FOR I=1,3,5,6,8,10,2,4,7,9
SET YSRR=YSRR_R(I)_","
+2 KILL R
SET R=YSRR
KILL I,YSIT,YSIX,J,YSKK,YSRR,X,Y
QUIT
MATE2 SET R(I)=0
SET J=I
if I>5
SET J=J-5
SET Y=^YTT(601,YSTEST,"S",J,"K",1,0)
FOR J=1:2:17
SET YSIT=$PIECE(Y,"^",J)
SET YSIX=$PIECE(Y,"^",J+1)
if I>5
SET YSIT=YSIT+45
if YSIX[$EXTRACT(X,YSIT)
SET R(I)=R(I)+1
+1 QUIT
MCMI SET YSTY="TL"
DO ^YTREPT
DO YSSRT^YTMCMI
+1 IF $EXTRACT(YSSR,1)=4!($EXTRACT(YSSR,1,2)["7")
FOR J=9:1:13,15
SET YSRR(J)=YSRR(J)+$SELECT(J=9!(J=11):8,J=10:16,1:28)
SET YSAS(J)=$SELECT(J=9!(J=11):8,J=10:16,1:28)
+2 IF $EXTRACT(YSSR,1,2)["2"!($EXTRACT(YSSR,1,2)["8")
FOR J=9:1:11
SET YSRR(J)=YSRR(J)-9
if $DATA(YSAS(J))
SET YSAS(J)=YSAS(J)-9
if '$DATA(YSAS(J))
SET YSAS(J)=-9
+3 SET K=0
FOR J=1:1:8
SET K=K+$PIECE(R,"^",J)
+4 SET YSAD=$SELECT(K<110:110-K,K<132:0,1:131-K/3)
IF YSAD#1
SET YSAD=YSAD\1-1
+5 IF YSAD
FOR J=9:1:20
SET YSRR(J)=YSRR(J)+YSAD
SET YSWF(J)=YSAD
BOTH SET S=""
FOR J=1:1:21
SET S=S_YSRR(J)_"^"
+1 KILL A,B,I,J,K,X,YSAD,YSAS,YSBR,YSII,YSIT,YSKK,YSNAM,YSRR,YSRS,YSSC,YSSR,YSTY,YSXR,YSXX,YSWF
QUIT
MILL SET YSTY="TL"
DO ^YTREPT
DO YSSRT^YTMILL
+1 SET K=+$EXTRACT(YSSR,1)
SET YSAD=$SELECT(K=4:10,K=7:15,K=2:-10,K=8:-10,1:0)
+2 SET K=$EXTRACT(YSSR,1,2)
IF K="28"!(K="82")
SET YSAD=-15
+3 IF YSAD
FOR J=9:1:14
SET YSRR(J)=YSRR(J)+YSAD
+4 ; MCMI LOGIC AND CLEAN
GOTO BOTH
SCII SET YSRM=""
SET X3=^YTT(601,YSTEST,"G",1,1,1,0)
SET X1=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
SET X2=^(2)
FOR I=1:1:29
DO TSCR
+1 SET R(1)=$PIECE(YSRM,U,1,6)
SET R(2)=$PIECE(YSRM,U,7,15)
SET R(3)=$PIECE(YSRM,U,16,99)
SET R=""
+2 KILL 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
QUIT
TSCR SET YSKK=1
SET T=0
S1 IF $DATA(^YTT(601,YSTEST,"S",I,"K",YSKK,0))#2=0
SET X=^YTT(601,YSTEST,"S",I,"M")
SET T=$JUSTIFY((T-$PIECE(X,"^",1)/$PIECE(X,"^",2)*10+50),0,0)
KILL Y
SET YSRM=YSRM_T_"^"
if I#60
QUIT
SET YSRM=""
QUIT
+1 SET Y=^YTT(601,YSTEST,"S",I,"K",YSKK,0)
SET P=1
T1 SET YSIT=$PIECE(Y,"^",P)
IF YSIT=""
SET YSKK=YSKK+1
GOTO S1
+1 SET A=$PIECE(Y,"^",P+1)
SET P=P+2
SET M=$SELECT(YSIT<201:$EXTRACT(X1,YSIT),1:$EXTRACT(X2,YSIT-200))
if M?1N
SET T=T+$EXTRACT(A,M)-1
GOTO T1
MYER SET YSRP=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
FOR J=1:1:4,7,8
DO SCR
+1 if YSSX="F"
GOTO V0
FOR J=5,6
DO SCR
+2 SET R(5)=R(5)+1
GOTO V1
V0 FOR J=9,10
DO SCR
+1 SET R(5)=R(9)
SET R(6)=R(10)
V1 SET K=""
FOR J=1:1:8
SET K=K_R(J)_"^"
+1 IF R(1)>R(2)
SET YSTY=" E"
SET YSRT=R(1)-R(2)*2-1
+2 IF '$TEST
SET YSTY=" I"
SET YSRT=R(2)-R(1)*2+1
+3 IF R(3)>R(4)
SET YSTY=YSTY_" S"
SET YSRT=YSRT_"^"_(R(3)-R(4)*2-1)
+4 IF '$TEST
SET YSTY=YSTY_" N"
SET YSRT=YSRT_"^"_(R(4)-R(3)*2+1)
+5 IF R(5)>R(6)
SET YSTY=YSTY_" T"
SET YSRT=YSRT_"^"_(R(5)-R(6)*2-1)
+6 IF '$TEST
SET YSTY=YSTY_" F"
SET YSRT=YSRT_"^"_(R(6)-R(5)*2+1)
+7 IF R(7)>R(8)
SET YSTY=YSTY_" J"
SET YSRT=YSRT_"^"_(R(7)-R(8)*2-1)
+8 IF '$TEST
SET YSTY=YSTY_" P"
SET YSRT=YSRT_"^"_(R(8)-R(7)*2+1)
+9 KILL R,S
SET R=""
SET R(1)=YSRT
SET S=""
SET S(1)=$EXTRACT(YSTY,2)_U_$EXTRACT(YSTY,4)_U_$EXTRACT(YSTY,6)_U_$EXTRACT(YSTY,8)
END KILL I,YSIT,J,K,YSKK,L,P,YSRP,YSRT,T1,YSTY,W,X,Y,Z
QUIT
SCR SET R(J)=0
SET Y=^YTT(601,YSTEST,"S",J,"K",1,0)
+1 FOR Z=1:1
SET YSIT=$PIECE(Y,",",Z)
if YSIT=""
QUIT
SET L=$LENGTH(YSIT)
SET W=$EXTRACT(YSIT,L)
SET P=$EXTRACT(YSIT,L-1)
SET YSIT=+YSIT
if $EXTRACT(YSRP,YSIT)=P
SET R(J)=R(J)+W
+2 QUIT
