YSMTI7.m

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 ---YSMTI7   724     printed  Apr 09, 2024@21:22:28                                                                                                                                                                                                       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