YSMTI4 ;ALB/ASF PSYCH TEST DOWNLOAD MCMI2 ;7/23/99 09:42
;;5.01;MENTAL HEALTH;**53**;Dec 30, 1994
D DEM^VADPT S YSSEX=$P(VADM(5),U) K VADM
F0 S R="",J=1
T0 S L=200,M=0,YSKK=1,YSTL=0 G:J=27 STND D RD
T1 I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S R=R_YSTL_"^",J=J+1 G T0
S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
T2 S YSIT=$P(Y,"^",P) I YSIT="" S YSKK=YSKK+1 G T1
S A=$P(Y,"^",P+1),P=P+2
S:$E(X,+YSIT-M)=A YSTL=YSTL+(+$P(YSIT,"(",2)) G T2
RD S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q
STND S X=($P(R,U,7)*1.5)+($P(R,U,12)*1.5)+($P(R,U,4)*1.6)+($P(R,U,5)*1.6)+($P(R,U,6)*1.6)+($P(R,U,13)*1.6)+$P(R,U,8)+$P(R,U,9)+$P(R,U,10)+$P(R,U,11),X=$J(X,3,0)
S Y=^YTT(601,201,"S",1,YSSEX) F I=1:1 I X'>(+$P(Y,U,I)) S S=$P($P(Y,U,I),",",2) Q
S S=S_"^",$P(R,U,1)=X F J=2:1:25 S X=^YTT(601,YSTEST,"S",J,YSSX),A=$P(R,U,J),S1=$P(X,U,A+1) S:S1="" S1=$P(X,U,$L(X,U)) S S=S_S1_U
DC ;DIS C
S X=+R I X<145!(X>590)!((X>249)&(X<401)) G HDAA
I X>144,X<250 S YSCF=250-X\10 S:250-X/10#1 YSCF=YSCF+1 F I=4:1:25 S YSCF1=$S(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1),$P(S,U,I)=$P(S,U,I)+(YSCF*YSCF1\1)
I X>400,X<591 S YSCF=X-400\16 S:X-400/16#1 YSCF=YSCF+1 F I=4:1:25 S YSCF1=$S(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1),$P(S,U,I)=$P(S,U,I)-(YSCF1*YSCF\1)
HDAA ;DEP/ANX
D RD^YTMCMI2A S YSIO=$E(X,176),YSEP=$E(X,177) S:YSIO'="I" YSIO="O" S:YSEP'?1N YSEP=2
S YSAS=$P(S,U,17),YSDS=$P(S,U,20),Y=(YSAS-85)+(YSDS-85)
I YSEP=2,YSIO="I",YSAS>84,YSDS>84 S Y1=Y*.5\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=Y*.75\1 S:Y1>15 Y1=15 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP=1,YSAS>84,YSDS>84 S Y1=Y S:Y>25 Y1=25 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S:Y1>20 Y1=20 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP>2,YSAS>84,YSDS>84 S Y1=Y*.25\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=Y*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="O",YSAS>84,YSDS>84 S Y1=((YSAS-85)+(YSDS-85))\4 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=Y*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP=2,YSDS>84,YSAS<85 S Y1=YSDS-85*.5\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=YSDS-85*.75\1 S:Y1>15 Y1=15 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP=1,YSDS>84,YSAS<85 S Y1=YSDS-85 S:Y1>25 Y1=25 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S:Y1>20 Y1=20 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="I",YSEP>2,YSDS>84,YSAS<85 S Y1=YSDS-85*.25\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=YSDS-85*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
I YSIO="O",YSDS>84,YSAS<85 S Y1=YSDS-85*.25\1 S:Y1>15 Y1=15 S $P(S,U,5)=$P(S,U,5)-Y1,$P(S,U,13)=$P(S,U,13)-Y1 S Y1=YSDS-85*.5\1 S:Y1>10 Y1=10 S $P(S,U,15)=$P(S,U,15)-Y1
XYZ ;Y-Z C
S Y1=$P(S,U,2)-$P(S,U,3)/10,Y1=$J(Y1,0,0) S:Y1>10 Y1=10 S:Y1<-10 Y1=-10 F I=14,15,17,18,20 S $P(S,U,I)=$P(S,U,I)+Y1
DCA K YSS,YSS1,YSS2,^TMP("YT1",$J) F I=4:1:13 S ^TMP("YT1",$J,999-$P(S,U,I),I)=""
S Y1=$O(^TMP("YT1",$J,0)),Y2=0 F I=0:1 S Y2=$O(^TMP("YT1",$J,Y1,Y2)) Q:Y2'>0 S YSS1(Y2)=""
I I<2 S Y1=$O(^TMP("YT1",$J,Y1)),Y2=0 F I=0:1 S Y2=$O(^TMP("YT1",$J,Y1,Y2)) Q:Y2'>0 S YSS2(Y2)=""
TIES S YSS1="",YSS2="" I YSSEX="M" F I=13,4,7,9,10,6,8,11,12,5 S:$D(YSS1(I)) YSS1=YSS1_I_U S:$D(YSS2(I)) YSS2=YSS2_I_U
I YSSEX="F" F I=9,4,10,8,5,12,13,11,7,6 S:$D(YSS1(I)) YSS1=YSS1_I_U S:$D(YSS2(I)) YSS2=YSS2_I_U
S YSS=YSS1_YSS2
I +YSS=7!(+YSS=8)!(+YSS=11)!($P(YSS,U,2)=11) F I=14,15,16,17,20,18 S Y1=$S(I<16:4,I=16:2,I=18:13,1:15) S $P(S,U,I)=$P(S,U,I)+Y1
I +YSS=13!(+YSS=5)!($P(YSS,U,2)=5) F I=15,16,14,17,18,20 S Y1=$S(I=14:2,I<17:6,I=17:7,1:5) S $P(S,U,I)=$P(S,U,I)-Y1
SCP ; LAST COR
I YSIO="I",YSEP=1 F I="23,8","24,10","25,4" S $P(S,U,+I)=$P(S,U,+I)+$P(I,",",2)
I YSIO="I",(YSEP=2!(YSEP=0)) F I="23,5","24,7","25,2" S $P(S,U,+I)=$P(S,U,+I)+$P(I,",",2)
K Y,Y1,^TMP("YT1",$J) S S(1)=$P(S,U,1,13),S(2)=$P(S,U,14,26),R(1)=$P(R,U,1,13),R(2)=$P(R,U,14,26),(S,R)=""
K YSTY,X,Y,A,B,K,YSKK,L,L1,L2,M,J,YSIT,YSRS,YSSS,I,P,YSMX,YSTL,YSTTL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSMTI4 4033 printed Dec 13, 2024@02:14:49 Page 2
YSMTI4 ;ALB/ASF PSYCH TEST DOWNLOAD MCMI2 ;7/23/99 09:42
+1 ;;5.01;MENTAL HEALTH;**53**;Dec 30, 1994
+2 DO DEM^VADPT
SET YSSEX=$PIECE(VADM(5),U)
KILL VADM
F0 SET R=""
SET J=1
T0 SET L=200
SET M=0
SET YSKK=1
SET YSTL=0
if J=27
GOTO STND
DO RD
T1 IF '$DATA(^YTT(601,YSTEST,"S",J,"K",YSKK,0))
SET R=R_YSTL_"^"
SET J=J+1
GOTO T0
+1 SET Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0)
SET P=1
T2 SET YSIT=$PIECE(Y,"^",P)
IF YSIT=""
SET YSKK=YSKK+1
GOTO T1
+1 SET A=$PIECE(Y,"^",P+1)
SET P=P+2
+2 if $EXTRACT(X,+YSIT-M)=A
SET YSTL=YSTL+(+$PIECE(YSIT,"(",2))
GOTO T2
RD SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)
QUIT
STND SET X=($PIECE(R,U,7)*1.5)+($PIECE(R,U,12)*1.5)+($PIECE(R,U,4)*1.6)+($PIECE(R,U,5)*1.6)+($PIECE(R,U,6)*1.6)+($PIECE(R,U,13)*1.6)+$PIECE(R,U,8)+$PIECE(R,U,9)+$PIECE(R,U,10)+$PIECE(R,U,11)
SET X=$JUSTIFY(X,3,0)
+1 SET Y=^YTT(601,201,"S",1,YSSEX)
FOR I=1:1
IF X'>(+$PIECE(Y,U,I))
SET S=$PIECE($PIECE(Y,U,I),",",2)
QUIT
+2 SET S=S_"^"
SET $PIECE(R,U,1)=X
FOR J=2:1:25
SET X=^YTT(601,YSTEST,"S",J,YSSX)
SET A=$PIECE(R,U,J)
SET S1=$PIECE(X,U,A+1)
if S1=""
SET S1=$PIECE(X,U,$LENGTH(X,U))
SET S=S_S1_U
DC ;DIS C
+1 SET X=+R
IF X<145!(X>590)!((X>249)&(X<401))
GOTO HDAA
+2 IF X>144
IF X<250
SET YSCF=250-X\10
if 250-X/10#1
SET YSCF=YSCF+1
FOR I=4:1:25
SET YSCF1=$SELECT(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1)
SET $PIECE(S,U,I)=$PIECE(S,U,I)+(YSCF*YSCF1\1)
+3 IF X>400
IF X<591
SET YSCF=X-400\16
if X-400/16#1
SET YSCF=YSCF+1
FOR I=4:1:25
SET YSCF1=$SELECT(I=14:.5,I=15:.5,I=16:.5,I=23:.5,I=24:.5,I=25:.5,1:1)
SET $PIECE(S,U,I)=$PIECE(S,U,I)-(YSCF1*YSCF\1)
HDAA ;DEP/ANX
+1 DO RD^YTMCMI2A
SET YSIO=$EXTRACT(X,176)
SET YSEP=$EXTRACT(X,177)
if YSIO'="I"
SET YSIO="O"
if YSEP'?1N
SET YSEP=2
+2 SET YSAS=$PIECE(S,U,17)
SET YSDS=$PIECE(S,U,20)
SET Y=(YSAS-85)+(YSDS-85)
+3 IF YSEP=2
IF YSIO="I"
IF YSAS>84
IF YSDS>84
SET Y1=Y*.5\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=Y*.75\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+4 IF YSIO="I"
IF YSEP=1
IF YSAS>84
IF YSDS>84
SET Y1=Y
if Y>25
SET Y1=25
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
if Y1>20
SET Y1=20
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+5 IF YSIO="I"
IF YSEP>2
IF YSAS>84
IF YSDS>84
SET Y1=Y*.25\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=Y*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+6 IF YSIO="O"
IF YSAS>84
IF YSDS>84
SET Y1=((YSAS-85)+(YSDS-85))\4
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=Y*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+7 IF YSIO="I"
IF YSEP=2
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85*.5\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=YSDS-85*.75\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+8 IF YSIO="I"
IF YSEP=1
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85
if Y1>25
SET Y1=25
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
if Y1>20
SET Y1=20
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+9 IF YSIO="I"
IF YSEP>2
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85*.25\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=YSDS-85*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
+10 IF YSIO="O"
IF YSDS>84
IF YSAS<85
SET Y1=YSDS-85*.25\1
if Y1>15
SET Y1=15
SET $PIECE(S,U,5)=$PIECE(S,U,5)-Y1
SET $PIECE(S,U,13)=$PIECE(S,U,13)-Y1
SET Y1=YSDS-85*.5\1
if Y1>10
SET Y1=10
SET $PIECE(S,U,15)=$PIECE(S,U,15)-Y1
XYZ ;Y-Z C
+1 SET Y1=$PIECE(S,U,2)-$PIECE(S,U,3)/10
SET Y1=$JUSTIFY(Y1,0,0)
if Y1>10
SET Y1=10
if Y1<-10
SET Y1=-10
FOR I=14,15,17,18,20
SET $PIECE(S,U,I)=$PIECE(S,U,I)+Y1
DCA KILL YSS,YSS1,YSS2,^TMP("YT1",$JOB)
FOR I=4:1:13
SET ^TMP("YT1",$JOB,999-$PIECE(S,U,I),I)=""
+1 SET Y1=$ORDER(^TMP("YT1",$JOB,0))
SET Y2=0
FOR I=0:1
SET Y2=$ORDER(^TMP("YT1",$JOB,Y1,Y2))
if Y2'>0
QUIT
SET YSS1(Y2)=""
+2 IF I<2
SET Y1=$ORDER(^TMP("YT1",$JOB,Y1))
SET Y2=0
FOR I=0:1
SET Y2=$ORDER(^TMP("YT1",$JOB,Y1,Y2))
if Y2'>0
QUIT
SET YSS2(Y2)=""
TIES SET YSS1=""
SET YSS2=""
IF YSSEX="M"
FOR I=13,4,7,9,10,6,8,11,12,5
if $DATA(YSS1(I))
SET YSS1=YSS1_I_U
if $DATA(YSS2(I))
SET YSS2=YSS2_I_U
+1 IF YSSEX="F"
FOR I=9,4,10,8,5,12,13,11,7,6
if $DATA(YSS1(I))
SET YSS1=YSS1_I_U
if $DATA(YSS2(I))
SET YSS2=YSS2_I_U
+2 SET YSS=YSS1_YSS2
+3 IF +YSS=7!(+YSS=8)!(+YSS=11)!($PIECE(YSS,U,2)=11)
FOR I=14,15,16,17,20,18
SET Y1=$SELECT(I<16:4,I=16:2,I=18:13,1:15)
SET $PIECE(S,U,I)=$PIECE(S,U,I)+Y1
+4 IF +YSS=13!(+YSS=5)!($PIECE(YSS,U,2)=5)
FOR I=15,16,14,17,18,20
SET Y1=$SELECT(I=14:2,I<17:6,I=17:7,1:5)
SET $PIECE(S,U,I)=$PIECE(S,U,I)-Y1
SCP ; LAST COR
+1 IF YSIO="I"
IF YSEP=1
FOR I="23,8","24,10","25,4"
SET $PIECE(S,U,+I)=$PIECE(S,U,+I)+$PIECE(I,",",2)
+2 IF YSIO="I"
IF (YSEP=2!(YSEP=0))
FOR I="23,5","24,7","25,2"
SET $PIECE(S,U,+I)=$PIECE(S,U,+I)+$PIECE(I,",",2)
+3 KILL Y,Y1,^TMP("YT1",$JOB)
SET S(1)=$PIECE(S,U,1,13)
SET S(2)=$PIECE(S,U,14,26)
SET R(1)=$PIECE(R,U,1,13)
SET R(2)=$PIECE(R,U,14,26)
SET (S,R)=""
+4 KILL YSTY,X,Y,A,B,K,YSKK,L,L1,L2,M,J,YSIT,YSRS,YSSS,I,P,YSMX,YSTL,YSTTL
QUIT
