YTMMPI2P.m

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 ---YTMMPI2P   4022     printed  Feb 18, 2025@23:44:08                                                                                                                                                                                                    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