YTMMPI2 ;ALB/ASF,HIOFO/FT - MMPI2 REPORT ;9/15/11 13:14
;;5.01;MENTAL HEALTH;**60**;Dec 30, 1994;Build 47
;
;Reference to TERMINAL TYPE (#3.2) file supported by DBIA #5725) - pending
;
S J=1,(YSTR,YSFR,YSQR)=0 F I=1:1:3 I $D(^YTD(601.2,YSDFN,1,YSET,1,YSED,I)) S X=^(I),L=$L(X) F K=1:1:L S:$E(X,K)="X" YSQR=YSQR+1 S:$E(X,K)="T" YSTR=YSTR+1 S:$E(X,K)="F" YSFR=YSFR+1
T0 ;
S L=200,M=0,YSKK=1,YSTL=0 D RD
T01X ;
I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S A(J)=YSTL,J=J+1 G T0:J<14,RD1
S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
T03X ;
S YSIT=$P(Y,U,P) I YSIT="" S YSKK=YSKK+1 G T01X
S B=$P(Y,U,P+1),P=P+2
T3 ;
I YSIT>L S L=L+200,M=M+200 D RD G T3
S:$E(X,YSIT-M)=B YSTL=YSTL+1 G T03X
RD ;
S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q
RD1 ;
MF ;SCALE 5 FIX
S YSND=$S(YSSX="F":"FK",1:"MK"),Y=^YTT(601,YSTEST,"S",8,YSND)
F P=1,3,5,7 S YSIT=$P(Y,U,P),B=$P(Y,U,P+1) S X=$S(YSIT>200:$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,2),YSIT-200),1:$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSIT)) S:X=B A(8)=A(8)+1
S R="" F I=1:1:13 S R=R_A(I)_U
K A S YSRNK=R
K ;CORRECTION SCALE MODIFIER
S X=$P(R,U,3) S $P(R,U,4)=$P(R,U,4)+$J(X*.5,0,0) S $P(R,U,7)=$P(R,U,7)+$J(X*.4,0,0) S $P(R,U,10)=$P(R,U,10)+X S $P(R,U,11)=$P(R,U,11)+X S $P(R,U,12)=$P(R,U,12)+$J(X*.2,0,0)
ST ;
S S="",J=1,P=YSSX
LK ;
S A=$P(R,U,J) G:A="" K0 S L1=$P(^YTT(601,YSTEST,"S",J,P),U) I A<L1 S YSTVL=$P(^(P),U,2) G LK1
S YSTVL=$P(^YTT(601,YSTEST,"S",J,P),U,A+2-L1) I YSTVL="" S YSTVL=$P(^(P),U,$L(^(P),"^"))
LK1 ;
S S=S_YSTVL_"^",J=J+1 G LK
K0 ;
K YSTVL S (YSSCALEB,YSSCALE)=S,YSRAW=R
HD ;
S DOT=YSHD,YSNS=13,V(3)="",YSSK="B",YSSNM="L ,F ,K ,HS,D ,HY,PD,MF,PA,PT,SC,MA,SI"
S X=" M M P I 2 P R O F I L E ",Y=70-$L(X)\2 W @IOF,!!?Y,X,$P(^YTT(601,YSTEST,0),U) D ^YTMMPI2P G:YSLFT END
BOTTM ;
W !?YSLM+6 F I=1:1:YSNS W $E($P(YSSNM,",",I)_" ",1,4)
W !?2,"Raw Score:" F I=1:1:YSNS W $J($P(YSRNK,U,I),4) W:I=3 " "
S X=$P(R,U,3) W !!?2,"K Corr.",?27,$J(X*.5,2,0),?$X+10,$J(X*.4,2,0),?$X+10,$J(X,2)," ",$J(X,2)," ",$J(X*.2,2,0)
W !!?2,"T Score: " F I=1:1:YSNS W $J($P(S,U,I),4) W:I=3 " "
W !!?2,"? Cannot Say (Raw): ",YSQR,?35,"F-K (Raw): ",$P(R,U,2)-$P(R,U,3)
W !?2,"Percent True:",$J(YSTR/$P(^YTT(601,YSTEST,0),U,11)*100,3,0),?$X+7,"Percent False:",$J(YSFR/$P(^YTT(601,YSTEST,0),U,11)*100,3,0),?$X+7,"Profile Elev.:"
S X=0 F I=4,5,6,7,9,10,11,12 S X=X+$P(S,U,I)
W $J(X/8,5,1)
WC ;WELSH CODE
S YSULON="",YSULOF="",Z=2
;I IO=0 S YSULON="*27,*91,*52,*109",YSULOF=HL ; *** PC ***
;I IO>0 S YSULON="*27,*45,1",YSULOF="*27,*45,0"
;I $D(^%ZIS(2,IO,6)) S YSULON=$P(^%ZIS(2,IO,6),U,4),YSULOF=$P(^(6),U,5)
S YSULON=$$GET1^DIQ(3.2,IO_",",23)
S YSULOF=$$GET1^DIQ(3.2,IO_",",24)
K ^TMP($J,"YTMMPI2") F I=4:1:13 S X=999-$P(S,U,I),X1=$S(I=13:0,1:I-3) S:'$D(^TMP($J,"YTMMPI2",X)) ^(X)="" S ^(X)=^(X)_X1
W !!?2,"Welsh Code (new): " S X=0,Z=2
F S X=$O(^TMP($J,"YTMMPI2",X)) Q:'X S X1=^(X),X2=999-X,Y=X,Y=$O(^TMP($J,"YTMMPI2",Y)) S:Y Y=999-Y D UL:$L(X1)>1!(X2-Y<2) W X1 S Z1=Z D:(X2-Y>1) ULOF:Z1=1,NUL:Z1'=1 D WCM
K ^TMP($J,"YTMMPI2") F I=1,2,3 S X=999-$P(S,U,I),X1=$S(I=1:"L",I=2:"F",1:"K") S:'$D(^TMP($J,"YTMMPI2",X)) ^(X)="" S ^(X)=^(X)_X1
W " " S X=0,Z=2
F S X=$O(^TMP($J,"YTMMPI2",X)) Q:'X S X1=^(X),X2=999-X,Y=X,Y=$O(^TMP($J,"YTMMPI2",Y)) S:Y Y=999-Y D UL:$L(X1)>1!(X2-Y<2) W X1 S Z1=Z D:(X2-Y>1) ULOF:Z1=1,NUL:Z1'=1 D WCM
W:YSULON="" " unable to show ties"
W !! D DTA^YTMMPI2P,WAIT^YTMMPI2P G:YSLFT END
OUT ;
K X1,X2,X3,DIC D:^YTT(601,YSTEST,0)?1"MMPI2".E SUP^YTMMPI2A
END ;
K A,B,C,G,H,I,J,K,L,L1,M,N,P,R,S,V,X,X1,X2,X3,Y,YSAST,YSB1,YSB2,YSBV,YSCNT,YSF,YSFR,YSHS,YSINC,YSIN2,YSIT,YSIT1,YSIT2,YSKK,YSKY,YSLE,YSLL,YSLM,YSLV,YSN,YSND,YSNS,YSOFF,YSQR,YSRAW,YSRNK,YSSCALE,YSSCALEB
K YSSK,YSSNM,YSSNM1,YSTL,YSTR,YSTV,YSTVL,YSULON,YSULOF,YSVS Q
UL ;
W:Z=0 " " W:$L(YSULON) @YSULON S Z=1 Q
ULOF ;
W:$L(YSULOF) @YSULOF S Z=0 Q
NUL ;
S Z=2 Q
WCM ;
S N=0 F K=100:-10:30 S N=N+1 I (X2>(K-1))&(Y<K) W $P("**^*^""^'^-^/^:^#",U,N) S:Z=0 Z=2 Q:Y<1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTMMPI2 4000 printed Dec 13, 2024@02:17:46 Page 2
YTMMPI2 ;ALB/ASF,HIOFO/FT - MMPI2 REPORT ;9/15/11 13:14
+1 ;;5.01;MENTAL HEALTH;**60**;Dec 30, 1994;Build 47
+2 ;
+3 ;Reference to TERMINAL TYPE (#3.2) file supported by DBIA #5725) - pending
+4 ;
+5 SET J=1
SET (YSTR,YSFR,YSQR)=0
FOR I=1:1:3
IF $DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED,I))
SET X=^(I)
SET L=$LENGTH(X)
FOR K=1:1:L
if $EXTRACT(X,K)="X"
SET YSQR=YSQR+1
if $EXTRACT(X,K)="T"
SET YSTR=YSTR+1
if $EXTRACT(X,K)="F"
SET YSFR=YSFR+1
T0 ;
+1 SET L=200
SET M=0
SET YSKK=1
SET YSTL=0
DO RD
T01X ;
+1 IF '$DATA(^YTT(601,YSTEST,"S",J,"K",YSKK,0))
SET A(J)=YSTL
SET J=J+1
if J<14
GOTO T0
GOTO RD1
+2 SET Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0)
SET P=1
T03X ;
+1 SET YSIT=$PIECE(Y,U,P)
IF YSIT=""
SET YSKK=YSKK+1
GOTO T01X
+2 SET B=$PIECE(Y,U,P+1)
SET P=P+2
T3 ;
+1 IF YSIT>L
SET L=L+200
SET M=M+200
DO RD
GOTO T3
+2 if $EXTRACT(X,YSIT-M)=B
SET YSTL=YSTL+1
GOTO T03X
RD ;
+1 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)
QUIT
RD1 ;
MF ;SCALE 5 FIX
+1 SET YSND=$SELECT(YSSX="F":"FK",1:"MK")
SET Y=^YTT(601,YSTEST,"S",8,YSND)
+2 FOR P=1,3,5,7
SET YSIT=$PIECE(Y,U,P)
SET B=$PIECE(Y,U,P+1)
SET X=$SELECT(YSIT>200:$EXTRACT(^YTD(601.2,YSDFN,1,YSET,1,YSED,2),YSIT-200),1:$EXTRACT(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSIT))
if X=B
SET A(8)=A(8)+1
+3 SET R=""
FOR I=1:1:13
SET R=R_A(I)_U
+4 KILL A
SET YSRNK=R
K ;CORRECTION SCALE MODIFIER
+1 SET X=$PIECE(R,U,3)
SET $PIECE(R,U,4)=$PIECE(R,U,4)+$JUSTIFY(X*.5,0,0)
SET $PIECE(R,U,7)=$PIECE(R,U,7)+$JUSTIFY(X*.4,0,0)
SET $PIECE(R,U,10)=$PIECE(R,U,10)+X
SET $PIECE(R,U,11)=$PIECE(R,U,11)+X
SET $PIECE(R,U,12)=$PIECE(R,U,12)+$JUSTIFY(X*.2,0,0)
ST ;
+1 SET S=""
SET J=1
SET P=YSSX
LK ;
+1 SET A=$PIECE(R,U,J)
if A=""
GOTO K0
SET L1=$PIECE(^YTT(601,YSTEST,"S",J,P),U)
IF A<L1
SET YSTVL=$PIECE(^(P),U,2)
GOTO LK1
+2 SET YSTVL=$PIECE(^YTT(601,YSTEST,"S",J,P),U,A+2-L1)
IF YSTVL=""
SET YSTVL=$PIECE(^(P),U,$LENGTH(^(P),"^"))
LK1 ;
+1 SET S=S_YSTVL_"^"
SET J=J+1
GOTO LK
K0 ;
+1 KILL YSTVL
SET (YSSCALEB,YSSCALE)=S
SET YSRAW=R
HD ;
+1 SET DOT=YSHD
SET YSNS=13
SET V(3)=""
SET YSSK="B"
SET YSSNM="L ,F ,K ,HS,D ,HY,PD,MF,PA,PT,SC,MA,SI"
+2 SET X=" M M P I 2 P R O F I L E "
SET Y=70-$LENGTH(X)\2
WRITE @IOF,!!?Y,X,$PIECE(^YTT(601,YSTEST,0),U)
DO ^YTMMPI2P
if YSLFT
GOTO END
BOTTM ;
+1 WRITE !?YSLM+6
FOR I=1:1:YSNS
WRITE $EXTRACT($PIECE(YSSNM,",",I)_" ",1,4)
+2 WRITE !?2,"Raw Score:"
FOR I=1:1:YSNS
WRITE $JUSTIFY($PIECE(YSRNK,U,I),4)
if I=3
WRITE " "
+3 SET X=$PIECE(R,U,3)
WRITE !!?2,"K Corr.",?27,$JUSTIFY(X*.5,2,0),?$X+10,$JUSTIFY(X*.4,2,0),?$X+10,$JUSTIFY(X,2)," ",$JUSTIFY(X,2)," ",$JUSTIFY(X*.2,2,0)
+4 WRITE !!?2,"T Score: "
FOR I=1:1:YSNS
WRITE $JUSTIFY($PIECE(S,U,I),4)
if I=3
WRITE " "
+5 WRITE !!?2,"? Cannot Say (Raw): ",YSQR,?35,"F-K (Raw): ",$PIECE(R,U,2)-$PIECE(R,U,3)
+6 WRITE !?2,"Percent True:",$JUSTIFY(YSTR/$PIECE(^YTT(601,YSTEST,0),U,11)*100,3,0),?$X+7,"Percent False:",$JUSTIFY(YSFR/$PIECE(^YTT(601,YSTEST,0),U,11)*100,3,0),?$X+7,"Profile Elev.:"
+7 SET X=0
FOR I=4,5,6,7,9,10,11,12
SET X=X+$PIECE(S,U,I)
+8 WRITE $JUSTIFY(X/8,5,1)
WC ;WELSH CODE
+1 SET YSULON=""
SET YSULOF=""
SET Z=2
+2 ;I IO=0 S YSULON="*27,*91,*52,*109",YSULOF=HL ; *** PC ***
+3 ;I IO>0 S YSULON="*27,*45,1",YSULOF="*27,*45,0"
+4 ;I $D(^%ZIS(2,IO,6)) S YSULON=$P(^%ZIS(2,IO,6),U,4),YSULOF=$P(^(6),U,5)
+5 SET YSULON=$$GET1^DIQ(3.2,IO_",",23)
+6 SET YSULOF=$$GET1^DIQ(3.2,IO_",",24)
+7 KILL ^TMP($JOB,"YTMMPI2")
FOR I=4:1:13
SET X=999-$PIECE(S,U,I)
SET X1=$SELECT(I=13:0,1:I-3)
if '$DATA(^TMP($JOB,"YTMMPI2",X))
SET ^(X)=""
SET ^(X)=^(X)_X1
+8 WRITE !!?2,"Welsh Code (new): "
SET X=0
SET Z=2
+9 FOR
SET X=$ORDER(^TMP($JOB,"YTMMPI2",X))
if 'X
QUIT
SET X1=^(X)
SET X2=999-X
SET Y=X
SET Y=$ORDER(^TMP($JOB,"YTMMPI2",Y))
if Y
SET Y=999-Y
if $LENGTH(X1)>1!(X2-Y<2)
DO UL
WRITE X1
SET Z1=Z
if (X2-Y>1)
if Z1=1
DO ULOF
if Z1'=1
DO NUL
DO WCM
+10 KILL ^TMP($JOB,"YTMMPI2")
FOR I=1,2,3
SET X=999-$PIECE(S,U,I)
SET X1=$SELECT(I=1:"L",I=2:"F",1:"K")
if '$DATA(^TMP($JOB,"YTMMPI2",X))
SET ^(X)=""
SET ^(X)=^(X)_X1
+11 WRITE " "
SET X=0
SET Z=2
+12 FOR
SET X=$ORDER(^TMP($JOB,"YTMMPI2",X))
if 'X
QUIT
SET X1=^(X)
SET X2=999-X
SET Y=X
SET Y=$ORDER(^TMP($JOB,"YTMMPI2",Y))
if Y
SET Y=999-Y
if $LENGTH(X1)>1!(X2-Y<2)
DO UL
WRITE X1
SET Z1=Z
if (X2-Y>1)
if Z1=1
DO ULOF
if Z1'=1
DO NUL
DO WCM
+13 if YSULON=""
WRITE " unable to show ties"
+14 WRITE !!
DO DTA^YTMMPI2P
DO WAIT^YTMMPI2P
if YSLFT
GOTO END
OUT ;
+1 KILL X1,X2,X3,DIC
if ^YTT(601,YSTEST,0)?1"MMPI2".E
DO SUP^YTMMPI2A
END ;
+1 KILL A,B,C,G,H,I,J,K,L,L1,M,N,P,R,S,V,X,X1,X2,X3,Y,YSAST,YSB1,YSB2,YSBV,YSCNT,YSF,YSFR,YSHS,YSINC,YSIN2,YSIT,YSIT1,YSIT2,YSKK,YSKY,YSLE,YSLL,YSLM,YSLV,YSN,YSND,YSNS,YSOFF,YSQR,YSRAW,YSRNK,YSSCALE,YSSCALEB
+2 KILL YSSK,YSSNM,YSSNM1,YSTL,YSTR,YSTV,YSTVL,YSULON,YSULOF,YSVS
QUIT
UL ;
+1 if Z=0
WRITE " "
if $LENGTH(YSULON)
WRITE @YSULON
SET Z=1
QUIT
ULOF ;
+1 if $LENGTH(YSULOF)
WRITE @YSULOF
SET Z=0
QUIT
NUL ;
+1 SET Z=2
QUIT
WCM ;
+1 SET N=0
FOR K=100:-10:30
SET N=N+1
IF (X2>(K-1))&(Y<K)
WRITE $PIECE("**^*^""^'^-^/^:^#",U,N)
if Z=0
SET Z=2
if Y<1
QUIT
