- 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 Feb 18, 2025@23:43:43 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)