YTACL ; REL - ADJECTIVE CHECK LIST ; 4/1/86 12:29 PM ;
;;5.01;MENTAL HEALTH;;Dec 30, 1994
;
S R="",J=1,X(1)=^YTD(601.2,YSDFN,1,YSET,1,YSED,1),X(2)=^(2)
T0 ;
S YSKK=1,YSTL=0
T1 ;
I $D(^YTT(601,YSTEST,"S",J,"K",YSKK,0))#2=0 S R=R_YSTL_"^",J=J+1 G T0:J<26,TD
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 M=$S(YSIT<201:$E(X(1),YSIT),1:$E(X(2),YSIT-200))
S:M="T" YSTL=YSTL+$S(A="T":1,1:-1) G T2
TD ;
S YSTL=0 F I=1:1:200 S:$E(X(1),I)="T" YSTL=YSTL+1
F I=1:1:100 S:$E(X(2),I)="T" YSTL=YSTL+1
I YSSX="M" S R=YSTL_"^"_$P(R,"^",1)_"^"_$P(R,"^",3,24),A=$S(YSTL<76:1,YSTL<96:3,YSTL<122:5,1:7)
E S R=YSTL_"^"_$P(R,"^",2,23)_"^"_$P(R,"^",25),A=$S(YSTL<79:1,YSTL<99:3,YSTL<120:5,1:7)
S S="",J=1 I '$D(YSSX) W !?5,"Patient's sex unknown",!,$C(7) H 3 Q
I YSSX="M"!(YSSX="F") S P=YSSX
E W !!?5,"Patient's sex NOT defined correctly",!,$C(7) H 3 Q
S1 ;
S M=$P(R,"^",J) G:M="" REPT
S X=^YTT(601,YSTEST,"S",J,P),S=S_$J((M-$P(X,"^",A)/$P(X,"^",A+1)*10+50),0,0)_"^",J=J+1 G S1
REPT ;
S ^YTD(601.2,YSDFN,1,YSET,1,YSED,100)=S,J=1 W @IOF,YSHDR,!!?22,$P(^YTT(601,YSTEST,"P"),"^",1),!!!?24,"S C A L E",?43,"RAW",?51,"T",!
R1 ;
S YSRS=$P(R,"^",J) I YSRS="" W ! K A,I,YSIT,J,YSKK,M,P,R,YSRS,S,YSSS,YSTL,X,Y Q
S YSSS=$P(S,"^",J) W !?19,$P(^YTT(601,YSTEST,"S",J,0),"^",2),?43,$J(YSRS,4,0),?49,$J(YSSS,4,0)
S J=J+1 G R1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTACL 1420 printed Sep 23, 2025@19:52:45 Page 2
YTACL ; REL - ADJECTIVE CHECK LIST ; 4/1/86 12:29 PM ;
+1 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
+2 ;
+3 SET R=""
SET J=1
SET X(1)=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
SET X(2)=^(2)
T0 ;
+1 SET YSKK=1
SET YSTL=0
T1 ;
+1 IF $DATA(^YTT(601,YSTEST,"S",J,"K",YSKK,0))#2=0
SET R=R_YSTL_"^"
SET J=J+1
if J<26
GOTO T0
GOTO TD
+2 SET Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0)
SET P=1
T2 ;
+1 SET YSIT=$PIECE(Y,"^",P)
IF YSIT=""
SET YSKK=YSKK+1
GOTO T1
+2 SET A=$PIECE(Y,"^",P+1)
SET P=P+2
+3 SET M=$SELECT(YSIT<201:$EXTRACT(X(1),YSIT),1:$EXTRACT(X(2),YSIT-200))
+4 if M="T"
SET YSTL=YSTL+$SELECT(A="T":1,1:-1)
GOTO T2
TD ;
+1 SET YSTL=0
FOR I=1:1:200
if $EXTRACT(X(1),I)="T"
SET YSTL=YSTL+1
+2 FOR I=1:1:100
if $EXTRACT(X(2),I)="T"
SET YSTL=YSTL+1
+3 IF YSSX="M"
SET R=YSTL_"^"_$PIECE(R,"^",1)_"^"_$PIECE(R,"^",3,24)
SET A=$SELECT(YSTL<76:1,YSTL<96:3,YSTL<122:5,1:7)
+4 IF '$TEST
SET R=YSTL_"^"_$PIECE(R,"^",2,23)_"^"_$PIECE(R,"^",25)
SET A=$SELECT(YSTL<79:1,YSTL<99:3,YSTL<120:5,1:7)
+5 SET S=""
SET J=1
IF '$DATA(YSSX)
WRITE !?5,"Patient's sex unknown",!,$CHAR(7)
HANG 3
QUIT
+6 IF YSSX="M"!(YSSX="F")
SET P=YSSX
+7 IF '$TEST
WRITE !!?5,"Patient's sex NOT defined correctly",!,$CHAR(7)
HANG 3
QUIT
S1 ;
+1 SET M=$PIECE(R,"^",J)
if M=""
GOTO REPT
+2 SET X=^YTT(601,YSTEST,"S",J,P)
SET S=S_$JUSTIFY((M-$PIECE(X,"^",A)/$PIECE(X,"^",A+1)*10+50),0,0)_"^"
SET J=J+1
GOTO S1
REPT ;
+1 SET ^YTD(601.2,YSDFN,1,YSET,1,YSED,100)=S
SET J=1
WRITE @IOF,YSHDR,!!?22,$PIECE(^YTT(601,YSTEST,"P"),"^",1),!!!?24,"S C A L E",?43,"RAW",?51,"T",!
R1 ;
+1 SET YSRS=$PIECE(R,"^",J)
IF YSRS=""
WRITE !
KILL A,I,YSIT,J,YSKK,M,P,R,YSRS,S,YSSS,YSTL,X,Y
QUIT
+2 SET YSSS=$PIECE(S,"^",J)
WRITE !?19,$PIECE(^YTT(601,YSTEST,"S",J,0),"^",2),?43,$JUSTIFY(YSRS,4,0),?49,$JUSTIFY(YSSS,4,0)
+3 SET J=J+1
GOTO R1
