YSMTI6 ;ALB/ASF-MULTIPLE PSYCH TESTS NEW ;4/18/01 17:27
;;5.01;MENTAL HEALTH;**62,71**;Dec 30, 1994
Q
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
Q
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
Q
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)
Q
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"
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI6 1879 printed Dec 13, 2024@02:14:51 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
