YTPAI.m

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 ---YTPAI   4494     printed  Feb 18, 2025@23:44:14                                                                                                                                                                                                       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