YTMBMD ;ALB/ASF,HIOFO/FT - MBMD ; 7/15/13 1:43pm
;;5.01;MENTAL HEALTH;**76,83,105**;Dec 30, 1994;Build 76
;No external references
MAIN ;
N A,B,G,I,L1,L2,N,X,YSANS,YSDAS,YSDAS1,YSIN,YSSID,YSTOUT,YSUOUT,YSVFLAG
D PTVAR^YSLRP
D RD
D VALIDITY ;Q:YSVFLAG
D RAW
D PS1 ; general untransformed
D RPA ; general response adjustment
D HPA ; general high point coping
D HPA1 ; general high point AA-EE a-m
D:YSTY["*" REPT
S R=R_U_$P(R,U,11,999)_U_$P(R,U,11,999)
D PSB^YTMBMD1 ; bariatric untransformed
D RPAB^YTMBMD1 ; bariatric response adjustment
D HPAB^YTMBMD1 ; bariatric high point coping
D HPA1B^YTMBMD1 ; bariatric high point AA-EE a-m
D:YSTY["*" REPTB^YTMBMD1
D PERCENT^YTMBMD2
D:YSTY["*" PAINREP^YTMBMD2
Q:$G(YSTOUT)!$G(YSUOUT) S (YSTOUT,YSUOUT)=""
D:YSTY["*" NOTEWOR
Q
RD S X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
Q
VALIDITY ;check if ok to score
S YSVFLAG=0
I $L(X,"X")>11 S YSVFLAG=1 Q
I ($E(X,106)="T")&($E(X,124)="T") S YSVFLAG=1 Q
I (YSAGE<18)!(YSAGE>85) S YSVFLAG=1 Q
Q
RAW ; raw scores
S R="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
F N=1:1:39 D
. S G=^YTT(601,YSTEST,"S",N,"K",1,0),I=1
. F S YSIN=$P(G,U,I),YSANS=$E($P(G,U,I+1),1),YSWT=$P($P(G,U,I+1),";",2),I=I+2 Q:YSIN="" S:$E(X,YSIN)=YSANS $P(R,U,N)=$P(R,U,N)+YSWT
Q
PS1 ; untransformed prevalence scores
S S="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
F I=11:1:39 S $P(S,U,I)=$P(^YTT(601,YSTEST,"S",I,YSSEX),U,$P(R,U,I)+1)
S X=$P(R,U,2) S $P(S,U,2)=$S(X<9:"L",X=9:"M",X=10:"H",1:0) ;scale X ASF 1/30/04
S X=$P(R,U,3) S $P(S,U,3)=$S(X<10:"L",X<13:"M",X>12:"H",1:0) ;scale Y ASF 1/30/04
S X=$P(R,U,4) S $P(S,U,4)=$S(X<5:"L",X=5:"M",X>5:"H",1:0) ;scale Z ASF 1/30/04
F I=5:1:10 S X=$P(R,U,I) S $P(S,U,I)=$S(X=0:"L",X<3:"M",X>2:"H",1:0) ;indicators ASF 1/30/04
Q
RPA ;Response Pattern Adjustment
S YSDAS=0
I ($P(S,U,2)="H")&($P(S,U,3)="H")&($P(S,U,4)'="H") S YSDAS=10
I ($P(S,U,2)'="H")&($P(S,U,3)="H")&($P(S,U,4)'="H") S YSDAS=10
I ($P(S,U,2)="H")&($P(S,U,3)'="H")&($P(S,U,4)'="H") S YSDAS=-5
I ($P(S,U,2)="H")&($P(S,U,3)'="H")&($P(S,U,4)="H") S YSDAS=-10
I ($P(S,U,2)'="H")&($P(S,U,3)'="H")&($P(S,U,4)="H") S YSDAS=-10
F I=11,12,13,14,15,27,28,29,30,31,32,33,34,35,36,37,38,39 S $P(S,U,I)=$P(S,U,I)+YSDAS
Q
HPA ;High Point Adjustment COPING
S N=0 F I=16:1:26 S:$P(S,U,I)>59 N=N+1
S YSDAS=$S(N>9:-10,N>7:-5,N>4:0,N>2:5,N>0:10,1:15)
F I=16:1:26 S $P(S,U,I)=$P(S,U,I)+YSDAS
Q
HPA1 ;high point AA-EE, a-m
S N=0
F I=11,12,13,14,15,27,28,29,30,31,32,33,34,35,36,37,38,39 S:$P(S,U,I)>59 N=N+1
S YSDAS=$S(N>16:-15,N>14:-10,N>12:-5,N>7:0,N>5:5,N>2:10,1:15)
S YSDAS1=$S(N>12:0,N>7:5,N>5:10,N>2:15,1:20)
F I=11,12,13,14,15,27,28,29,30,31,32,33,34,35,36,37 S $P(S,U,I)=$P(S,U,I)+YSDAS
F I=38,39 S $P(S,U,I)=$P(S,U,I)+YSDAS1
Q
REPT ;reports
S (YSTOUT,YSUOUT)=""
S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),B=$P(^("P"),U,3),L1=58-A\2,L2=L1+A+4 S:A<9 A=9
D DTA^YTREPT
W !,?(72-$L(X)\2),X,!
W !?50,$S(YSVFLAG:"*** Invalid Profile ***",1:"Valid Profile")
W !,"*** General Medical Norms ***"
F I=2:1:10 D D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
. W:I=2 !,"Response Patterns" ;ASF 1/30/04 ABOVE LINE ALSO
. W:I=5 !,"Negative Health Habits"
. W !,?4,$P(^YTT(601,YSTEST,"S",I,0),U,2),?25 D LIKELY
D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
F I=11:1:39 D D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
. W:I=11 !,"Psychiatric Indications"
. W:I=16 !,"Coping Styles"
. W:I=27 !,"Stress Moderators"
. W:I=33 !,"Treatment Prognostics"
. W:I=38 !,"Management Guides"
. S YSSID=$P(^YTT(601,YSTEST,"S",I,0),U,2)
. W !,$P(YSSID," ")
. W ?5,$J($P(R,U,I),2)," ",$S($P(S,U,I)'<0:$J($P(S,U,I),3),1:" 0")," "
. D CHART
. W ?52,$P(YSSID," ",2,99)
;D NOTEWOR
Q
LIKELY ;
N X
S X=$P(S,U,I)
W $S(X="L":"unlikely problem",X="M":"possible problem",X="H":"likely problem",1:"????")
Q
CHART ;
N X
S X=$P(S,U,I)
;W $E("***************************************************************",1,$J(X/3,0,0))
W $E("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX",1,$J(X/3,0,0))
Q
NOTEWOR ;note worthy responses
D RD
W !!?10,"*** Noteworthy Responses ***"
F I=1,14,28,66,6,117,131,157,3,20,41,62,5,10,103,116,49 D D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
.W:I=1 !!?4,"Panic Susceptibility"
.W:I=6 !!?4,"Disorientation"
.W:I=3 !!?4,"Medical Anxiety"
.W:I=5 !!?4,"Adherence Problems"
.W:I=49 !!?4,"Suicidal Tendencies"
. W:$E(X,I)="T" !,$J(I,3,0),". ",^YTT(601,YSTEST,"Q",I,"T",1,0)
I (($E(X,49)="T")&($E(X,58)="T"))!(($E(X,161)="T")&($E(X,58)="T")) W !," 58. ",^YTT(601,YSTEST,"Q",58,"T",1,0)
I (($E(X,49)="T")&($E(X,161)="T"))!(($E(X,161)="T")&($E(X,58)="T")) W !,"161. ",^YTT(601,YSTEST,"Q",161,"T",1,0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTMBMD 4916 printed Sep 23, 2025@19:53:32 Page 2
YTMBMD ;ALB/ASF,HIOFO/FT - MBMD ; 7/15/13 1:43pm
+1 ;;5.01;MENTAL HEALTH;**76,83,105**;Dec 30, 1994;Build 76
+2 ;No external references
MAIN ;
+1 NEW A,B,G,I,L1,L2,N,X,YSANS,YSDAS,YSDAS1,YSIN,YSSID,YSTOUT,YSUOUT,YSVFLAG
+2 DO PTVAR^YSLRP
+3 DO RD
+4 ;Q:YSVFLAG
DO VALIDITY
+5 DO RAW
+6 ; general untransformed
DO PS1
+7 ; general response adjustment
DO RPA
+8 ; general high point coping
DO HPA
+9 ; general high point AA-EE a-m
DO HPA1
+10 if YSTY["*"
DO REPT
+11 SET R=R_U_$PIECE(R,U,11,999)_U_$PIECE(R,U,11,999)
+12 ; bariatric untransformed
DO PSB^YTMBMD1
+13 ; bariatric response adjustment
DO RPAB^YTMBMD1
+14 ; bariatric high point coping
DO HPAB^YTMBMD1
+15 ; bariatric high point AA-EE a-m
DO HPA1B^YTMBMD1
+16 if YSTY["*"
DO REPTB^YTMBMD1
+17 DO PERCENT^YTMBMD2
+18 if YSTY["*"
DO PAINREP^YTMBMD2
+19 if $GET(YSTOUT)!$GET(YSUOUT)
QUIT
SET (YSTOUT,YSUOUT)=""
+20 if YSTY["*"
DO NOTEWOR
+21 QUIT
RD SET X=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
+1 QUIT
VALIDITY ;check if ok to score
+1 SET YSVFLAG=0
+2 IF $LENGTH(X,"X")>11
SET YSVFLAG=1
QUIT
+3 IF ($EXTRACT(X,106)="T")&($EXTRACT(X,124)="T")
SET YSVFLAG=1
QUIT
+4 IF (YSAGE<18)!(YSAGE>85)
SET YSVFLAG=1
QUIT
+5 QUIT
RAW ; raw scores
+1 SET R="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+2 FOR N=1:1:39
Begin DoDot:1
+3 SET G=^YTT(601,YSTEST,"S",N,"K",1,0)
SET I=1
+4 FOR
SET YSIN=$PIECE(G,U,I)
SET YSANS=$EXTRACT($PIECE(G,U,I+1),1)
SET YSWT=$PIECE($PIECE(G,U,I+1),";",2)
SET I=I+2
if YSIN=""
QUIT
if $EXTRACT(X,YSIN)=YSANS
SET $PIECE(R,U,N)=$PIECE(R,U,N)+YSWT
End DoDot:1
+5 QUIT
PS1 ; untransformed prevalence scores
+1 SET S="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+2 FOR I=11:1:39
SET $PIECE(S,U,I)=$PIECE(^YTT(601,YSTEST,"S",I,YSSEX),U,$PIECE(R,U,I)+1)
+3 ;scale X ASF 1/30/04
SET X=$PIECE(R,U,2)
SET $PIECE(S,U,2)=$SELECT(X<9:"L",X=9:"M",X=10:"H",1:0)
+4 ;scale Y ASF 1/30/04
SET X=$PIECE(R,U,3)
SET $PIECE(S,U,3)=$SELECT(X<10:"L",X<13:"M",X>12:"H",1:0)
+5 ;scale Z ASF 1/30/04
SET X=$PIECE(R,U,4)
SET $PIECE(S,U,4)=$SELECT(X<5:"L",X=5:"M",X>5:"H",1:0)
+6 ;indicators ASF 1/30/04
FOR I=5:1:10
SET X=$PIECE(R,U,I)
SET $PIECE(S,U,I)=$SELECT(X=0:"L",X<3:"M",X>2:"H",1:0)
+7 QUIT
RPA ;Response Pattern Adjustment
+1 SET YSDAS=0
+2 IF ($PIECE(S,U,2)="H")&($PIECE(S,U,3)="H")&($PIECE(S,U,4)'="H")
SET YSDAS=10
+3 IF ($PIECE(S,U,2)'="H")&($PIECE(S,U,3)="H")&($PIECE(S,U,4)'="H")
SET YSDAS=10
+4 IF ($PIECE(S,U,2)="H")&($PIECE(S,U,3)'="H")&($PIECE(S,U,4)'="H")
SET YSDAS=-5
+5 IF ($PIECE(S,U,2)="H")&($PIECE(S,U,3)'="H")&($PIECE(S,U,4)="H")
SET YSDAS=-10
+6 IF ($PIECE(S,U,2)'="H")&($PIECE(S,U,3)'="H")&($PIECE(S,U,4)="H")
SET YSDAS=-10
+7 FOR I=11,12,13,14,15,27,28,29,30,31,32,33,34,35,36,37,38,39
SET $PIECE(S,U,I)=$PIECE(S,U,I)+YSDAS
+8 QUIT
HPA ;High Point Adjustment COPING
+1 SET N=0
FOR I=16:1:26
if $PIECE(S,U,I)>59
SET N=N+1
+2 SET YSDAS=$SELECT(N>9:-10,N>7:-5,N>4:0,N>2:5,N>0:10,1:15)
+3 FOR I=16:1:26
SET $PIECE(S,U,I)=$PIECE(S,U,I)+YSDAS
+4 QUIT
HPA1 ;high point AA-EE, a-m
+1 SET N=0
+2 FOR I=11,12,13,14,15,27,28,29,30,31,32,33,34,35,36,37,38,39
if $PIECE(S,U,I)>59
SET N=N+1
+3 SET YSDAS=$SELECT(N>16:-15,N>14:-10,N>12:-5,N>7:0,N>5:5,N>2:10,1:15)
+4 SET YSDAS1=$SELECT(N>12:0,N>7:5,N>5:10,N>2:15,1:20)
+5 FOR I=11,12,13,14,15,27,28,29,30,31,32,33,34,35,36,37
SET $PIECE(S,U,I)=$PIECE(S,U,I)+YSDAS
+6 FOR I=38,39
SET $PIECE(S,U,I)=$PIECE(S,U,I)+YSDAS1
+7 QUIT
REPT ;reports
+1 SET (YSTOUT,YSUOUT)=""
+2 SET X=$PIECE(^YTT(601,YSTEST,"P"),U)
SET A=$PIECE(^("P"),U,2)
SET B=$PIECE(^("P"),U,3)
SET L1=58-A\2
SET L2=L1+A+4
if A<9
SET A=9
+3 DO DTA^YTREPT
+4 WRITE !,?(72-$LENGTH(X)\2),X,!
+5 WRITE !?50,$SELECT(YSVFLAG:"*** Invalid Profile ***",1:"Valid Profile")
+6 WRITE !,"*** General Medical Norms ***"
+7 FOR I=2:1:10
Begin DoDot:1
+8 ;ASF 1/30/04 ABOVE LINE ALSO
if I=2
WRITE !,"Response Patterns"
+9 if I=5
WRITE !,"Negative Health Habits"
+10 WRITE !,?4,$PIECE(^YTT(601,YSTEST,"S",I,0),U,2),?25
DO LIKELY
End DoDot:1
if IOST?1"C-".E&($Y>21)
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
+11 if IOST?1"C-".E&($Y>21)
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
+12 FOR I=11:1:39
Begin DoDot:1
+13 if I=11
WRITE !,"Psychiatric Indications"
+14 if I=16
WRITE !,"Coping Styles"
+15 if I=27
WRITE !,"Stress Moderators"
+16 if I=33
WRITE !,"Treatment Prognostics"
+17 if I=38
WRITE !,"Management Guides"
+18 SET YSSID=$PIECE(^YTT(601,YSTEST,"S",I,0),U,2)
+19 WRITE !,$PIECE(YSSID," ")
+20 WRITE ?5,$JUSTIFY($PIECE(R,U,I),2)," ",$SELECT($PIECE(S,U,I)'<0:$JUSTIFY($PIECE(S,U,I),3),1:" 0")," "
+21 DO CHART
+22 WRITE ?52,$PIECE(YSSID," ",2,99)
End DoDot:1
if IOST?1"C-".E&($Y>21)
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
+23 ;D NOTEWOR
+24 QUIT
LIKELY ;
+1 NEW X
+2 SET X=$PIECE(S,U,I)
+3 WRITE $SELECT(X="L":"unlikely problem",X="M":"possible problem",X="H":"likely problem",1:"????")
+4 QUIT
CHART ;
+1 NEW X
+2 SET X=$PIECE(S,U,I)
+3 ;W $E("***************************************************************",1,$J(X/3,0,0))
+4 WRITE $EXTRACT("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX",1,$JUSTIFY(X/3,0,0))
+5 QUIT
NOTEWOR ;note worthy responses
+1 DO RD
+2 WRITE !!?10,"*** Noteworthy Responses ***"
+3 FOR I=1,14,28,66,6,117,131,157,3,20,41,62,5,10,103,116,49
Begin DoDot:1
+4 if I=1
WRITE !!?4,"Panic Susceptibility"
+5 if I=6
WRITE !!?4,"Disorientation"
+6 if I=3
WRITE !!?4,"Medical Anxiety"
+7 if I=5
WRITE !!?4,"Adherence Problems"
+8 if I=49
WRITE !!?4,"Suicidal Tendencies"
+9 if $EXTRACT(X,I)="T"
WRITE !,$JUSTIFY(I,3,0),". ",^YTT(601,YSTEST,"Q",I,"T",1,0)
End DoDot:1
if IOST?1"C-".E&($Y>21)
DO SCR^YTREPT
if YSTOUT!YSUOUT
QUIT
+10 IF (($EXTRACT(X,49)="T")&($EXTRACT(X,58)="T"))!(($EXTRACT(X,161)="T")&($EXTRACT(X,58)="T"))
WRITE !," 58. ",^YTT(601,YSTEST,"Q",58,"T",1,0)
+11 IF (($EXTRACT(X,49)="T")&($EXTRACT(X,161)="T"))!(($EXTRACT(X,161)="T")&($EXTRACT(X,58)="T"))
WRITE !,"161. ",^YTT(601,YSTEST,"Q",161,"T",1,0)
