Routine: YSMTI6

YSMTI6 ;ALB/ASF-MULTIPLE PSYCH TESTS NEW ;4/18/01  17:27

 ;;5.01;MENTAL HEALTH;**62,71**;Dec 30, 1994

AUDIT ;

 N I,X,N,X1

 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)

 S R=0 F I=1:1:8 S R=R+$E(X,I)

 S X1=$S($E(X,9)=1:2,$E(X,9)=2:4,1:0) S R=R+X1

 S X1=$S($E(X,10)=1:2,$E(X,10)=2:4,1:0) S R=R+X1

DOMG ;

 N I,X,YSMISS,YSDEP

 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)

 S (YSMISS,YSDEP)=0 F I=1:1:5 S YSDEP=YSDEP+$E(X,I) S:$E(X,I)="X" YSMISS=YSMISS+1

 I YSMISS=1 S YSDEP=YSDEP+(YSDEP/4)

 I YSMISS>1 S S="invalid"

 S R=YSDEP

PAI ;   ASF 4/18/01

 N A,B,J,YSICN,YSKK,YSMX,YSNUMX,YSTL

 S (R,S)="^",YSMX=4

 D RD

 Q:$L(X,"X")>18

 D SCOR,STND

 Q  ;--> OUT

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=2:1:53 I $D(^YTT(601,YSTEST,"S",YSKK,"K")) S Y=^YTT(601,YSTEST,"S",YSKK,"K",1,0),YSTL=0 D KK S $P(R,U,YSKK)=YSTL

FS ;full scales

 F I=5,9,13,17,21,25,29,33,38,44 S $P(R,U,I)=$P(R,U,I+1)+$P(R,U,I+2)+$P(R,U,I+3) S:I=33 $P(R,U,I)=$P(R,U,I)+$P(R,U,I+4)

ICNR ;score ICN

 S YSICN=0

 S Y=(5-$E(X,75))-(5-$E(X,115)) D A

 S Y=$E(X,4)-$E(X,44) D A

 S Y=$E(X,60)-$E(X,100) D A

 S Y=$E(X,145)-(5-$E(X,185)) D A

 S Y=$E(X,65)-(5-$E(X,246)) D A

 S Y=$E(X,102)-(5-$E(X,103)) D A

 S Y=$E(X,22)-(5-$E(X,142)) D A

 S Y=(5-$E(X,301))-$E(X,140) D A

 S Y=5-(5-$E(X,270))-$E(X,53) D A

 S Y=5-(5-$E(X,190))-$E(X,13) D A

 S $P(R,U,1)=YSICN

 S X=^YTT(601,YSTEST,"S",1,"M"),$P(S,U,1)=$J((YSICN-$P(X,U)/$P(X,U,2)*10+50),0,0)

A ;icn absolutes

 S:Y<0 Y=-Y S YSICN=YSICN+Y Q

KK S YSNUMX=0

 F I=1:2 Q:$P(Y,U,I)=""  S YSIT=$P(Y,U,I),A=$P(Y,U,I+1),B=$E(X,YSIT),YSTL=YSTL+$S(B="X":0,A="D":B-1,1:YSMX-B) S:B="X" YSNUMX=YSNUMX+1

 I (YSNUMX/(I-1))>.2 S YSTL="X"

STND ;stanard T scores

 F J=2:1:53 S A=$P(R,U,J) S:A?.N X=^YTT(601,YSTEST,"S",J,"M"),S(J)=$J((A-$P(X,U)/$P(X,U,2)*10+50),0,0) S:A="X" S(J)="X" S S=S_S(J)_U

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI6   1879     printed  Feb 18, 2025@23:41:08                                                                                                                                                                                                      Page 2

YSMTI6    ;ALB/ASF-MULTIPLE PSYCH TESTS NEW ;4/18/01  17:27

 +1       ;;5.01;MENTAL HEALTH;**62,71**;Dec 30, 1994

 +2        QUIT

AUDIT     ;

 +1        NEW I,X,N,X1

 +2        SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)

 +3        SET R=0

           FOR I=1:1:8

               SET R=R+$EXTRACT(X,I)

 +4        SET X1=$SELECT($EXTRACT(X,9)=1:2,$EXTRACT(X,9)=2:4,1:0)

           SET R=R+X1

 +5        SET X1=$SELECT($EXTRACT(X,10)=1:2,$EXTRACT(X,10)=2:4,1:0)

           SET R=R+X1

 +6        QUIT

DOMG      ;

 +1        NEW I,X,YSMISS,YSDEP

 +2        SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)

 +3        SET (YSMISS,YSDEP)=0

           FOR I=1:1:5

               SET YSDEP=YSDEP+$EXTRACT(X,I)

               if $EXTRACT(X,I)="X"

                   SET YSMISS=YSMISS+1

 +4        IF YSMISS=1

               SET YSDEP=YSDEP+(YSDEP/4)

 +5        IF YSMISS>1

               SET S="invalid"

 +6        SET R=YSDEP

 +7        QUIT

PAI       ;   ASF 4/18/01

 +1        NEW A,B,J,YSICN,YSKK,YSMX,YSNUMX,YSTL

 +2        SET (R,S)="^"

           SET YSMX=4

 +3        DO RD

 +4        if $LENGTH(X,"X")>18

               QUIT

 +5        DO SCOR

           DO STND

 +6       ;--> OUT

           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=2:1:53

               IF $DATA(^YTT(601,YSTEST,"S",YSKK,"K"))

                   SET Y=^YTT(601,YSTEST,"S",YSKK,"K",1,0)

                   SET YSTL=0

                   DO KK

                   SET $PIECE(R,U,YSKK)=YSTL

FS        ;full scales

 +1        FOR I=5,9,13,17,21,25,29,33,38,44

               SET $PIECE(R,U,I)=$PIECE(R,U,I+1)+$PIECE(R,U,I+2)+$PIECE(R,U,I+3)

               if I=33

                   SET $PIECE(R,U,I)=$PIECE(R,U,I)+$PIECE(R,U,I+4)

ICNR      ;score ICN

 +1        SET YSICN=0

 +2        SET Y=(5-$EXTRACT(X,75))-(5-$EXTRACT(X,115))

           DO A

 +3        SET Y=$EXTRACT(X,4)-$EXTRACT(X,44)

           DO A

 +4        SET Y=$EXTRACT(X,60)-$EXTRACT(X,100)

           DO A

 +5        SET Y=$EXTRACT(X,145)-(5-$EXTRACT(X,185))

           DO A

 +6        SET Y=$EXTRACT(X,65)-(5-$EXTRACT(X,246))

           DO A

 +7        SET Y=$EXTRACT(X,102)-(5-$EXTRACT(X,103))

           DO A

 +8        SET Y=$EXTRACT(X,22)-(5-$EXTRACT(X,142))

           DO A

 +9        SET Y=(5-$EXTRACT(X,301))-$EXTRACT(X,140)

           DO A

 +10       SET Y=5-(5-$EXTRACT(X,270))-$EXTRACT(X,53)

           DO A

 +11       SET Y=5-(5-$EXTRACT(X,190))-$EXTRACT(X,13)

           DO A

 +12       SET $PIECE(R,U,1)=YSICN

 +13       SET X=^YTT(601,YSTEST,"S",1,"M")

           SET $PIECE(S,U,1)=$JUSTIFY((YSICN-$PIECE(X,U)/$PIECE(X,U,2)*10+50),0,0)

 +14       QUIT

A         ;icn absolutes

 +1        if Y<0

               SET Y=-Y

           SET YSICN=YSICN+Y

           QUIT

KK         SET YSNUMX=0

 +1        FOR I=1:2

               if $PIECE(Y,U,I)=""

                   QUIT

               SET YSIT=$PIECE(Y,U,I)

               SET A=$PIECE(Y,U,I+1)

               SET B=$EXTRACT(X,YSIT)

               SET YSTL=YSTL+$SELECT(B="X":0,A="D":B-1,1:YSMX-B)

               if B="X"

                   SET YSNUMX=YSNUMX+1

 +2        IF (YSNUMX/(I-1))>.2

               SET YSTL="X"

 +3        QUIT

STND      ;stanard T scores

 +1        FOR J=2:1:53

               SET A=$PIECE(R,U,J)

               if A?.N

                   SET X=^YTT(601,YSTEST,"S",J,"M")

                   SET S(J)=$JUSTIFY((A-$PIECE(X,U)/$PIECE(X,U,2)*10+50),0,0)

               if A="X"

                   SET S(J)="X"

               SET S=S_S(J)_U

 +2        QUIT

YSMTI6.m