- 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 Feb 18, 2025@23:46:16 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