- 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 Feb 18, 2025@23:44:15 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."
