YTPAI1 ;ALB/ASF-PAI TEST PROFILE ;11/7/95 13:45 ;
;;5.01;MENTAL HEALTH;**10**;Dec 30, 1994
A ;setup
K YSAST S YSTV=100,YSBV=28,YSINC=2,YSLE=5 F J=1:1:53 S A(J)=$P(S,U,J) S:A(J)>YSTV A(J)=YSTV S:A(J)<YSBV A(J)=YSBV S:A(J)#2 A(J)=A(J)-1
S YSVS=1,YSHS="100,70,50,28"
F I=1:1 S J=$P(YSHS,",",I) Q:J="" S H(I)=+J
S YSLC1=9999,YSLV=YSTV,YSIN2=YSINC/2
S YSHS=$O(H(-1)),H(-1)=-999
TOP ;
D DTA^YTREPT
W !!?30,"PAI Full Scale Profile"
W !?19,"1 2 3 4 5 6 7 8 9 10 11 A B C D E Y Z"
L ;loop thru graph
F I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53 S B(I)=(A(I)'<(YSLV-YSIN2))&(A(I)<(YSLV+YSIN2)) I $D(C(I)) S:(C(I)'<(YSLV-YSIN2))&(C(I)<(YSLV+YSIN2)) B(I)=2
S YSLL=$S(YSLV=100:">99",YSLV=98:98,YSLV=28:"<30",YSLV#10=0:YSLV,1:" ")
W ;
S YSWS=(H(YSHS)>(YSLV-YSIN2))&(H(YSHS)<(YSLV+YSIN2)) I YSWS D WS G:YSLFT END S YSHS=$O(H(YSHS))
I 'YSWS D WL G:YSLFT END
S YSLC1=YSLC1+1 S:YSLC1>YSLE YSLC1=1
I YSLV>YSBV S YSLV=YSLV-YSINC GOTO L
D BOTTOM
END ;
Q ;K A,B,YSA,YSTV,YSTVL,YSBV,YSINC,YSIN2,YSLE,YSVS,YSHS,V,H,YSLL,YSLC1,YSWS Q
WL ;
D:IOST?1"C-".E SCR^YTREPT:$Y>(IOSL-4) Q:YSUOUT!YSTOUT
W !,$J(YSLL,4),"|"
F I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53 S C=$S(A(I)>$P(^YTT(601,YSTEST,"S",I,"M"),U,3):" * ",1:" + ") W $S(B(I):C,1:" ") W:I=4!(I=43)!(I=51) "|"
W "|",YSLL Q
WS ;
D:IOST?1"C-".E SCR^YTREPT:$Y>(IOSL-4) Q:YSUOUT!YSTOUT
W !,$J(YSLL,4),"|"
F I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53 S C=$S(A(I)>$P(^YTT(601,YSTEST,"S",I,"M"),U,3):"-*-",1:"-+-") W $S(B(I):C,1:"---") W:I=4!(I=43)!(I=51) "|"
W "|",YSLL Q
Q
BOTTOM ;
Q:YSUOUT!YSTOUT
W !?6,"I I N P S A A D M P S B A A D A S S N R D W"
W !?6,"C N I I O N R E A A C O N L R G U T O X O R"
W !?6,"N F M M M X D P N R Z R T C G G I R N R M M"
TS ;
W !!?2,"T "
F I=1,3,5,13,21,29,38,43,48,50,52 W $S(I=5!(I=48)!(I=52):" ",1:""),$P(S,U,I)," "
W !?9 F I=2,4,9,17,25,33,42,44,49,51,53 W $S(I=9!(I=44)!(I=53):" ",1:""),$P(S,U,I)," "
RS ;
W !!," Raw " F I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53 W:I=5!(I=44)!(I=52) " " W $J($P(R,U,I),3)
D BTEXT
Q
IR ;responses
D RD^YTPAI
W !?30,"PAI Item Responses",!
F K=1:1:43 Q:YSLFT D:IOST?1"C-".E SCR^YTREPT:$Y+4>IOSL W ! F J=0:1:7 S I=J*43+K D IR1
Q
IR1 W $J(I,4),". "
IR2 W $S($E(X,I)=1:"F ",$E(X,I)=2:"ST",$E(X,I)=3:"MT",$E(X,I)=4:"VT",1:" X")," "
Q
SUBS ;sub scales
D DTA^YTREPT
W !!?25,"PAI Subscale Profile"
W !?38,"<+3 4 5 6 7 8 9 9>"
W !?30,"Raw T",?40,"0....0....0....0....0....0....0....9"
S YSLN=" | | "
S YSLAST="SOM"
F I=1:1:53 I $P(^YTT(601,YSTEST,"S",I,0),U,2)?3U1"-".E D SS1
D RD^YTPAI W !!?2,"Missing Items = ",$L(X,"X")-1
D BTEXT
Q
SS1 ;
D:IOST?1"C-".E SCR^YTREPT:$Y>(IOSL-4) Q:YSUOUT!YSTOUT
I YSLAST'=$E($P(^YTT(601,YSTEST,"S",I,0),U,2),1,3) W ! S YSLAST=$E($P(^YTT(601,YSTEST,"S",I,0),U,2),1,3)
W !?2,$P(^YTT(601,YSTEST,"S",I,0),U,2),?30,$J($P(R,U,I),3),$J($P(S,U,I),5)
S C=$S($P(S,U,I)>$P(^YTT(601,YSTEST,"S",I,"M"),U,3):"*",1:"+")
S Y1=$P(S,U,I),Y=$S(Y1>98:100,Y1<30:30,1:Y1) S:Y#2 Y=Y-1
S Y1=Y-30/2,YSLN1=$E(YSLN,1,Y1-1)_C_$E(YSLN,Y1+1,99)
W ?41,YSLN1
Q
BTEXT ;
W ! S Y=0 F S Y=$O(^YTT(601,YSTEST,"G",2,1,Y)) Q:Y'>0 W !,^(Y,0)
CC W !,"Copyright (c) 1989, 1990, 1991 by Psychological Assessment Resources Inc.",!,"Reproduced by permission."
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTPAI1 3466 printed Dec 13, 2024@02:17:58 Page 2
YTPAI1 ;ALB/ASF-PAI TEST PROFILE ;11/7/95 13:45 ;
+1 ;;5.01;MENTAL HEALTH;**10**;Dec 30, 1994
A ;setup
+1 KILL YSAST
SET YSTV=100
SET YSBV=28
SET YSINC=2
SET YSLE=5
FOR J=1:1:53
SET A(J)=$PIECE(S,U,J)
if A(J)>YSTV
SET A(J)=YSTV
if A(J)<YSBV
SET A(J)=YSBV
if A(J)#2
SET A(J)=A(J)-1
+2 SET YSVS=1
SET YSHS="100,70,50,28"
+3 FOR I=1:1
SET J=$PIECE(YSHS,",",I)
if J=""
QUIT
SET H(I)=+J
+4 SET YSLC1=9999
SET YSLV=YSTV
SET YSIN2=YSINC/2
+5 SET YSHS=$ORDER(H(-1))
SET H(-1)=-999
TOP ;
+1 DO DTA^YTREPT
+2 WRITE !!?30,"PAI Full Scale Profile"
+3 WRITE !?19,"1 2 3 4 5 6 7 8 9 10 11 A B C D E Y Z"
L ;loop thru graph
+1 FOR I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53
SET B(I)=(A(I)'<(YSLV-YSIN2))&(A(I)<(YSLV+YSIN2))
IF $DATA(C(I))
if (C(I)'<(YSLV-YSIN2))&(C(I)<(YSLV+YSIN2))
SET B(I)=2
+2 SET YSLL=$SELECT(YSLV=100:">99",YSLV=98:98,YSLV=28:"<30",YSLV#10=0:YSLV,1:" ")
W ;
+1 SET YSWS=(H(YSHS)>(YSLV-YSIN2))&(H(YSHS)<(YSLV+YSIN2))
IF YSWS
DO WS
if YSLFT
GOTO END
SET YSHS=$ORDER(H(YSHS))
+2 IF 'YSWS
DO WL
if YSLFT
GOTO END
+3 SET YSLC1=YSLC1+1
if YSLC1>YSLE
SET YSLC1=1
+4 IF YSLV>YSBV
SET YSLV=YSLV-YSINC
GOTO L
+5 DO BOTTOM
END ;
+1 ;K A,B,YSA,YSTV,YSTVL,YSBV,YSINC,YSIN2,YSLE,YSVS,YSHS,V,H,YSLL,YSLC1,YSWS Q
QUIT
WL ;
+1 if IOST?1"C-".E
if $Y>(IOSL-4)
DO SCR^YTREPT
if YSUOUT!YSTOUT
QUIT
+2 WRITE !,$JUSTIFY(YSLL,4),"|"
+3 FOR I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53
SET C=$SELECT(A(I)>$PIECE(^YTT(601,YSTEST,"S",I,"M"),U,3):" * ",1:" + ")
WRITE $SELECT(B(I):C,1:" ")
if I=4!(I=43)!(I=51)
WRITE "|"
+4 WRITE "|",YSLL
QUIT
WS ;
+1 if IOST?1"C-".E
if $Y>(IOSL-4)
DO SCR^YTREPT
if YSUOUT!YSTOUT
QUIT
+2 WRITE !,$JUSTIFY(YSLL,4),"|"
+3 FOR I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53
SET C=$SELECT(A(I)>$PIECE(^YTT(601,YSTEST,"S",I,"M"),U,3):"-*-",1:"-+-")
WRITE $SELECT(B(I):C,1:"---")
if I=4!(I=43)!(I=51)
WRITE "|"
+4 WRITE "|",YSLL
QUIT
+5 QUIT
BOTTOM ;
+1 if YSUOUT!YSTOUT
QUIT
+2 WRITE !?6,"I I N P S A A D M P S B A A D A S S N R D W"
+3 WRITE !?6,"C N I I O N R E A A C O N L R G U T O X O R"
+4 WRITE !?6,"N F M M M X D P N R Z R T C G G I R N R M M"
TS ;
+1 WRITE !!?2,"T "
+2 FOR I=1,3,5,13,21,29,38,43,48,50,52
WRITE $SELECT(I=5!(I=48)!(I=52):" ",1:""),$PIECE(S,U,I)," "
+3 WRITE !?9
FOR I=2,4,9,17,25,33,42,44,49,51,53
WRITE $SELECT(I=9!(I=44)!(I=53):" ",1:""),$PIECE(S,U,I)," "
RS ;
+1 WRITE !!," Raw "
FOR I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53
if I=5!(I=44)!(I=52)
WRITE " "
WRITE $JUSTIFY($PIECE(R,U,I),3)
+2 DO BTEXT
+3 QUIT
IR ;responses
+1 DO RD^YTPAI
+2 WRITE !?30,"PAI Item Responses",!
+3 FOR K=1:1:43
if YSLFT
QUIT
if IOST?1"C-".E
if $Y+4>IOSL
DO SCR^YTREPT
WRITE !
FOR J=0:1:7
SET I=J*43+K
DO IR1
+4 QUIT
IR1 WRITE $JUSTIFY(I,4),". "
IR2 WRITE $SELECT($EXTRACT(X,I)=1:"F ",$EXTRACT(X,I)=2:"ST",$EXTRACT(X,I)=3:"MT",$EXTRACT(X,I)=4:"VT",1:" X")," "
+1 QUIT
SUBS ;sub scales
+1 DO DTA^YTREPT
+2 WRITE !!?25,"PAI Subscale Profile"
+3 WRITE !?38,"<+3 4 5 6 7 8 9 9>"
+4 WRITE !?30,"Raw T",?40,"0....0....0....0....0....0....0....9"
+5 SET YSLN=" | | "
+6 SET YSLAST="SOM"
+7 FOR I=1:1:53
IF $PIECE(^YTT(601,YSTEST,"S",I,0),U,2)?3U1"-".E
DO SS1
+8 DO RD^YTPAI
WRITE !!?2,"Missing Items = ",$LENGTH(X,"X")-1
+9 DO BTEXT
+10 QUIT
SS1 ;
+1 if IOST?1"C-".E
if $Y>(IOSL-4)
DO SCR^YTREPT
if YSUOUT!YSTOUT
QUIT
+2 IF YSLAST'=$EXTRACT($PIECE(^YTT(601,YSTEST,"S",I,0),U,2),1,3)
WRITE !
SET YSLAST=$EXTRACT($PIECE(^YTT(601,YSTEST,"S",I,0),U,2),1,3)
+3 WRITE !?2,$PIECE(^YTT(601,YSTEST,"S",I,0),U,2),?30,$JUSTIFY($PIECE(R,U,I),3),$JUSTIFY($PIECE(S,U,I),5)
+4 SET C=$SELECT($PIECE(S,U,I)>$PIECE(^YTT(601,YSTEST,"S",I,"M"),U,3):"*",1:"+")
+5 SET Y1=$PIECE(S,U,I)
SET Y=$SELECT(Y1>98:100,Y1<30:30,1:Y1)
if Y#2
SET Y=Y-1
+6 SET Y1=Y-30/2
SET YSLN1=$EXTRACT(YSLN,1,Y1-1)_C_$EXTRACT(YSLN,Y1+1,99)
+7 WRITE ?41,YSLN1
+8 QUIT
BTEXT ;
+1 WRITE !
SET Y=0
FOR
SET Y=$ORDER(^YTT(601,YSTEST,"G",2,1,Y))
if Y'>0
QUIT
WRITE !,^(Y,0)
CC WRITE !,"Copyright (c) 1989, 1990, 1991 by Psychological Assessment Resources Inc.",!,"Reproduced by permission."
