YTPAI ;ASF/ALB- PAI TEST ;7/14/00 10:26
;;5.01;MENTAL HEALTH;**10,66,221,238**;Dec 30, 1994;Build 25
;
;Reference to $$SQRT^XLFMTH supported by IA #10105
;
S YSLFT=0,YSNOITEM="DONE^YTPAI"
MAIN ;
S (R,S)="^",YSMX=4
D RD
I $L(X,"X")>18 D DTA^YTREPT W !!!!,"PAI: Too many missing items to score" D:IOST?1"C".E SCR^YTREPT G OUT
D SCOR,STND
D ^YTPAI1 ;profile
G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
D SUBS^YTPAI1
G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
D ADDIT
D FIT
G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
D CRIT ;critical items
G DONE:YSLFT D:IOST?1"C-".E SCR^YTREPT
OUT D DTA^YTREPT,IR^YTPAI1
DONE K S,R,A,YSXBAR,YSYBAR,YSXSD,YSYSD Q
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
ADDIT ;additional indexes
D DTA^YTREPT
S YSINDX=0
I $P(S,U,3)>109 S YSINDX=YSINDX+1
I $P(S,U,3)-$P(S,U,2)>19 S YSINDX=YSINDX+1
I $P(S,U,2)-$P(S,U,1)>14 S YSINDX=YSINDX+1 ;asf 7/14/00 =YSINDX+2
I $P(S,U,27)-$P(S,U,26)>14 S YSINDX=YSINDX+1
I $P(S,U,27)-$P(S,U,28)>14 S YSINDX=YSINDX+1
I $P(S,U,24)-$P(S,U,23)>14 S YSINDX=YSINDX+1
I ($P(S,U,17)>84)&($P(S,U,51)>44) S YSINDX=YSINDX+1
I $P(S,U,40)-$P(S,U,39)>9 S YSINDX=YSINDX+1
W !?2,"Malingering Index = ",YSINDX
S YSINDX=0 ; RESET
I $P(S,U,4)>44 S YSINDX=YSINDX+1 S:$P(S,U,4)>49 YSINDX=YSINDX+1
I $P(S,U,51)>44 S YSINDX=YSINDX+1
I $P(S,U,40)-$P(S,U,39)>9 S YSINDX=YSINDX+1
I $P(S,U,41)-$P(S,U,39)>9 S YSINDX=YSINDX+1
I $P(S,U,23)-$P(S,U,24)>9 S YSINDX=YSINDX+1
I $P(S,U,14)-$P(S,U,11)>9 S YSINDX=YSINDX+1
I $P(S,U,52)-$P(S,U,46)>14 S YSINDX=YSINDX+1
I $P(S,U,22)-$P(S,U,49)>9 S YSINDX=YSINDX+1
W !?2,"Defensiveness Index = ",$J(YSINDX,3)
XBAR ;
S YSINDX=0 F I=5,9,13,17,21,25,29,33,38,42,43 S YSINDX=YSINDX+$P(S,U,I)
W !?2,"Mean Clinical Elevation = ",$J(YSINDX/11,4,0)
Q
FIT ;coeff of fit
W !!,"Database Profile",?30,"Coefficient of Fit"
K A F K=1:1:41 D FIT1
S N=0 F S N=$O(A(N)) Q:N'>0 S K=0 F S K=$O(A(N,K)) Q:K'>0 G DONE:YSLFT D:IOST?1"C-".E&($Y+4>IOSL) SCR^YTREPT D FITW
Q
FITW W !,$P(^YTT(601,YSTEST,"G",1,1,K,0),U,1),?35,$J(9-N,6,3)
Q
FIT1 S (X1,Y1,X12,Y12,YSXY)=0,N=1
S YSFIT=^YTT(601,YSTEST,"G",1,1,K,0)
F I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53 D FITLOOP
;stanadrd dev t scores
S YSXBAR=X1/22
S YSXSD=$$SQRT^XLFMTH(X12/22-(YSXBAR*YSXBAR))
;standard dev fit data
S YSYBAR=Y1/22
S YSYSD=$$SQRT^XLFMTH(Y12/22-(YSYBAR*YSYBAR))
; CORR
S YSR=((YSXY/22)-(YSXBAR*YSYBAR))/(YSXSD*YSYSD)
S A(9-YSR,K)=""
Q
FITLOOP ;get individual items
S N=N+1,X1=X1+$P(S,U,I),X12=X12+($P(S,U,I)*$P(S,U,I)),Y1=Y1+$P(YSFIT,U,N),Y12=Y12+($P(YSFIT,U,N)*$P(YSFIT,U,N)),YSXY=YSXY+($P(S,U,I)*$P(YSFIT,U,N))
Q
CRIT ;
D RD,DTA^YTREPT
W !?10,"Critical Items",!!,"Delusions and Hallucinations"
F I=90,130,170,210,309 D CRITW
W !!,"Potential for Self-Harm" F I=100,183,206,220,340 D CRITW
W !!,"Potential for Aggression" F I=21,61,101,181 D CRITW
W !!,"Substance Abuse" F I=55,222 D CRITW
W !!,"Potential Malingering" F I=9,49,129,249 D CRITW
W !!,"Unreliability/Resistance" F I=31,71,311 D CRITW
W !!,"Traumatic Stressors" F I=34,114,194,274 D CRITW
Q
CRITW ; write critical items
Q:$E(X,I)<2
W !,$S($E(X,I)=2:"ST",$E(X,I)=3:"MT",1:"VT")," "
W ^YTT(601,YSTEST,"Q",I,"T",1,0)
W:$D(^YTT(601,YSTEST,"Q",I,"T",2,0)) !?7,^YTT(601,YSTEST,"Q",I,"T",2,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTPAI 4494 printed Dec 13, 2024@02:17:57 Page 2
YTPAI ;ASF/ALB- PAI TEST ;7/14/00 10:26
+1 ;;5.01;MENTAL HEALTH;**10,66,221,238**;Dec 30, 1994;Build 25
+2 ;
+3 ;Reference to $$SQRT^XLFMTH supported by IA #10105
+4 ;
+5 SET YSLFT=0
SET YSNOITEM="DONE^YTPAI"
MAIN ;
+1 SET (R,S)="^"
SET YSMX=4
+2 DO RD
+3 IF $LENGTH(X,"X")>18
DO DTA^YTREPT
WRITE !!!!,"PAI: Too many missing items to score"
if IOST?1"C".E
DO SCR^YTREPT
GOTO OUT
+4 DO SCOR
DO STND
+5 ;profile
DO ^YTPAI1
+6 if YSLFT
GOTO DONE
if IOST?1"C-".E
DO SCR^YTREPT
+7 DO SUBS^YTPAI1
+8 if YSLFT
GOTO DONE
if IOST?1"C-".E
DO SCR^YTREPT
+9 DO ADDIT
+10 DO FIT
+11 if YSLFT
GOTO DONE
if IOST?1"C-".E
DO SCR^YTREPT
+12 ;critical items
DO CRIT
+13 if YSLFT
GOTO DONE
if IOST?1"C-".E
DO SCR^YTREPT
OUT DO DTA^YTREPT
DO IR^YTPAI1
DONE KILL S,R,A,YSXBAR,YSYBAR,YSXSD,YSYSD
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
ADDIT ;additional indexes
+1 DO DTA^YTREPT
+2 SET YSINDX=0
+3 IF $PIECE(S,U,3)>109
SET YSINDX=YSINDX+1
+4 IF $PIECE(S,U,3)-$PIECE(S,U,2)>19
SET YSINDX=YSINDX+1
+5 ;asf 7/14/00 =YSINDX+2
IF $PIECE(S,U,2)-$PIECE(S,U,1)>14
SET YSINDX=YSINDX+1
+6 IF $PIECE(S,U,27)-$PIECE(S,U,26)>14
SET YSINDX=YSINDX+1
+7 IF $PIECE(S,U,27)-$PIECE(S,U,28)>14
SET YSINDX=YSINDX+1
+8 IF $PIECE(S,U,24)-$PIECE(S,U,23)>14
SET YSINDX=YSINDX+1
+9 IF ($PIECE(S,U,17)>84)&($PIECE(S,U,51)>44)
SET YSINDX=YSINDX+1
+10 IF $PIECE(S,U,40)-$PIECE(S,U,39)>9
SET YSINDX=YSINDX+1
+11 WRITE !?2,"Malingering Index = ",YSINDX
+12 ; RESET
SET YSINDX=0
+13 IF $PIECE(S,U,4)>44
SET YSINDX=YSINDX+1
if $PIECE(S,U,4)>49
SET YSINDX=YSINDX+1
+14 IF $PIECE(S,U,51)>44
SET YSINDX=YSINDX+1
+15 IF $PIECE(S,U,40)-$PIECE(S,U,39)>9
SET YSINDX=YSINDX+1
+16 IF $PIECE(S,U,41)-$PIECE(S,U,39)>9
SET YSINDX=YSINDX+1
+17 IF $PIECE(S,U,23)-$PIECE(S,U,24)>9
SET YSINDX=YSINDX+1
+18 IF $PIECE(S,U,14)-$PIECE(S,U,11)>9
SET YSINDX=YSINDX+1
+19 IF $PIECE(S,U,52)-$PIECE(S,U,46)>14
SET YSINDX=YSINDX+1
+20 IF $PIECE(S,U,22)-$PIECE(S,U,49)>9
SET YSINDX=YSINDX+1
+21 WRITE !?2,"Defensiveness Index = ",$JUSTIFY(YSINDX,3)
XBAR ;
+1 SET YSINDX=0
FOR I=5,9,13,17,21,25,29,33,38,42,43
SET YSINDX=YSINDX+$PIECE(S,U,I)
+2 WRITE !?2,"Mean Clinical Elevation = ",$JUSTIFY(YSINDX/11,4,0)
+3 QUIT
FIT ;coeff of fit
+1 WRITE !!,"Database Profile",?30,"Coefficient of Fit"
+2 KILL A
FOR K=1:1:41
DO FIT1
+3 SET N=0
FOR
SET N=$ORDER(A(N))
if N'>0
QUIT
SET K=0
FOR
SET K=$ORDER(A(N,K))
if K'>0
QUIT
if YSLFT
GOTO DONE
if IOST?1"C-".E&($Y+4>IOSL)
DO SCR^YTREPT
DO FITW
+4 QUIT
FITW WRITE !,$PIECE(^YTT(601,YSTEST,"G",1,1,K,0),U,1),?35,$JUSTIFY(9-N,6,3)
+1 QUIT
FIT1 SET (X1,Y1,X12,Y12,YSXY)=0
SET N=1
+1 SET YSFIT=^YTT(601,YSTEST,"G",1,1,K,0)
+2 FOR I=1,2,3,4,5,9,13,17,21,25,29,33,38,42,43,44,48:1:53
DO FITLOOP
+3 ;stanadrd dev t scores
+4 SET YSXBAR=X1/22
+5 SET YSXSD=$$SQRT^XLFMTH(X12/22-(YSXBAR*YSXBAR))
+6 ;standard dev fit data
+7 SET YSYBAR=Y1/22
+8 SET YSYSD=$$SQRT^XLFMTH(Y12/22-(YSYBAR*YSYBAR))
+9 ; CORR
+10 SET YSR=((YSXY/22)-(YSXBAR*YSYBAR))/(YSXSD*YSYSD)
+11 SET A(9-YSR,K)=""
+12 QUIT
FITLOOP ;get individual items
+1 SET N=N+1
SET X1=X1+$PIECE(S,U,I)
SET X12=X12+($PIECE(S,U,I)*$PIECE(S,U,I))
SET Y1=Y1+$PIECE(YSFIT,U,N)
SET Y12=Y12+($PIECE(YSFIT,U,N)*$PIECE(YSFIT,U,N))
SET YSXY=YSXY+($PIECE(S,U,I)*$PIECE(YSFIT,U,N))
+2 QUIT
CRIT ;
+1 DO RD
DO DTA^YTREPT
+2 WRITE !?10,"Critical Items",!!,"Delusions and Hallucinations"
+3 FOR I=90,130,170,210,309
DO CRITW
+4 WRITE !!,"Potential for Self-Harm"
FOR I=100,183,206,220,340
DO CRITW
+5 WRITE !!,"Potential for Aggression"
FOR I=21,61,101,181
DO CRITW
+6 WRITE !!,"Substance Abuse"
FOR I=55,222
DO CRITW
+7 WRITE !!,"Potential Malingering"
FOR I=9,49,129,249
DO CRITW
+8 WRITE !!,"Unreliability/Resistance"
FOR I=31,71,311
DO CRITW
+9 WRITE !!,"Traumatic Stressors"
FOR I=34,114,194,274
DO CRITW
+10 QUIT
CRITW ; write critical items
+1 if $EXTRACT(X,I)<2
QUIT
+2 WRITE !,$SELECT($EXTRACT(X,I)=2:"ST",$EXTRACT(X,I)=3:"MT",1:"VT")," "
+3 WRITE ^YTT(601,YSTEST,"Q",I,"T",1,0)
+4 if $DATA(^YTT(601,YSTEST,"Q",I,"T",2,0))
WRITE !?7,^YTT(601,YSTEST,"Q",I,"T",2,0)
+5 QUIT
