YSMTI7 ;ALB/ASF MULTIPLE TEST SCORING ;4/18/01 17:57
;;5.01;MENTAL HEALTH;**71**;Dec 30, 1994
Q
NEOPI ; ASF 4/18/01
N X,Y,YSKK,YSMX,YSIT,YSTL,YSXK
K S,R S R="",S="",YSXK="",YSMX=5
D RD Q:$L($E(X,1,240),"X")>42 ;---> OUT
D SCOR,STND
Q
RD S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)_^YTD(601.2,YSDFN,1,YSET,1,YSED,2) Q
SCOR ;
F YSKK=1:1:30 S Y=^YTT(601,YSTEST,"S",YSKK,"K",1,0),YSTL=0,YSTX=0 D KK S R=R_YSTL_U,YSXK=YSXK_YSTX_U
Q
KK F I=1:2:15 S YSIT=$P(Y,U,I),A=$P(Y,U,I+1),B=$E(X,YSIT),YSTL=YSTL+$S(B="X":2,A="D":B-1,1:YSMX-B) S:B="X" YSTX=YSTX+1
Q
STND ;stanard T scores
F J=1:1:30 S A=$P(R,U,J) S X=^YTT(601,YSTEST,"S",J,YSSX),S(J)=$J((A-$P(X,U)/$P(X,U,2)*10+50),0,0),S=S_S(J)_U
D NF^YTNEOPI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI7 724 printed Nov 22, 2024@17:24:53 Page 2
YSMTI7 ;ALB/ASF MULTIPLE TEST SCORING ;4/18/01 17:57
+1 ;;5.01;MENTAL HEALTH;**71**;Dec 30, 1994
+2 QUIT
NEOPI ; ASF 4/18/01
+1 NEW X,Y,YSKK,YSMX,YSIT,YSTL,YSXK
+2 KILL S,R
SET R=""
SET S=""
SET YSXK=""
SET YSMX=5
+3 ;---> OUT
DO RD
if $LENGTH($EXTRACT(X,1,240),"X")>42
QUIT
+4 DO SCOR
DO STND
+5 QUIT
RD SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)_^YTD(601.2,YSDFN,1,YSET,1,YSED,2)
QUIT
SCOR ;
+1 FOR YSKK=1:1:30
SET Y=^YTT(601,YSTEST,"S",YSKK,"K",1,0)
SET YSTL=0
SET YSTX=0
DO KK
SET R=R_YSTL_U
SET YSXK=YSXK_YSTX_U
+2 QUIT
KK FOR I=1:2:15
SET YSIT=$PIECE(Y,U,I)
SET A=$PIECE(Y,U,I+1)
SET B=$EXTRACT(X,YSIT)
SET YSTL=YSTL+$SELECT(B="X":2,A="D":B-1,1:YSMX-B)
if B="X"
SET YSTX=YSTX+1
+1 QUIT
STND ;stanard T scores
+1 FOR J=1:1:30
SET A=$PIECE(R,U,J)
SET X=^YTT(601,YSTEST,"S",J,YSSX)
SET S(J)=$JUSTIFY((A-$PIECE(X,U)/$PIECE(X,U,2)*10+50),0,0)
SET S=S_S(J)_U
+2 DO NF^YTNEOPI
+3 QUIT
