YTMMPI2P ;SLC/DKG,ALB/ASF-TEST PKG: MMPI2 PROFILE ;Nov 09, 2023@15:02:43
;;5.01;MENTAL HEALTH;**19,37,238**;Dec 30, 1994;Build 25
;
A ;
K YSAST S YSTV=110,YSBV=30,YSINC=2,YSLE=5 S Z1=0,X=YSSCALE,YSLFT=0 F J=1:1:YSNS S (A(J),YSA(J))=$P(X,U,J),YSAST(J)="" S:A(J)>YSTV YSAST(J)=">" S:A(J)>YSBV YSAST=">"
S YSVS=3,YSHS="110,66,50,30^"
F J=1:1:YSNS S Z1=$P(YSSNM,",",J),Z1=$P(Z1," "),$P(YSSNM,",",J)=Z1_YSAST(J)
S YSSNM1="" F I=1:1:YSNS S YSSNM1=YSSNM1_$P($P(YSSNM,",",I)," ")_$S($L($P(YSSNM,",",I))>1:"",1:" ")_","
F I=1:1 S J=$P(YSHS,",",I) Q:J="" S H(I)=+J
S YSLM=80-(YSNS*4+20)\2+5
S YSLC1=9999,YSLV=YSTV,YSIN2=YSINC/2
S YSHS=$O(H(-1)),H(-1)=-999
L ;
F I=1:1:YSNS 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(YSLC1'<YSLE:$J(YSLV,5,0),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
END ;
K A,B,YSA,YSTV,YSTVL,YSBV,YSINC,YSIN2,YSLE,YSVS,YSHS,V,H,YSLL,YSLC1,YSWS Q
WL ;
D:IOST?1"C-".E WAIT:$Y>(IOSL-4) Q:YSLFT W:'Z1 ! W ?YSLM,YSLL,"|" S Z1=0
I YSSK="B" F I=1:1:YSNS W $S(B(I):$E($P(YSSNM1,",",I)_" ",1,3),1:" ") I I<YSNS W $S($D(V(I)):"|",1:" ")
I YSSK="K" F I=1:1:YSNS W $S(B(I)=2:" + ",B(I):$E($P(YSSNM1,",",I)_" ",1,3),1:" ") I I<YSNS W $S($D(V(I)):"|",1:" ")
I YSSK'="B"&(YSSK'="K") F I=1:1:YSNS S X="* " S:$P(YSSNM,",",I)?1"TR".E&(YSSK="S") X=$S($P(YSRAW,U,I)<9:"F ",$P(YSRAW,U,I)>9:"T ",1:"# ") W $S(B(I):X,1:" ")
W "|",$E(YSLL,3,5) Q
WS ;
D:IOST?1"C-".E WAIT:$Y>(IOSL-4) Q:YSLFT W:'Z1 ! W ?YSLM,YSLL,"|" S Z1=0
I YSSK="B" F I=1:1:YSNS W $S(B(I):$P(YSSNM1,",",I)_"-",1:"---") I I<YSNS W $S($D(V(I)):"|",1:"-")
I YSSK="K" F I=1:1:YSNS W "-",$S(B(I)=2:"+-",B(I):$P(YSSNM,",",I),1:"--") I I<YSNS W $S($D(V(I)):"|",1:"-")
I YSSK'="B"&(YSSK'="K") F I=1:1:YSNS S X="*---" S:$P(YSSNM,",",I)?1"TR".E&(YSSK="S") X=$S($P(YSRAW,U,I)<9:"F---",$P(YSRAW,U,I)>9:"T---",1:"#---") W $S(B(I):X,1:"----")
W "|",$E(YSLL,3,5) Q
Q
DTA ;
S YSDTA=$P(^YTD(601.2,YSDFN,1,YSET,1,YSHD,0),U,5) S:YSDTA'="" YSDTA=$$FMTE^XLFDT(YSDTA,"5ZD")
S YSHDR=$E(YSHDR,1,43)_" "_$S($G(YSSIG)'="":YSSIG,1:YSSX)_" AGE "_$J(YSAGE,2,0)_" "_$$FMTE^XLFDT(DT,"5ZD")_" "_$$FMTE^XLFDT(YSHD,"5ZD")
W YSHDR," ",YSDTA W ! W:$D(YSAST) "'<' OR '>' indicates 'T' out of table range" W ?53,"PRINTED ENTERED " W:YSDTA'="" "ADMIN" Q
WAIT ;
; %% ANOTHER READER CALL ???? LOOK YSLFT = YSTOUT %%%
Q:IOST'?1"C-".E W $C(7) R YSLFT:DTIME S YSTOUT='$T,YSUOUT=YSLFT["^" S:YSLFT["^"!'$T YSLFT=1 Q:YSLFT S Z1=1 W # Q
Q
NK ;NON-K CORRECTED
S J=100 F I=4,7,10,11,12 S J=J+1,A(J)=$P(YSRNK,U,I),S="" D LK^YTMMPI2A S C(I)=+S
HD ;
S (S,YSSCALE)=YSSCALEB,DOT=YSHD,YSNS=13,V(3)="",YSSK="K",YSSNM="L ,F ,K ,HS,D ,HY,PD,MF,PA,PT,SC,MA,SI"
W @IOF,!!?25,"K and Non-K Corrected Profile",! D ^YTMMPI2P Q:YSLFT
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(YSRNK,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,"+Non-K Corr.",!?3,"T Score:",?26,$J(C(4),3),?$X+9,$J(C(7),3),?$X+9,$J(C(10),3)," ",$J(C(11),3)," ",$J(C(12),3)
W !!?2,"? Cannot Say (Raw): ",YSQR K A,C,S,YSRAW,YSNRK
W !! D DTA,WAIT,CR G:YSLFT END^YTMMPI2 S YSFORM=1 D IR^YTREPT
D ^YTMMPI2C ;Print user comments
Q
CR ;COPYRIGHT
I $P(^YTT(601,YSTEST,0),U,6)]"" S YSCH=$P(^(0),U,6),Y=$P(^(0),U,7) D DD^%DT S YSCD=Y I $D(^YTT(601.3,YSCH,0)) S YSCHN=YSCH,YSCH=$P(^(0),U) D CR^YTDRIV
I IOST'?1"C-".E D WPO
Q
WPO ;
;WRITE PRINTED BY - ORDERED BY ------MJD 10/15/96
N YSI
F YSI=1:1:IOSL-$Y-5 W !
W !,"Printed by: ",$P(^VA(200,DUZ,0),U),!
S YSORD=$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3)
I YSORD,$D(^VA(200,YSORD,0)) W "Ordered by: ",$P(^(0),U)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTMMPI2P 4022 printed Apr 09, 2024@21:24:11 Page 2
YTMMPI2P ;SLC/DKG,ALB/ASF-TEST PKG: MMPI2 PROFILE ;Nov 09, 2023@15:02:43
+1 ;;5.01;MENTAL HEALTH;**19,37,238**;Dec 30, 1994;Build 25
+2 ;
A ;
+1 KILL YSAST
SET YSTV=110
SET YSBV=30
SET YSINC=2
SET YSLE=5
SET Z1=0
SET X=YSSCALE
SET YSLFT=0
FOR J=1:1:YSNS
SET (A(J),YSA(J))=$PIECE(X,U,J)
SET YSAST(J)=""
if A(J)>YSTV
SET YSAST(J)=">"
if A(J)>YSBV
SET YSAST=">"
+2 SET YSVS=3
SET YSHS="110,66,50,30^"
+3 FOR J=1:1:YSNS
SET Z1=$PIECE(YSSNM,",",J)
SET Z1=$PIECE(Z1," ")
SET $PIECE(YSSNM,",",J)=Z1_YSAST(J)
+4 SET YSSNM1=""
FOR I=1:1:YSNS
SET YSSNM1=YSSNM1_$PIECE($PIECE(YSSNM,",",I)," ")_$SELECT($LENGTH($PIECE(YSSNM,",",I))>1:"",1:" ")_","
+5 FOR I=1:1
SET J=$PIECE(YSHS,",",I)
if J=""
QUIT
SET H(I)=+J
+6 SET YSLM=80-(YSNS*4+20)\2+5
+7 SET YSLC1=9999
SET YSLV=YSTV
SET YSIN2=YSINC/2
+8 SET YSHS=$ORDER(H(-1))
SET H(-1)=-999
L ;
+1 FOR I=1:1:YSNS
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(YSLC1'<YSLE:$JUSTIFY(YSLV,5,0),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
END ;
+1 KILL A,B,YSA,YSTV,YSTVL,YSBV,YSINC,YSIN2,YSLE,YSVS,YSHS,V,H,YSLL,YSLC1,YSWS
QUIT
WL ;
+1 if IOST?1"C-".E
if $Y>(IOSL-4)
DO WAIT
if YSLFT
QUIT
if 'Z1
WRITE !
WRITE ?YSLM,YSLL,"|"
SET Z1=0
+2 IF YSSK="B"
FOR I=1:1:YSNS
WRITE $SELECT(B(I):$EXTRACT($PIECE(YSSNM1,",",I)_" ",1,3),1:" ")
IF I<YSNS
WRITE $SELECT($DATA(V(I)):"|",1:" ")
+3 IF YSSK="K"
FOR I=1:1:YSNS
WRITE $SELECT(B(I)=2:" + ",B(I):$EXTRACT($PIECE(YSSNM1,",",I)_" ",1,3),1:" ")
IF I<YSNS
WRITE $SELECT($DATA(V(I)):"|",1:" ")
+4 IF YSSK'="B"&(YSSK'="K")
FOR I=1:1:YSNS
SET X="* "
if $PIECE(YSSNM,",",I)?1"TR".E&(YSSK="S")
SET X=$SELECT($PIECE(YSRAW,U,I)<9:"F ",$PIECE(YSRAW,U,I)>9:"T ",1:"# ")
WRITE $SELECT(B(I):X,1:" ")
+5 WRITE "|",$EXTRACT(YSLL,3,5)
QUIT
WS ;
+1 if IOST?1"C-".E
if $Y>(IOSL-4)
DO WAIT
if YSLFT
QUIT
if 'Z1
WRITE !
WRITE ?YSLM,YSLL,"|"
SET Z1=0
+2 IF YSSK="B"
FOR I=1:1:YSNS
WRITE $SELECT(B(I):$PIECE(YSSNM1,",",I)_"-",1:"---")
IF I<YSNS
WRITE $SELECT($DATA(V(I)):"|",1:"-")
+3 IF YSSK="K"
FOR I=1:1:YSNS
WRITE "-",$SELECT(B(I)=2:"+-",B(I):$PIECE(YSSNM,",",I),1:"--")
IF I<YSNS
WRITE $SELECT($DATA(V(I)):"|",1:"-")
+4 IF YSSK'="B"&(YSSK'="K")
FOR I=1:1:YSNS
SET X="*---"
if $PIECE(YSSNM,",",I)?1"TR".E&(YSSK="S")
SET X=$SELECT($PIECE(YSRAW,U,I)<9:"F---",$PIECE(YSRAW,U,I)>9:"T---",1:"#---")
WRITE $SELECT(B(I):X,1:"----")
+5 WRITE "|",$EXTRACT(YSLL,3,5)
QUIT
+6 QUIT
DTA ;
+1 SET YSDTA=$PIECE(^YTD(601.2,YSDFN,1,YSET,1,YSHD,0),U,5)
if YSDTA'=""
SET YSDTA=$$FMTE^XLFDT(YSDTA,"5ZD")
+2 SET YSHDR=$EXTRACT(YSHDR,1,43)_" "_$SELECT($GET(YSSIG)'="":YSSIG,1:YSSX)_" AGE "_$JUSTIFY(YSAGE,2,0)_" "_$$FMTE^XLFDT(DT,"5ZD")_" "_$$FMTE^XLFDT(YSHD,"5ZD")
+3 WRITE YSHDR," ",YSDTA
WRITE !
if $DATA(YSAST)
WRITE "'<' OR '>' indicates 'T' out of table range"
WRITE ?53,"PRINTED ENTERED "
if YSDTA'=""
WRITE "ADMIN"
QUIT
WAIT ;
+1 ; %% ANOTHER READER CALL ???? LOOK YSLFT = YSTOUT %%%
+2 if IOST'?1"C-".E
QUIT
WRITE $CHAR(7)
READ YSLFT:DTIME
SET YSTOUT='$TEST
SET YSUOUT=YSLFT["^"
if YSLFT["^"!'$TEST
SET YSLFT=1
if YSLFT
QUIT
SET Z1=1
WRITE #
QUIT
+3 QUIT
NK ;NON-K CORRECTED
+1 SET J=100
FOR I=4,7,10,11,12
SET J=J+1
SET A(J)=$PIECE(YSRNK,U,I)
SET S=""
DO LK^YTMMPI2A
SET C(I)=+S
HD ;
+1 SET (S,YSSCALE)=YSSCALEB
SET DOT=YSHD
SET YSNS=13
SET V(3)=""
SET YSSK="K"
SET YSSNM="L ,F ,K ,HS,D ,HY,PD,MF,PA,PT,SC,MA,SI"
+2 WRITE @IOF,!!?25,"K and Non-K Corrected Profile",!
DO ^YTMMPI2P
if YSLFT
QUIT
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(YSRNK,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,"+Non-K Corr.",!?3,"T Score:",?26,$JUSTIFY(C(4),3),?$X+9,$JUSTIFY(C(7),3),?$X+9,$JUSTIFY(C(10),3)," ",$JUSTIFY(C(11),3)," ",$JUSTIFY(C(12),3)
+6 WRITE !!?2,"? Cannot Say (Raw): ",YSQR
KILL A,C,S,YSRAW,YSNRK
+7 WRITE !!
DO DTA
DO WAIT
DO CR
if YSLFT
GOTO END^YTMMPI2
SET YSFORM=1
DO IR^YTREPT
+8 ;Print user comments
DO ^YTMMPI2C
+9 QUIT
CR ;COPYRIGHT
+1 IF $PIECE(^YTT(601,YSTEST,0),U,6)]""
SET YSCH=$PIECE(^(0),U,6)
SET Y=$PIECE(^(0),U,7)
DO DD^%DT
SET YSCD=Y
IF $DATA(^YTT(601.3,YSCH,0))
SET YSCHN=YSCH
SET YSCH=$PIECE(^(0),U)
DO CR^YTDRIV
+2 IF IOST'?1"C-".E
DO WPO
+3 QUIT
WPO ;
+1 ;WRITE PRINTED BY - ORDERED BY ------MJD 10/15/96
+2 NEW YSI
+3 FOR YSI=1:1:IOSL-$Y-5
WRITE !
+4 WRITE !,"Printed by: ",$PIECE(^VA(200,DUZ,0),U),!
+5 SET YSORD=$PIECE(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3)
+6 IF YSORD
IF $DATA(^VA(200,YSORD,0))
WRITE "Ordered by: ",$PIECE(^(0),U)
+7 QUIT
