YTSMCMI4 ;BAL/KTL - MHAX ANSWERS SPECIAL HANDLING #2 ; 9/14/18 3:19pm
;;5.01;MENTAL HEALTH;**151,187,202,217,221,234**;Dec 30, 1994;Build 38
;
; MCMI4
;
DLLSTR(YSDATA,YS,YSTRNG) ;
; YSTRNG = 1 Score Instr
; YSTRNG = 2 get Rpt Ans and Text
N YSCNT,YSIND,CNT,YSCOD,YSINVRPT,YSCALRSL,YSRAWRSL,YSQANS,YSQANS2,YSQSCAL,YSNOGRPH,HIARR,SCALOD
N YBRS,YPRS ;Calc Base Rate, Calc PR
N YSNOTE ;Noteworthy
N HIHIT,GRSHIT ;High 3 Persnlty Scale Hit & Grossman >75 Hit
S N=N+1
D INICOD^YTSMCMIB ;YSCOD(scalename)=scalecode
D INIBRS^YTSMCMIC ;YBRS(scalecode,"STR") -get Base Rate for each scale Raw
D INIPRS^YTSMCMID ;YPRS(scalecode,"STR") -get Percentile for scale Raw (Facet)/Adj Base Rate (Non-Facet)
D YSQ^YTSMCMIB ;YSQSCAL(scalcode)=questions. chck if any scales are invld.
D DATA1
I YSTRNG=1 Q
; Genrate Rpt Sections
D MODIND ;Mod Indices
D CPP ;Clin Patterns
D SPP ;Sevr Path
D CS ;Clinical Syndr
D SCS ;Sevr Clinical Syndr
D TOP3 ;3 Highest Grossman Scales
D FACET ;All Facet Scales
D RSLWRN ;Rsl Warning
D NTWRTHY
D RESP ;Set up Responses
Q
DATA1 ;Extract results&calc
;I YSTRNG=1, add up RAW values for scaleN calc adj BR and PR
;I YSTRNG=2, extract from saved values, Do rpt calcs
I YSTRNG=1 D Q
.D EXTANS ;Extrct T/F responses
.D ^YTSMCMIA
D LDSCORES^YTSCORE(.YSDATA,.YS)
;Extract Raw Scale Rsl;Get the High Point;Get BR Adj Hdr;Get V rsl for Invalidity;Get W rsl for Inconsistency
D EXTRSL,EXTANS,HIGHPT,BRADJH,INVDH,INCNH
S YSINVRPT=$$INVRPT() ; See if INVALID Rpt cond
I YSINVRPT'="" D INVALID(YSINVRPT)
D INVSCL ;Any Scale invalid
D ELEV ;Top 3 Grossman
D NOTEW ;Noteworthy Responses
Q
INVRPT() ;
; Check for Invalid Report
; Raw V > 1 ;Invalidity Index elev
; Raw X > 114 ! Raw X < 7 ;Scale X outside range
; All Scales 1-8B Base Rate < 60 ; All scls too low
; Raw W > 19 ;Inconsistency Index elevated
; More than 13 responses skipped for X
; INVRPT of 1 = YES, INVALID
; 0 = NO, OK TO PROCEED
N INVSTR,SCALSTR,SCAL,CHK,XQUES,QUES,I,SKIPS
I YSRAWRSL("V Invalidity")>1 S INVSTR="The Invalidity Index is elevated." Q INVSTR
I YSRAWRSL("X Disclosure")<7!(YSRAWRSL("X Disclosure")>114) S INVSTR="Scale X is outside of an acceptable range." Q INVSTR
S CHK=""
F I=1145:1:1156 D
.S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
.S SCAL=$G(YBRS(SCAL,"RSL"))
.Q:SCAL<60
.S CHK=1
I CHK="" S INVSTR="Scales 1-8B are all less than 60 BR" Q INVSTR
I $G(YSRAWRSL("W Inconsistency"))>19 S INVSTR="The Inconsistency Index is elevated." Q INVSTR
; Check if X scale>13 omits
S XQUES=YSQSCAL("X Disclosure")
S CHK=0
F I=1:1:$L(XQUES,U) D
. S QUES=$P(XQUES,U,I) I YSQANS(QUES)="X" S CHK=CHK+1
I CHK>13 S INVSTR="Scale X omits greater than 13" Q INVSTR
; Check all scale>13 omits
S CHK=0,SCAL=""
;F S SCAL=$O(YSQSCAL(SCAL)) Q:SCAL="" D
;. S XQUES=YSQSCAL(SCAL)
;. F I=1:1:$L(XQUES,U) D
;.. S QUES=$P(XQUES,U,I) Q:QUES="" Q:YSQANS(QUES)'="X"
;.. Q:$D(SKIPS(QUES)) ;already counted from another scale
;.. S CHK=CHK+1,SKIPS(QUES)=""
S QUES="" F S QUES=$O(YSQANS(QUES)) Q:QUES="" D
. Q:YSQANS(QUES)'="X"
. Q:$D(SKIPS(QUES))
. S CHK=CHK+1,SKIPS(QUES)=""
I CHK>13 S INVSTR="Invalid responses greater than 13" Q INVSTR
Q ""
INVALID(INVSTR) ;
; Text for invalid rpt
N I,DONE
S DONE=""
S I="" F S I=$O(YSDATA(I)) Q:I=""!(DONE=1) D
.I YSDATA(I)["7771" S $P(YSDATA(I),U,3)="",DONE=1 ;If INVALID, do not display HP Code
S N=N+1,YSDATA(N)="7783^9999;1^INVALID PROFILE: "_INVSTR_"|"
S YSNOGRPH=1 ;Don't Graph BR Scores
Q
INVSCL ;
;Any scale>2 or 4 omits
N OMITS,SCALSTR,SCAL,QUES,RSL,CNT,I,II
F I=1140:1:1143,1145:1:1169,1240:1:1284 D
.S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
.S CNT=0
.I SCAL="X Disclosure"!(SCAL="W Inconsistency") Q
.S OMITS=4 I SCAL="V Invalidity" S OMITS=2
.F II=1:1:$L(YSQSCAL(SCAL),U) D
..S QUES=$P(YSQSCAL(SCAL),U,II),RSL=YSQANS(QUES)
..I RSL'=1,(RSL'=2) S CNT=CNT+1
.I CNT>OMITS D
..S YSRAWRSL(SCAL)="-"
..S YBRS(SCAL,"RSL")="-"
..S YPRS(SCAL,"RSL")="-"
Q
EXTANS ;
;Extract the T/F from YSDATA
;TRUE=1 FALSE=2
N X,QUEST,ANS,STR,PTR,DATA
S X=2
F S X=$O(YSDATA(X)) Q:+X=0 D
.S DATA=YSDATA(X)
.S ANS=$$GET1^DIQ(601.75,$P($G(DATA),U,3)_",",4,"I")
.S QUES=$P(DATA,U,2),PTR=$P(DATA,U)
.S YSQANS(QUES)=ANS
.S YSQANS(QUES,"PTR")=PTR
.S YSQANS2(PTR)=ANS
Q
EXTRSL ;
; Extract the Raw score-store by Scale Name
N I,SCAL,VAL,BR,PR,RAW,YSAD,YSCALE,G,SCLNAM
S I=1 F S I=$O(^TMP($J,"YSCOR",I)) Q:I="" D
.S VAL=^TMP($J,"YSCOR",I),SCAL=$P(VAL,"="),VAL=$P(VAL,"=",2)
.S RAW=$P(VAL,U),YSRAWRSL(SCAL)=RAW
.S BR=$P(VAL,U,2),BR=$$BRFIX^YTSMCMIA(BR),YBRS(SCAL,"RSL")=BR ;PATCH X
.S PR=$P(VAL,U,3),YPRS(SCAL,"RSL")=PR
.S SCLNAM(SCAL)=I ;^TMP($J,"YSCOR") by scalename-extract calculated results below
D EX2
Q
EX2 ;T-SCORE NOT IN ^TMP($J,"YSCOR")
S YSAD=$G(YS("AD"))
S YSCALE=""
F S YSCALE=$O(^YTT(601.92,"AC",YSAD,YSCALE)) Q:'YSCALE D
.S G=$G(^YTT(601.92,YSCALE,0))
.S SCAL=$P(G,U,3)
.S RAW=$P(G,U,4),BR=$P(G,U,5),BR=$$BRFIX^YTSMCMIA(BR),PR=$P(G,U,6) ;PATCH X
.S YBRS(SCAL,"RSL")=BR
.S YPRS(SCAL,"RSL")=PR
Q
HIGHPT ; Highpoint Hdr
S N=N+1
N TEXT1,SCAL,SCALC,SCALSTR,SCALCOD,I,HI,DONE,SCALR
S TEXT1=""
S SCALCOD="1 ^2A^2B^3 ^4A^4B^5 ^6A^6B^7 ^8A^8B"
F I=1145:1:1156 D
.S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
.S SCALR=$G(YBRS(SCAL,"RSL"))
.Q:SCALR'>59
.S SCALC=YSCOD("NAME",SCAL) S:$L(SCALC)=1 SCALC=SCALC_" " ;Sort numbers vs strings correctly
.S HI(-SCALR,SCALC)=""
S DONE=0,I=0
S SCAL="" F S SCAL=$O(HI(SCAL)) Q:SCAL=""!DONE D
.S SCALC="" F S SCALC=$O(HI(SCAL,SCALC)) Q:SCALC=""!DONE D
..S SCALCOD=SCALC
..S:SCALCOD[" " SCALCOD=+SCALCOD
..S TEXT1=TEXT1_SCALCOD_" ",I=I+1
..I I=3 S DONE=1
I $L(TEXT1)>0 S TEXT1=$E(TEXT1,1,$L(TEXT1)-1)
S YSDATA(N)="7771^9999;1^"_TEXT1
Q
BRADJH ; BR Adjustment Hdr
N X,ACC,A,CC,TEXT1
S TEXT1=""
S X=YSRAWRSL("X Disclosure")
S A=YBRS("A Generalized Anxiety","RSL")
S CC=YBRS("CC Major Depression","RSL")
I ((X>0)&(X<21))!((X>61)&(X<122)) S TEXT1="X"
I (A>74)!(CC>74) S TEXT1=$S(TEXT1="":"A/CC",1:TEXT1_", A/CC")
S:TEXT1="" TEXT1="None"
S N=N+1,YSDATA(N)="7772^9999;1^"_TEXT1
Q
INVDH ; Invalidity Hdr
N TEXT1
S TEXT1=$G(YSRAWRSL("V Invalidity"))
S N=N+1,YSDATA(N)="7773^9999;1^"_TEXT1
Q
INCNH ; Inconsistency Hdr
N TEXT1
S TEXT1=$G(YSRAWRSL("W Inconsistency"))
S N=N+1,YSDATA(N)="7774^9999;1^"_TEXT1
S YSRAWRSL("W Inconsistency")=0
Q
CALCW ; Calc the W Scale
N PAIR
S YSRAWRSL("W Inconsistency")=0
F PAIR="22-170","125-143","47-157","40-181","81-116","85-126","76-150","25-94","44-121","39-59","17-184","33-89","78-164","38-171","74-115","46-154","26-99","20-174","32-122","13-112","55-110","173-194","95-127","60-162","15-149" D
.D WADD(PAIR)
S N=N+1,YSDATA(N)="7774^9999;1^"_YSRAWRSL("W Inconsistency")
Q
WADD(PAIR) ;
N Q1,Q2,ADD
S Q1=$G(YSQANS($P(PAIR,"-"))) S:Q1=2 Q1=0 ;False=0 instead of 2
S Q2=$G(YSQANS($P(PAIR,"-",2))) S:Q2=2 Q2=0 ;
S ADD=$TR((Q1-Q2),"-") ;W ?30,ADD
S YSRAWRSL("W Inconsistency")=YSRAWRSL("W Inconsistency")+ADD
Q
ELEV ; Calc 3 highest Personality Scores from BR
; Order of Importance after BR: S,C,P,1,2A,2B,3,4A,4B,5,6A,6B,7,8A,8B
; Result is HIARR("FINAL")
N SCALSTR,SCAL,SCD,BR,TOPN,CNT,SCCOD,SCDF,SCALF,I,J
F I=1157:1:1159,1145:1:1156 D
.S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
.S BR=YBRS(SCAL,"RSL")
.Q:BR<60
.S HIARR("RSL",-BR,SCAL)=""
S TOPN=3
S CNT=0,BR="" F S BR=$O(HIARR("RSL",BR)) Q:BR=""!(CNT>TOPN) D
.F I=1157:1:1159,1145:1:1156 D
..S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
..Q:CNT>TOPN
..S SCD=YSCOD("NAME",SCAL)
..Q:'$D(HIARR("RSL",BR,SCAL))
..S CNT=CNT+1,HIARR("FINAL",CNT)=SCAL_U_SCD
S SCAL="" F S SCAL=$O(YSCOD("NAME",SCAL)) Q:SCAL="" S SCCOD(YSCOD("NAME",SCAL))=SCAL ;SCCOD of Scale Codes=Scale Name
F I=1:1:TOPN D
.Q:'$D(HIARR("FINAL",I))
.S SCAL=HIARR("FINAL",I),SCD=$P(SCAL,U,2),SCAL=$P(SCAL,U)
.F J=1:1:3 D
..S SCDF=SCD_"."_J,SCALF=SCCOD(SCDF)
..S HIARR("FINAL",I,J)=SCALF_U_SCDF_U_YSRAWRSL(SCALF)_U_YBRS(SCALF,"RSL")_U_YPRS(SCALF,"RSL")
Q
NOTEW ; Noteworthy
; Use YSQANS(question number)=1/2 (True/False)
; YSQANS(question number,"PTR")=pointer to MH QUESTION
N CNT,CAT,QUESTR,QUES,CATTOT
S CNT=1
S CAT="Adult ADHD",CATTOT=0
F QUES=56,77,82,92,108,-63 D SETNOT
I CATTOT<4 K YSNOTE(CNT) ;Must be>=4 endorsed responses
S CNT=CNT+1
S CAT="Autism Spectrum",CATTOT=0
F QUES=92,119,138,163,165,179,190 D SETNOT
I CATTOT<4 K YSNOTE(CNT)
S CNT=CNT+1
S CAT="Childhood Abuse"
F QUES=47,157 D SETNOT
S CNT=CNT+1
S CAT="Eating Disorder"
F QUES=69,86,102,186 D SETNOT
S CNT=CNT+1
S CAT="Emotional Dyscontrol"
F QUES=27,36,45,56,72,80,127,177 D SETNOT
S CNT=CNT+1
S CAT="Explosively Angry"
F QUES=11,74,115,145,168,191 D SETNOT
S CNT=CNT+1
S CAT="Health Preoccupied"
F QUES=7,41,57,113,120,146 D SETNOT
S CNT=CNT+1
S CAT="Interpersonally Alienated"
F QUES=4,104,182,190 D SETNOT
S CNT=CNT+1
S CAT="Prescription Drug Abuse"
F QUES=124,176 D SETNOT
S CNT=CNT+1
S CAT="Self-Destructive Potential"
F QUES=14,32,34,39,59,101,107,114,126,151,164 D SETNOT
S CNT=CNT+1
S CAT="Self-Injurious Behavior/Tendency"
F QUES=40,181 D SETNOT
S CNT=CNT+1
S CAT="Traumatic Brain Injury"
F QUES=55,110 D SETNOT
S CNT=CNT+1
S CAT="Vengefully Prone"
F QUES=22,37,78,100,103,111,136,167,178,192 D SETNOT
Q
SETNOT ;
N CHK
S CHK=1 ;True
I QUES<0 S QUES=-QUES,CHK=2 ;Minus Ques#-check for a False
S ANS=YSQANS(QUES) Q:ANS'=CHK
S:'$D(YSNOTE(CNT,"CAT")) YSNOTE(CNT,"CAT")=CAT
S YSNOTE(CNT,"CAT",QUES)=YSQANS(QUES,"PTR")_U_ANS,CATTOT=CATTOT+1
Q
MODIND ;
N SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
S ANS=7775,STR=" "
S SCALSTR="X Disclosure^Y Desirability^Z Debasement"
D RPTBLK(ANS,SCALSTR)
Q
CPP ;
N SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
S ANS=7776,STR=" "
S SCALSTR="1 Schizoid^2A Avoidant^2B Melancholic^3 Dependent^4A Histrionic^4B Turbulent^5 Narcissistic^6A Antisocial^6B Sadistic^7 Compulsive^8A Negativistic^8B Masochistic"
D RPTBLK1(ANS,SCALSTR)
Q
SPP ;
N SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
S ANS=7777,STR=" "
S SCALSTR="S Schizotypal^C Borderline^P Paranoid"
D RPTBLK1(ANS,SCALSTR)
Q
CS ;
N SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
S ANS=7778,STR=" "
S SCALSTR="A Generalized Anxiety^H Somatic Symptom^N Bipolar Spectrum^D Persistent Depression^B Alcohol Use^T Drug Use^R Post-Traumatic Stress"
D RPTBLK1(ANS,SCALSTR)
Q
SCS ;
N SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
S ANS=7779,STR=" "
S SCALSTR="SS Schizophrenic Spectrum^CC Major Depression^PP Delusional"
D RPTBLK1(ANS,SCALSTR)
Q
TOP3 ;
N SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR,TCNT,TCNT2,HD
S ANS=7780,STR=" ",HIHIT=0
Q:'$D(HIARR)
F TCNT=1:1:3 D
.Q:'$D(HIARR("FINAL",TCNT))
.S HD=HIARR("FINAL",TCNT),SCAL=$P(HD,U),SCALCOD=$P(HD,U,2),HIHIT=1
.S ZTXT=$$MAKSTR(SCAL,39,"L"),STR=STR_ZTXT_"|"
.S TCNT2="" F S TCNT2=$O(HIARR("FINAL",TCNT,TCNT2)) Q:TCNT2="" D
..S HD=HIARR("FINAL",TCNT,TCNT2),SCAL=$P(HD,U),SCALCOD=$P(HD,U,2)
..S RAW=$P(HD,U,3),BR=$P(HD,U,4),PR=$P(HD,U,5)
..S ZTXT=$$MAKSTR(SCAL,39,"L"),STR=STR_ZTXT
..S ZTXT=$$MAKSTR(RAW,4,"R"),STR=STR_ZTXT
..S ZTXT=$$MAKSTR(PR,4,"R"),STR=STR_ZTXT
..S ZTXT=$$MAKSTR(BR,4,"R"),STR=STR_ZTXT
..S GRPH=$$MAKGRP(BR,100),STR=STR_" "_GRPH_"|"
.S STR=STR_"|"
S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR
Q
FACET ;
N SCAL,SCALCOD,GSCAL,GCOD,ZTXT,STR,SCALXRF,I,II
;Make SCALXRF by Scale Code to get to the each Grossman Facet Scale Names
S SCAL="" F S SCAL=$O(YSCOD("NAME",SCAL)) Q:SCAL="" S SCALXRF(YSCOD("NAME",SCAL))=SCAL
S ANS=7781,STR=" ",GRSHIT=0
F I=1145:1:1159 D
.S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
.S SCALCOD=YSCOD("NAME",SCAL)
.S ZTXT=$$MAKSTR(SCAL,39,"L"),STR=STR_ZTXT_"|"
.F II=1:1:3 D
..S GCOD=SCALCOD_"."_II
..S GSCAL=SCALXRF(GCOD)
..S ZTXT=$$MAKSTR(GSCAL,39,"L"),STR=STR_ZTXT
..S RAW=YSRAWRSL(GSCAL),PR=YPRS(GSCAL,"RSL"),BR=YBRS(GSCAL,"RSL")
..I BR>74 S GRSHIT=1 ;At least one Grossman Facet >=75
..S ZTXT=$$MAKSTR(RAW,4,"R"),STR=STR_ZTXT
..S ZTXT=$$MAKSTR(PR,4,"R"),STR=STR_ZTXT
..S ZTXT=$$MAKSTR(BR,4,"R"),STR=STR_ZTXT_"|"
.S STR=STR_"|"
S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR
Q
RSLWRN ; Result warning
N STR
;S HIHIT=1,GRSHIT=0 ;TESTING
Q:HIHIT=0 ;No Personality Scale >= 60
Q:GRSHIT=1 ;At least one Grossman Facet >=75
S STR="Generally, two conditions must be met in order for a Grossman Facet scale score |"
S STR=STR_"to be considered interpretable. The first is that a primary personality scale |"
S STR=STR_"must be at or above BR 60. The second is that one or more of its facet scales |"
S STR=STR_"must be at or above BR 75. Since none of this patient's facet scale scores are|"
S STR=STR_"at or above BR 75, no facet scale interpretations are included in this report.|"
S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR
Q
NTWRTHY ;
N I,II,CAT,QUES,QPTR,QTXT,ZTXT,STR,QANS
Q:'$D(YSNOTE)
S ANS=7782
S STR=" "
S I=0 F S I=$O(YSNOTE(I)) Q:I="" D
.S CAT=YSNOTE(I,"CAT")
.S STR=STR_CAT_"|"
.S QUES="" F S QUES=$O(YSNOTE(I,"CAT",QUES)) Q:QUES="" D
..S ZTXT=$$MAKSTR(QUES_". ",5,"R"),STR=STR_ZTXT
..S QPTR=$P(YSNOTE(I,"CAT",QUES),U),QANS=$P(YSNOTE(I,"CAT",QUES),U,2)
..S QANS=$S(QANS=1:"(True)",QANS=2:"(False)",1:"")
..S QTXT="",II=0 F S II=$O(^YTT(601.72,QPTR,1,II)) Q:+II=0 D
... S QTXT=QTXT_^YTT(601.72,QPTR,1,II,0) ;Space between lines?
..S STR=STR_QTXT_" "_QANS_"|"
.S STR=STR_"|"
S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR
Q
RESP ;
N I,STR,NUM,QUES,ANS
S ANS=7784
S STR="||ITEM RESPONSES |"
I '$D(YSQANS) S STR=STR_"Could not create list of responses for the report|" S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR Q
F I=1:1:195 D
.S NUM=YSQANS(I) I NUM="" S NUM="X"
.S STR=STR_$$MAKSTR(I_": ",5,"R")_NUM_" " I I#10=0 S STR=STR_"|"
S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR
Q
RPTBLK(ANS,SCALSTR) ;
;Report Block no PR
F I=1:1:$L(SCALSTR,U) D
.S SCAL=$P(SCALSTR,U,I),SCALCOD=YSCOD("NAME",SCAL)
.S ZTXT=$$MAKSTR(SCAL,43,"L"),STR=STR_ZTXT
.S RAW=YSRAWRSL(SCAL),BR=YBRS(SCAL,"RSL")
.S ZTXT=$$MAKSTR(RAW,4,"R"),STR=STR_ZTXT
.S ZTXT=$$MAKSTR(BR,4,"R"),STR=STR_ZTXT
.S GRPH=$$MAKGRP(BR,100),STR=STR_" "_GRPH_"|"
S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR
Q
RPTBLK1(ANS,SCALSTR) ;
;Report Block+PR
F I=1:1:$L(SCALSTR,U) D
.S SCAL=$P(SCALSTR,U,I),SCALCOD=YSCOD("NAME",SCAL)
.S ZTXT=$$MAKSTR(SCAL,39,"L"),STR=STR_ZTXT
.S RAW=YSRAWRSL(SCAL),PR=YPRS(SCAL,"RSL"),BR=YBRS(SCAL,"RSL")
.S ZTXT=$$MAKSTR(RAW,4,"R"),STR=STR_ZTXT
.S ZTXT=$$MAKSTR(PR,4,"R"),STR=STR_ZTXT
.S ZTXT=$$MAKSTR(BR,4,"R"),STR=STR_ZTXT
.S GRPH=$$MAKGRP(BR,115),STR=STR_" "_GRPH_"|"
S N=N+1,YSDATA(N)=ANS_"^9999;1^"_STR
Q
MAKSTR(TXT,LEN,JUST,CHAR) ;
; TXT =Text
; LEN =Total Len
; JUST=R/L Justified, def=R
; CHAR=Char PAD, def=" "
N STR,TXTL
S TXTL=$L(TXT),STR=""
I TXT[" " S TXT=$TR(TXT," ",$C(0))
I $G(CHAR)="" S CHAR=" "
I $G(JUST)="" S JUST="R"
I JUST="L" D
.S STR=TXT
.Q:(LEN-TXTL+1)'>1 ;String is full len, don't justify
.S $P(STR,CHAR,LEN-TXTL+1)=""
I JUST="R" D
.I (LEN-TXTL+1)>1 S $P(STR,CHAR,LEN-TXTL+1)=""
.S STR=STR_TXT
S:STR[$C(0) STR=$TR(STR,$C(0)," ") ;XLAT out $C(0)
Q STR
MAKGRP(NUM,MAX) ;
; String of "*" for graph
N GRP,LEN,RND,J,NCHAR
S LEN=50 ;Graph #of Chars.
I NUM="-"!($G(YSNOGRPH)=1) D Q GRP
.S GRP=$$MAKSTR("",LEN,"L")
S NCHAR=LEN/MAX*NUM,RND="."_$P(NCHAR,".",2),NCHAR=$P(NCHAR,".")
I RND>.5 S NCHAR=NCHAR+1
S $P(GRP,"*",NCHAR+1)="",GRP=$$MAKSTR(GRP,LEN,"L")
Q GRP
YSARRAY(YSARRAY) ;
N II,YSVAL,YSCALEI,YSCALEN,YSKEYI,G,YSQN,YSAI,YSAN,YSTARG
K YSARRAY
S II=1
F I=2:1 Q:'$D(^TMP($J,"YSG",I)) I ^TMP($J,"YSG",I)?1"Scale".E D
. S YSCALEI=$P(^TMP($J,"YSG",I),U),YSCALEI=$P(YSCALEI,"=",2)
. S YSCALEN=$P(^TMP($J,"YSG",I),U,4)
. S YSKEYI=0 F S YSKEYI=$O(^YTT(601.91,"AC",YSCALEI,YSKEYI)) Q:YSKEYI'>0 D
..S G=^YTT(601.91,YSKEYI,0)
..S YSQN=$P(G,U,3),YSTARG=$P(G,U,4),YSVAL=$P(G,U,5)
..S YSAI=$O(^YTT(601.85,"AC",YSAD,YSQN,0))
..Q:YSAI'>0
..Q:'$D(^YTT(601.85,YSAI,0))
..S YSAN=""
..I $D(^YTT(601.85,YSAI,1,1,0)) S YSAN=^YTT(601.85,YSAI,1,1,0)
..I $P(^YTT(601.85,YSAI,0),U,4)?1N.N S YSAN=$P(^YTT(601.85,YSAI,0),U,4),YSAN=$G(^YTT(601.75,YSAN,1))
..I YSAN=YSTARG S YSARRAY(II)=YSVAL,II=II+1
..S YSARRAY("SCALE",YSCALEN)=$G(YSARRAY("SCALE",YSCALEN))+YSVAL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSMCMI4 16633 printed Sep 23, 2025@19:56:05 Page 2
YTSMCMI4 ;BAL/KTL - MHAX ANSWERS SPECIAL HANDLING #2 ; 9/14/18 3:19pm
+1 ;;5.01;MENTAL HEALTH;**151,187,202,217,221,234**;Dec 30, 1994;Build 38
+2 ;
+3 ; MCMI4
+4 ;
DLLSTR(YSDATA,YS,YSTRNG) ;
+1 ; YSTRNG = 1 Score Instr
+2 ; YSTRNG = 2 get Rpt Ans and Text
+3 NEW YSCNT,YSIND,CNT,YSCOD,YSINVRPT,YSCALRSL,YSRAWRSL,YSQANS,YSQANS2,YSQSCAL,YSNOGRPH,HIARR,SCALOD
+4 ;Calc Base Rate, Calc PR
NEW YBRS,YPRS
+5 ;Noteworthy
NEW YSNOTE
+6 ;High 3 Persnlty Scale Hit & Grossman >75 Hit
NEW HIHIT,GRSHIT
+7 SET N=N+1
+8 ;YSCOD(scalename)=scalecode
DO INICOD^YTSMCMIB
+9 ;YBRS(scalecode,"STR") -get Base Rate for each scale Raw
DO INIBRS^YTSMCMIC
+10 ;YPRS(scalecode,"STR") -get Percentile for scale Raw (Facet)/Adj Base Rate (Non-Facet)
DO INIPRS^YTSMCMID
+11 ;YSQSCAL(scalcode)=questions. chck if any scales are invld.
DO YSQ^YTSMCMIB
+12 DO DATA1
+13 IF YSTRNG=1
QUIT
+14 ; Genrate Rpt Sections
+15 ;Mod Indices
DO MODIND
+16 ;Clin Patterns
DO CPP
+17 ;Sevr Path
DO SPP
+18 ;Clinical Syndr
DO CS
+19 ;Sevr Clinical Syndr
DO SCS
+20 ;3 Highest Grossman Scales
DO TOP3
+21 ;All Facet Scales
DO FACET
+22 ;Rsl Warning
DO RSLWRN
+23 DO NTWRTHY
+24 ;Set up Responses
DO RESP
+25 QUIT
DATA1 ;Extract results&calc
+1 ;I YSTRNG=1, add up RAW values for scaleN calc adj BR and PR
+2 ;I YSTRNG=2, extract from saved values, Do rpt calcs
+3 IF YSTRNG=1
Begin DoDot:1
+4 ;Extrct T/F responses
DO EXTANS
+5 DO ^YTSMCMIA
End DoDot:1
QUIT
+6 DO LDSCORES^YTSCORE(.YSDATA,.YS)
+7 ;Extract Raw Scale Rsl;Get the High Point;Get BR Adj Hdr;Get V rsl for Invalidity;Get W rsl for Inconsistency
+8 DO EXTRSL
DO EXTANS
DO HIGHPT
DO BRADJH
DO INVDH
DO INCNH
+9 ; See if INVALID Rpt cond
SET YSINVRPT=$$INVRPT()
+10 IF YSINVRPT'=""
DO INVALID(YSINVRPT)
+11 ;Any Scale invalid
DO INVSCL
+12 ;Top 3 Grossman
DO ELEV
+13 ;Noteworthy Responses
DO NOTEW
+14 QUIT
INVRPT() ;
+1 ; Check for Invalid Report
+2 ; Raw V > 1 ;Invalidity Index elev
+3 ; Raw X > 114 ! Raw X < 7 ;Scale X outside range
+4 ; All Scales 1-8B Base Rate < 60 ; All scls too low
+5 ; Raw W > 19 ;Inconsistency Index elevated
+6 ; More than 13 responses skipped for X
+7 ; INVRPT of 1 = YES, INVALID
+8 ; 0 = NO, OK TO PROCEED
+9 NEW INVSTR,SCALSTR,SCAL,CHK,XQUES,QUES,I,SKIPS
+10 IF YSRAWRSL("V Invalidity")>1
SET INVSTR="The Invalidity Index is elevated."
QUIT INVSTR
+11 IF YSRAWRSL("X Disclosure")<7!(YSRAWRSL("X Disclosure")>114)
SET INVSTR="Scale X is outside of an acceptable range."
QUIT INVSTR
+12 SET CHK=""
+13 FOR I=1145:1:1156
Begin DoDot:1
+14 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
+15 SET SCAL=$GET(YBRS(SCAL,"RSL"))
+16 if SCAL<60
QUIT
+17 SET CHK=1
End DoDot:1
+18 IF CHK=""
SET INVSTR="Scales 1-8B are all less than 60 BR"
QUIT INVSTR
+19 IF $GET(YSRAWRSL("W Inconsistency"))>19
SET INVSTR="The Inconsistency Index is elevated."
QUIT INVSTR
+20 ; Check if X scale>13 omits
+21 SET XQUES=YSQSCAL("X Disclosure")
+22 SET CHK=0
+23 FOR I=1:1:$LENGTH(XQUES,U)
Begin DoDot:1
+24 SET QUES=$PIECE(XQUES,U,I)
IF YSQANS(QUES)="X"
SET CHK=CHK+1
End DoDot:1
+25 IF CHK>13
SET INVSTR="Scale X omits greater than 13"
QUIT INVSTR
+26 ; Check all scale>13 omits
+27 SET CHK=0
SET SCAL=""
+28 ;F S SCAL=$O(YSQSCAL(SCAL)) Q:SCAL="" D
+29 ;. S XQUES=YSQSCAL(SCAL)
+30 ;. F I=1:1:$L(XQUES,U) D
+31 ;.. S QUES=$P(XQUES,U,I) Q:QUES="" Q:YSQANS(QUES)'="X"
+32 ;.. Q:$D(SKIPS(QUES)) ;already counted from another scale
+33 ;.. S CHK=CHK+1,SKIPS(QUES)=""
+34 SET QUES=""
FOR
SET QUES=$ORDER(YSQANS(QUES))
if QUES=""
QUIT
Begin DoDot:1
+35 if YSQANS(QUES)'="X"
QUIT
+36 if $DATA(SKIPS(QUES))
QUIT
+37 SET CHK=CHK+1
SET SKIPS(QUES)=""
End DoDot:1
+38 IF CHK>13
SET INVSTR="Invalid responses greater than 13"
QUIT INVSTR
+39 QUIT ""
INVALID(INVSTR) ;
+1 ; Text for invalid rpt
+2 NEW I,DONE
+3 SET DONE=""
+4 SET I=""
FOR
SET I=$ORDER(YSDATA(I))
if I=""!(DONE=1)
QUIT
Begin DoDot:1
+5 ;If INVALID, do not display HP Code
IF YSDATA(I)["7771"
SET $PIECE(YSDATA(I),U,3)=""
SET DONE=1
End DoDot:1
+6 SET N=N+1
SET YSDATA(N)="7783^9999;1^INVALID PROFILE: "_INVSTR_"|"
+7 ;Don't Graph BR Scores
SET YSNOGRPH=1
+8 QUIT
INVSCL ;
+1 ;Any scale>2 or 4 omits
+2 NEW OMITS,SCALSTR,SCAL,QUES,RSL,CNT,I,II
+3 FOR I=1140:1:1143,1145:1:1169,1240:1:1284
Begin DoDot:1
+4 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
+5 SET CNT=0
+6 IF SCAL="X Disclosure"!(SCAL="W Inconsistency")
QUIT
+7 SET OMITS=4
IF SCAL="V Invalidity"
SET OMITS=2
+8 FOR II=1:1:$LENGTH(YSQSCAL(SCAL),U)
Begin DoDot:2
+9 SET QUES=$PIECE(YSQSCAL(SCAL),U,II)
SET RSL=YSQANS(QUES)
+10 IF RSL'=1
IF (RSL'=2)
SET CNT=CNT+1
End DoDot:2
+11 IF CNT>OMITS
Begin DoDot:2
+12 SET YSRAWRSL(SCAL)="-"
+13 SET YBRS(SCAL,"RSL")="-"
+14 SET YPRS(SCAL,"RSL")="-"
End DoDot:2
End DoDot:1
+15 QUIT
EXTANS ;
+1 ;Extract the T/F from YSDATA
+2 ;TRUE=1 FALSE=2
+3 NEW X,QUEST,ANS,STR,PTR,DATA
+4 SET X=2
+5 FOR
SET X=$ORDER(YSDATA(X))
if +X=0
QUIT
Begin DoDot:1
+6 SET DATA=YSDATA(X)
+7 SET ANS=$$GET1^DIQ(601.75,$PIECE($GET(DATA),U,3)_",",4,"I")
+8 SET QUES=$PIECE(DATA,U,2)
SET PTR=$PIECE(DATA,U)
+9 SET YSQANS(QUES)=ANS
+10 SET YSQANS(QUES,"PTR")=PTR
+11 SET YSQANS2(PTR)=ANS
End DoDot:1
+12 QUIT
EXTRSL ;
+1 ; Extract the Raw score-store by Scale Name
+2 NEW I,SCAL,VAL,BR,PR,RAW,YSAD,YSCALE,G,SCLNAM
+3 SET I=1
FOR
SET I=$ORDER(^TMP($JOB,"YSCOR",I))
if I=""
QUIT
Begin DoDot:1
+4 SET VAL=^TMP($JOB,"YSCOR",I)
SET SCAL=$PIECE(VAL,"=")
SET VAL=$PIECE(VAL,"=",2)
+5 SET RAW=$PIECE(VAL,U)
SET YSRAWRSL(SCAL)=RAW
+6 ;PATCH X
SET BR=$PIECE(VAL,U,2)
SET BR=$$BRFIX^YTSMCMIA(BR)
SET YBRS(SCAL,"RSL")=BR
+7 SET PR=$PIECE(VAL,U,3)
SET YPRS(SCAL,"RSL")=PR
+8 ;^TMP($J,"YSCOR") by scalename-extract calculated results below
SET SCLNAM(SCAL)=I
End DoDot:1
+9 DO EX2
+10 QUIT
EX2 ;T-SCORE NOT IN ^TMP($J,"YSCOR")
+1 SET YSAD=$GET(YS("AD"))
+2 SET YSCALE=""
+3 FOR
SET YSCALE=$ORDER(^YTT(601.92,"AC",YSAD,YSCALE))
if 'YSCALE
QUIT
Begin DoDot:1
+4 SET G=$GET(^YTT(601.92,YSCALE,0))
+5 SET SCAL=$PIECE(G,U,3)
+6 ;PATCH X
SET RAW=$PIECE(G,U,4)
SET BR=$PIECE(G,U,5)
SET BR=$$BRFIX^YTSMCMIA(BR)
SET PR=$PIECE(G,U,6)
+7 SET YBRS(SCAL,"RSL")=BR
+8 SET YPRS(SCAL,"RSL")=PR
End DoDot:1
+9 QUIT
HIGHPT ; Highpoint Hdr
+1 SET N=N+1
+2 NEW TEXT1,SCAL,SCALC,SCALSTR,SCALCOD,I,HI,DONE,SCALR
+3 SET TEXT1=""
+4 SET SCALCOD="1 ^2A^2B^3 ^4A^4B^5 ^6A^6B^7 ^8A^8B"
+5 FOR I=1145:1:1156
Begin DoDot:1
+6 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
+7 SET SCALR=$GET(YBRS(SCAL,"RSL"))
+8 if SCALR'>59
QUIT
+9 ;Sort numbers vs strings correctly
SET SCALC=YSCOD("NAME",SCAL)
if $LENGTH(SCALC)=1
SET SCALC=SCALC_" "
+10 SET HI(-SCALR,SCALC)=""
End DoDot:1
+11 SET DONE=0
SET I=0
+12 SET SCAL=""
FOR
SET SCAL=$ORDER(HI(SCAL))
if SCAL=""!DONE
QUIT
Begin DoDot:1
+13 SET SCALC=""
FOR
SET SCALC=$ORDER(HI(SCAL,SCALC))
if SCALC=""!DONE
QUIT
Begin DoDot:2
+14 SET SCALCOD=SCALC
+15 if SCALCOD[" "
SET SCALCOD=+SCALCOD
+16 SET TEXT1=TEXT1_SCALCOD_" "
SET I=I+1
+17 IF I=3
SET DONE=1
End DoDot:2
End DoDot:1
+18 IF $LENGTH(TEXT1)>0
SET TEXT1=$EXTRACT(TEXT1,1,$LENGTH(TEXT1)-1)
+19 SET YSDATA(N)="7771^9999;1^"_TEXT1
+20 QUIT
BRADJH ; BR Adjustment Hdr
+1 NEW X,ACC,A,CC,TEXT1
+2 SET TEXT1=""
+3 SET X=YSRAWRSL("X Disclosure")
+4 SET A=YBRS("A Generalized Anxiety","RSL")
+5 SET CC=YBRS("CC Major Depression","RSL")
+6 IF ((X>0)&(X<21))!((X>61)&(X<122))
SET TEXT1="X"
+7 IF (A>74)!(CC>74)
SET TEXT1=$SELECT(TEXT1="":"A/CC",1:TEXT1_", A/CC")
+8 if TEXT1=""
SET TEXT1="None"
+9 SET N=N+1
SET YSDATA(N)="7772^9999;1^"_TEXT1
+10 QUIT
INVDH ; Invalidity Hdr
+1 NEW TEXT1
+2 SET TEXT1=$GET(YSRAWRSL("V Invalidity"))
+3 SET N=N+1
SET YSDATA(N)="7773^9999;1^"_TEXT1
+4 QUIT
INCNH ; Inconsistency Hdr
+1 NEW TEXT1
+2 SET TEXT1=$GET(YSRAWRSL("W Inconsistency"))
+3 SET N=N+1
SET YSDATA(N)="7774^9999;1^"_TEXT1
+4 SET YSRAWRSL("W Inconsistency")=0
+5 QUIT
CALCW ; Calc the W Scale
+1 NEW PAIR
+2 SET YSRAWRSL("W Inconsistency")=0
+3 FOR PAIR="22-170","125-143","47-157","40-181","81-116","85-126","76-150","25-94","44-121","39-59","17-184","33-89","78-164","38-171","74-115","46-154","26-99","20-174","32-122","13-112","55-110","173-194","95-127","60-162","15-149"
Begin DoDot:1
+4 DO WADD(PAIR)
End DoDot:1
+5 SET N=N+1
SET YSDATA(N)="7774^9999;1^"_YSRAWRSL("W Inconsistency")
+6 QUIT
WADD(PAIR) ;
+1 NEW Q1,Q2,ADD
+2 ;False=0 instead of 2
SET Q1=$GET(YSQANS($PIECE(PAIR,"-")))
if Q1=2
SET Q1=0
+3 ;
SET Q2=$GET(YSQANS($PIECE(PAIR,"-",2)))
if Q2=2
SET Q2=0
+4 ;W ?30,ADD
SET ADD=$TRANSLATE((Q1-Q2),"-")
+5 SET YSRAWRSL("W Inconsistency")=YSRAWRSL("W Inconsistency")+ADD
+6 QUIT
ELEV ; Calc 3 highest Personality Scores from BR
+1 ; Order of Importance after BR: S,C,P,1,2A,2B,3,4A,4B,5,6A,6B,7,8A,8B
+2 ; Result is HIARR("FINAL")
+3 NEW SCALSTR,SCAL,SCD,BR,TOPN,CNT,SCCOD,SCDF,SCALF,I,J
+4 FOR I=1157:1:1159,1145:1:1156
Begin DoDot:1
+5 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
+6 SET BR=YBRS(SCAL,"RSL")
+7 if BR<60
QUIT
+8 SET HIARR("RSL",-BR,SCAL)=""
End DoDot:1
+9 SET TOPN=3
+10 SET CNT=0
SET BR=""
FOR
SET BR=$ORDER(HIARR("RSL",BR))
if BR=""!(CNT>TOPN)
QUIT
Begin DoDot:1
+11 FOR I=1157:1:1159,1145:1:1156
Begin DoDot:2
+12 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
+13 if CNT>TOPN
QUIT
+14 SET SCD=YSCOD("NAME",SCAL)
+15 if '$DATA(HIARR("RSL",BR,SCAL))
QUIT
+16 SET CNT=CNT+1
SET HIARR("FINAL",CNT)=SCAL_U_SCD
End DoDot:2
End DoDot:1
+17 ;SCCOD of Scale Codes=Scale Name
SET SCAL=""
FOR
SET SCAL=$ORDER(YSCOD("NAME",SCAL))
if SCAL=""
QUIT
SET SCCOD(YSCOD("NAME",SCAL))=SCAL
+18 FOR I=1:1:TOPN
Begin DoDot:1
+19 if '$DATA(HIARR("FINAL",I))
QUIT
+20 SET SCAL=HIARR("FINAL",I)
SET SCD=$PIECE(SCAL,U,2)
SET SCAL=$PIECE(SCAL,U)
+21 FOR J=1:1:3
Begin DoDot:2
+22 SET SCDF=SCD_"."_J
SET SCALF=SCCOD(SCDF)
+23 SET HIARR("FINAL",I,J)=SCALF_U_SCDF_U_YSRAWRSL(SCALF)_U_YBRS(SCALF,"RSL")_U_YPRS(SCALF,"RSL")
End DoDot:2
End DoDot:1
+24 QUIT
NOTEW ; Noteworthy
+1 ; Use YSQANS(question number)=1/2 (True/False)
+2 ; YSQANS(question number,"PTR")=pointer to MH QUESTION
+3 NEW CNT,CAT,QUESTR,QUES,CATTOT
+4 SET CNT=1
+5 SET CAT="Adult ADHD"
SET CATTOT=0
+6 FOR QUES=56,77,82,92,108,-63
DO SETNOT
+7 ;Must be>=4 endorsed responses
IF CATTOT<4
KILL YSNOTE(CNT)
+8 SET CNT=CNT+1
+9 SET CAT="Autism Spectrum"
SET CATTOT=0
+10 FOR QUES=92,119,138,163,165,179,190
DO SETNOT
+11 IF CATTOT<4
KILL YSNOTE(CNT)
+12 SET CNT=CNT+1
+13 SET CAT="Childhood Abuse"
+14 FOR QUES=47,157
DO SETNOT
+15 SET CNT=CNT+1
+16 SET CAT="Eating Disorder"
+17 FOR QUES=69,86,102,186
DO SETNOT
+18 SET CNT=CNT+1
+19 SET CAT="Emotional Dyscontrol"
+20 FOR QUES=27,36,45,56,72,80,127,177
DO SETNOT
+21 SET CNT=CNT+1
+22 SET CAT="Explosively Angry"
+23 FOR QUES=11,74,115,145,168,191
DO SETNOT
+24 SET CNT=CNT+1
+25 SET CAT="Health Preoccupied"
+26 FOR QUES=7,41,57,113,120,146
DO SETNOT
+27 SET CNT=CNT+1
+28 SET CAT="Interpersonally Alienated"
+29 FOR QUES=4,104,182,190
DO SETNOT
+30 SET CNT=CNT+1
+31 SET CAT="Prescription Drug Abuse"
+32 FOR QUES=124,176
DO SETNOT
+33 SET CNT=CNT+1
+34 SET CAT="Self-Destructive Potential"
+35 FOR QUES=14,32,34,39,59,101,107,114,126,151,164
DO SETNOT
+36 SET CNT=CNT+1
+37 SET CAT="Self-Injurious Behavior/Tendency"
+38 FOR QUES=40,181
DO SETNOT
+39 SET CNT=CNT+1
+40 SET CAT="Traumatic Brain Injury"
+41 FOR QUES=55,110
DO SETNOT
+42 SET CNT=CNT+1
+43 SET CAT="Vengefully Prone"
+44 FOR QUES=22,37,78,100,103,111,136,167,178,192
DO SETNOT
+45 QUIT
SETNOT ;
+1 NEW CHK
+2 ;True
SET CHK=1
+3 ;Minus Ques#-check for a False
IF QUES<0
SET QUES=-QUES
SET CHK=2
+4 SET ANS=YSQANS(QUES)
if ANS'=CHK
QUIT
+5 if '$DATA(YSNOTE(CNT,"CAT"))
SET YSNOTE(CNT,"CAT")=CAT
+6 SET YSNOTE(CNT,"CAT",QUES)=YSQANS(QUES,"PTR")_U_ANS
SET CATTOT=CATTOT+1
+7 QUIT
MODIND ;
+1 NEW SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
+2 SET ANS=7775
SET STR=" "
+3 SET SCALSTR="X Disclosure^Y Desirability^Z Debasement"
+4 DO RPTBLK(ANS,SCALSTR)
+5 QUIT
CPP ;
+1 NEW SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
+2 SET ANS=7776
SET STR=" "
+3 SET SCALSTR="1 Schizoid^2A Avoidant^2B Melancholic^3 Dependent^4A Histrionic^4B Turbulent^5 Narcissistic^6A Antisocial^6B Sadistic^7 Compulsive^8A Negativistic^8B Masochistic"
+4 DO RPTBLK1(ANS,SCALSTR)
+5 QUIT
SPP ;
+1 NEW SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
+2 SET ANS=7777
SET STR=" "
+3 SET SCALSTR="S Schizotypal^C Borderline^P Paranoid"
+4 DO RPTBLK1(ANS,SCALSTR)
+5 QUIT
CS ;
+1 NEW SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
+2 SET ANS=7778
SET STR=" "
+3 SET SCALSTR="A Generalized Anxiety^H Somatic Symptom^N Bipolar Spectrum^D Persistent Depression^B Alcohol Use^T Drug Use^R Post-Traumatic Stress"
+4 DO RPTBLK1(ANS,SCALSTR)
+5 QUIT
SCS ;
+1 NEW SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR
+2 SET ANS=7779
SET STR=" "
+3 SET SCALSTR="SS Schizophrenic Spectrum^CC Major Depression^PP Delusional"
+4 DO RPTBLK1(ANS,SCALSTR)
+5 QUIT
TOP3 ;
+1 NEW SCALSTR,SCAL,XSCAL,SCALCOD,ZTXT,STR,GRPH,I,ANS,RAW,BR,TCNT,TCNT2,HD
+2 SET ANS=7780
SET STR=" "
SET HIHIT=0
+3 if '$DATA(HIARR)
QUIT
+4 FOR TCNT=1:1:3
Begin DoDot:1
+5 if '$DATA(HIARR("FINAL",TCNT))
QUIT
+6 SET HD=HIARR("FINAL",TCNT)
SET SCAL=$PIECE(HD,U)
SET SCALCOD=$PIECE(HD,U,2)
SET HIHIT=1
+7 SET ZTXT=$$MAKSTR(SCAL,39,"L")
SET STR=STR_ZTXT_"|"
+8 SET TCNT2=""
FOR
SET TCNT2=$ORDER(HIARR("FINAL",TCNT,TCNT2))
if TCNT2=""
QUIT
Begin DoDot:2
+9 SET HD=HIARR("FINAL",TCNT,TCNT2)
SET SCAL=$PIECE(HD,U)
SET SCALCOD=$PIECE(HD,U,2)
+10 SET RAW=$PIECE(HD,U,3)
SET BR=$PIECE(HD,U,4)
SET PR=$PIECE(HD,U,5)
+11 SET ZTXT=$$MAKSTR(SCAL,39,"L")
SET STR=STR_ZTXT
+12 SET ZTXT=$$MAKSTR(RAW,4,"R")
SET STR=STR_ZTXT
+13 SET ZTXT=$$MAKSTR(PR,4,"R")
SET STR=STR_ZTXT
+14 SET ZTXT=$$MAKSTR(BR,4,"R")
SET STR=STR_ZTXT
+15 SET GRPH=$$MAKGRP(BR,100)
SET STR=STR_" "_GRPH_"|"
End DoDot:2
+16 SET STR=STR_"|"
End DoDot:1
+17 SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
+18 QUIT
FACET ;
+1 NEW SCAL,SCALCOD,GSCAL,GCOD,ZTXT,STR,SCALXRF,I,II
+2 ;Make SCALXRF by Scale Code to get to the each Grossman Facet Scale Names
+3 SET SCAL=""
FOR
SET SCAL=$ORDER(YSCOD("NAME",SCAL))
if SCAL=""
QUIT
SET SCALXRF(YSCOD("NAME",SCAL))=SCAL
+4 SET ANS=7781
SET STR=" "
SET GRSHIT=0
+5 FOR I=1145:1:1159
Begin DoDot:1
+6 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
+7 SET SCALCOD=YSCOD("NAME",SCAL)
+8 SET ZTXT=$$MAKSTR(SCAL,39,"L")
SET STR=STR_ZTXT_"|"
+9 FOR II=1:1:3
Begin DoDot:2
+10 SET GCOD=SCALCOD_"."_II
+11 SET GSCAL=SCALXRF(GCOD)
+12 SET ZTXT=$$MAKSTR(GSCAL,39,"L")
SET STR=STR_ZTXT
+13 SET RAW=YSRAWRSL(GSCAL)
SET PR=YPRS(GSCAL,"RSL")
SET BR=YBRS(GSCAL,"RSL")
+14 ;At least one Grossman Facet >=75
IF BR>74
SET GRSHIT=1
+15 SET ZTXT=$$MAKSTR(RAW,4,"R")
SET STR=STR_ZTXT
+16 SET ZTXT=$$MAKSTR(PR,4,"R")
SET STR=STR_ZTXT
+17 SET ZTXT=$$MAKSTR(BR,4,"R")
SET STR=STR_ZTXT_"|"
End DoDot:2
+18 SET STR=STR_"|"
End DoDot:1
+19 SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
+20 QUIT
RSLWRN ; Result warning
+1 NEW STR
+2 ;S HIHIT=1,GRSHIT=0 ;TESTING
+3 ;No Personality Scale >= 60
if HIHIT=0
QUIT
+4 ;At least one Grossman Facet >=75
if GRSHIT=1
QUIT
+5 SET STR="Generally, two conditions must be met in order for a Grossman Facet scale score |"
+6 SET STR=STR_"to be considered interpretable. The first is that a primary personality scale |"
+7 SET STR=STR_"must be at or above BR 60. The second is that one or more of its facet scales |"
+8 SET STR=STR_"must be at or above BR 75. Since none of this patient's facet scale scores are|"
+9 SET STR=STR_"at or above BR 75, no facet scale interpretations are included in this report.|"
+10 SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
+11 QUIT
NTWRTHY ;
+1 NEW I,II,CAT,QUES,QPTR,QTXT,ZTXT,STR,QANS
+2 if '$DATA(YSNOTE)
QUIT
+3 SET ANS=7782
+4 SET STR=" "
+5 SET I=0
FOR
SET I=$ORDER(YSNOTE(I))
if I=""
QUIT
Begin DoDot:1
+6 SET CAT=YSNOTE(I,"CAT")
+7 SET STR=STR_CAT_"|"
+8 SET QUES=""
FOR
SET QUES=$ORDER(YSNOTE(I,"CAT",QUES))
if QUES=""
QUIT
Begin DoDot:2
+9 SET ZTXT=$$MAKSTR(QUES_". ",5,"R")
SET STR=STR_ZTXT
+10 SET QPTR=$PIECE(YSNOTE(I,"CAT",QUES),U)
SET QANS=$PIECE(YSNOTE(I,"CAT",QUES),U,2)
+11 SET QANS=$SELECT(QANS=1:"(True)",QANS=2:"(False)",1:"")
+12 SET QTXT=""
SET II=0
FOR
SET II=$ORDER(^YTT(601.72,QPTR,1,II))
if +II=0
QUIT
Begin DoDot:3
+13 ;Space between lines?
SET QTXT=QTXT_^YTT(601.72,QPTR,1,II,0)
End DoDot:3
+14 SET STR=STR_QTXT_" "_QANS_"|"
End DoDot:2
+15 SET STR=STR_"|"
End DoDot:1
+16 SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
+17 QUIT
RESP ;
+1 NEW I,STR,NUM,QUES,ANS
+2 SET ANS=7784
+3 SET STR="||ITEM RESPONSES |"
+4 IF '$DATA(YSQANS)
SET STR=STR_"Could not create list of responses for the report|"
SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
QUIT
+5 FOR I=1:1:195
Begin DoDot:1
+6 SET NUM=YSQANS(I)
IF NUM=""
SET NUM="X"
+7 SET STR=STR_$$MAKSTR(I_": ",5,"R")_NUM_" "
IF I#10=0
SET STR=STR_"|"
End DoDot:1
+8 SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
+9 QUIT
RPTBLK(ANS,SCALSTR) ;
+1 ;Report Block no PR
+2 FOR I=1:1:$LENGTH(SCALSTR,U)
Begin DoDot:1
+3 SET SCAL=$PIECE(SCALSTR,U,I)
SET SCALCOD=YSCOD("NAME",SCAL)
+4 SET ZTXT=$$MAKSTR(SCAL,43,"L")
SET STR=STR_ZTXT
+5 SET RAW=YSRAWRSL(SCAL)
SET BR=YBRS(SCAL,"RSL")
+6 SET ZTXT=$$MAKSTR(RAW,4,"R")
SET STR=STR_ZTXT
+7 SET ZTXT=$$MAKSTR(BR,4,"R")
SET STR=STR_ZTXT
+8 SET GRPH=$$MAKGRP(BR,100)
SET STR=STR_" "_GRPH_"|"
End DoDot:1
+9 SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
+10 QUIT
RPTBLK1(ANS,SCALSTR) ;
+1 ;Report Block+PR
+2 FOR I=1:1:$LENGTH(SCALSTR,U)
Begin DoDot:1
+3 SET SCAL=$PIECE(SCALSTR,U,I)
SET SCALCOD=YSCOD("NAME",SCAL)
+4 SET ZTXT=$$MAKSTR(SCAL,39,"L")
SET STR=STR_ZTXT
+5 SET RAW=YSRAWRSL(SCAL)
SET PR=YPRS(SCAL,"RSL")
SET BR=YBRS(SCAL,"RSL")
+6 SET ZTXT=$$MAKSTR(RAW,4,"R")
SET STR=STR_ZTXT
+7 SET ZTXT=$$MAKSTR(PR,4,"R")
SET STR=STR_ZTXT
+8 SET ZTXT=$$MAKSTR(BR,4,"R")
SET STR=STR_ZTXT
+9 SET GRPH=$$MAKGRP(BR,115)
SET STR=STR_" "_GRPH_"|"
End DoDot:1
+10 SET N=N+1
SET YSDATA(N)=ANS_"^9999;1^"_STR
+11 QUIT
MAKSTR(TXT,LEN,JUST,CHAR) ;
+1 ; TXT =Text
+2 ; LEN =Total Len
+3 ; JUST=R/L Justified, def=R
+4 ; CHAR=Char PAD, def=" "
+5 NEW STR,TXTL
+6 SET TXTL=$LENGTH(TXT)
SET STR=""
+7 IF TXT[" "
SET TXT=$TRANSLATE(TXT," ",$CHAR(0))
+8 IF $GET(CHAR)=""
SET CHAR=" "
+9 IF $GET(JUST)=""
SET JUST="R"
+10 IF JUST="L"
Begin DoDot:1
+11 SET STR=TXT
+12 ;String is full len, don't justify
if (LEN-TXTL+1)'>1
QUIT
+13 SET $PIECE(STR,CHAR,LEN-TXTL+1)=""
End DoDot:1
+14 IF JUST="R"
Begin DoDot:1
+15 IF (LEN-TXTL+1)>1
SET $PIECE(STR,CHAR,LEN-TXTL+1)=""
+16 SET STR=STR_TXT
End DoDot:1
+17 ;XLAT out $C(0)
if STR[$CHAR(0)
SET STR=$TRANSLATE(STR,$CHAR(0)," ")
+18 QUIT STR
MAKGRP(NUM,MAX) ;
+1 ; String of "*" for graph
+2 NEW GRP,LEN,RND,J,NCHAR
+3 ;Graph #of Chars.
SET LEN=50
+4 IF NUM="-"!($GET(YSNOGRPH)=1)
Begin DoDot:1
+5 SET GRP=$$MAKSTR("",LEN,"L")
End DoDot:1
QUIT GRP
+6 SET NCHAR=LEN/MAX*NUM
SET RND="."_$PIECE(NCHAR,".",2)
SET NCHAR=$PIECE(NCHAR,".")
+7 IF RND>.5
SET NCHAR=NCHAR+1
+8 SET $PIECE(GRP,"*",NCHAR+1)=""
SET GRP=$$MAKSTR(GRP,LEN,"L")
+9 QUIT GRP
YSARRAY(YSARRAY) ;
+1 NEW II,YSVAL,YSCALEI,YSCALEN,YSKEYI,G,YSQN,YSAI,YSAN,YSTARG
+2 KILL YSARRAY
+3 SET II=1
+4 FOR I=2:1
if '$DATA(^TMP($JOB,"YSG",I))
QUIT
IF ^TMP($JOB,"YSG",I)?1"Scale".E
Begin DoDot:1
+5 SET YSCALEI=$PIECE(^TMP($JOB,"YSG",I),U)
SET YSCALEI=$PIECE(YSCALEI,"=",2)
+6 SET YSCALEN=$PIECE(^TMP($JOB,"YSG",I),U,4)
+7 SET YSKEYI=0
FOR
SET YSKEYI=$ORDER(^YTT(601.91,"AC",YSCALEI,YSKEYI))
if YSKEYI'>0
QUIT
Begin DoDot:2
+8 SET G=^YTT(601.91,YSKEYI,0)
+9 SET YSQN=$PIECE(G,U,3)
SET YSTARG=$PIECE(G,U,4)
SET YSVAL=$PIECE(G,U,5)
+10 SET YSAI=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,0))
+11 if YSAI'>0
QUIT
+12 if '$DATA(^YTT(601.85,YSAI,0))
QUIT
+13 SET YSAN=""
+14 IF $DATA(^YTT(601.85,YSAI,1,1,0))
SET YSAN=^YTT(601.85,YSAI,1,1,0)
+15 IF $PIECE(^YTT(601.85,YSAI,0),U,4)?1N.N
SET YSAN=$PIECE(^YTT(601.85,YSAI,0),U,4)
SET YSAN=$GET(^YTT(601.75,YSAN,1))
+16 IF YSAN=YSTARG
SET YSARRAY(II)=YSVAL
SET II=II+1
+17 SET YSARRAY("SCALE",YSCALEN)=$GET(YSARRAY("SCALE",YSCALEN))+YSVAL
End DoDot:2
End DoDot:1
+18 QUIT
