YTMBMD2 ;ALB/ASF-MBMD ; 2/14/12 1:26pm
;;5.01;MENTAL HEALTH;**105**;Dec 30, 1994;Build 76
;No external references
PERCENT ; bariatric untransformed prevalence scores
F I=69:1:97 S $P(S,U,I)=$P(^YTT(601,YSTEST,"S",I,YSSEX),U,$P(R,U,I)+1)
Q
PAINREP ; pain pt report
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 !,"*** Pain Patient Percentiles ***"
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=69:1:97 D D:IOST?1"C-".E&($Y>21) SCR^YTREPT Q:YSTOUT!YSUOUT
. W:I=69 !,"Psychiatric Indications"
. W:I=74 !,"Coping Styles"
. W:I=85 !,"Stress Moderators"
. W:I=91 !,"Treatment Prognostics"
. W:I=96 !,"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)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTMBMD2 1576 printed Dec 13, 2024@02:17:28 Page 2
YTMBMD2 ;ALB/ASF-MBMD ; 2/14/12 1:26pm
+1 ;;5.01;MENTAL HEALTH;**105**;Dec 30, 1994;Build 76
+2 ;No external references
PERCENT ; bariatric untransformed prevalence scores
+1 FOR I=69:1:97
SET $PIECE(S,U,I)=$PIECE(^YTT(601,YSTEST,"S",I,YSSEX),U,$PIECE(R,U,I)+1)
+2 QUIT
PAINREP ; pain pt report
+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 !,"*** Pain Patient Percentiles ***"
+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=69:1:97
Begin DoDot:1
+13 if I=69
WRITE !,"Psychiatric Indications"
+14 if I=74
WRITE !,"Coping Styles"
+15 if I=85
WRITE !,"Stress Moderators"
+16 if I=91
WRITE !,"Treatment Prognostics"
+17 if I=96
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 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
