- YTSMCMIA ;BAL/KTL - Extension of YTSMCMI4 MHA ANSWERS SPECIAL HANDLING ; 9/14/18 3:19pm
- ;;5.01;MENTAL HEALTH;**151,187,217**;Dec 30, 1994;Build 12
- ;
- ; MCMI4 Scoring
- ;
- ; Handle initial scoring and saving of administration
- ; Invoked from DATA1^YTSMCMI4 when YSTRING=1
- D ADDRSL ;Add the MH Score Keys for each scale
- D CALW
- D BR ;Get the Base Rate Score
- D BRADJ1 ;Do the first Adjustment to the Base Rate
- D BRADJ2 ;Do second Adjustment to the Base Rate
- D PR ;Get the Percentile Ranking
- D SCORESV
- Q
- ADDRSL ;Add up the related scored answers for each scale
- N LINE,TEXT,NXTQUES,XI
- F LINE=1:1 S TEXT=$P($T(SCOREDAT+LINE),";",2) Q:TEXT="QUIT" D
- .N SCALE,RAWTYPE,SCLRAW,QUESTIONS,I,SNAM,RVAL,ADVAL,NXTLIN,NXTSCL
- .S SCLRAW=$P(TEXT,"|",1,2),SCALE=$P(TEXT,"|",1) S RAWTYPE=$P(TEXT,"|",2) S QUESTIONS=$P(TEXT,"|",3)
- .S NXTLIN=$P($T(SCOREDAT+LINE+1),";",2) ;For lines with too many questions, split into two $T lines
- .S NXTSCL=$P(NXTLIN,"|",1,2)
- .I NXTSCL=SCLRAW D
- ..S NXTQUES=$P(NXTLIN,"|",3)
- ..S QUESTIONS=QUESTIONS_"^"_NXTQUES
- ..S LINE=LINE+1
- .S SNAM=$$GET1^DIQ(601.87,SCALE_",",3,"I")
- .S RVAL=$P(RAWTYPE,"_"),ADVAL=$P(RAWTYPE,"_",2)
- .F XI=1:1:$L(QUESTIONS,U) D
- ..N NODE,DATA,RAW
- ..S NODE=$P(QUESTIONS,U,XI)+2 ;YSDATA question nodes start at 3
- ..S DATA=YSDATA(NODE)
- ..S RAW=$$GET1^DIQ(601.75,$P($G(DATA),U,3)_",",4,"I")
- ..;retrieval method section. For each RAWTYPE assign a value to RAW
- ..;typical case, YSDATA piece 3 has the MH CHOICE IEN and raw value is in LEGACY field
- ..; For MCMI4 exception where additive value depends on the scale.
- ..; Therefore additive value defined in table as second "_" piece of the RAWTYPE
- ..; First "_" piece is the legacy value of MH CHOICE - 1=True 2=False
- ..I RAW=RVAL S YSRAWRSL(SNAM)=$G(YSRAWRSL(SNAM))+ADVAL
- .I '$D(YSRAWRSL(SNAM)) S YSRAWRSL(SNAM)=0
- Q
- N I,SNAM,TOT,MHK,QUES,TAR,VAL,ANS
- K YSRAWRSL
- F I=1140:1:1143,1145:1:1169,1240:1:1284 D ;1142 VS 1143?
- .S SNAM=$$GET1^DIQ(601.87,I_",",3,"I")
- .S TOT=0
- .S MHK=0 F S MHK=$O(^YTT(601.91,"AC",I,MHK)) Q:+MHK=0 D
- ..S QUES=$$GET1^DIQ(601.91,MHK_",",2,"I")
- ..S TAR=$$GET1^DIQ(601.91,MHK_",",3,"I")
- ..S VAL=$$GET1^DIQ(601.91,MHK_",",4,"I")
- ..S ANS=$G(YSQANS2(QUES)),ANS=$S(ANS=1:"True",ANS=2:"False",1:"")
- ..I ANS=TAR S TOT=TOT+VAL
- .;Save each scale in the YSRAWRSL(scalnam) array which is the format
- .;the calculations expect them to be in.
- .S YSRAWRSL(SNAM)=TOT
- Q
- SCOREDAT ;SCALE IEN|RAW VALUE STORAGE TYPE|QUES#^QUES#...
- ;1140|1_1|2^4^5^6^8^9^10^11^12^15^16^17^19^20^21^22^23^24^26^29^30^32^35^36^37^38^39^42^43^46^48^50^51^52^53^54^59^60^63^65^66^67^70^71^72^73^74^75^77^79^82^83^84^85^87^88^90^92^93^96^97^99^100^103^105^106^109^111^112^115^117^119^120
- ;1140|1_1|122^126^128^129^132^133^135^137^139^140^141^142^145^147^149^152^154^155^156^158^159^162^164^166^167^168^169^170^171^172^173^174^175^178^179^180^183^184^185^187^188^189^190^191^192^193^194^195
- ;1141|2_1|65^71^90^99^159^162^187
- ;1141|1_1|2^3^8^20^30^46^67^73^75^84^154^155^158^173^174^185^188
- ;1142|1_1|1^14^16^17^18^22^28^31^32^34^37^39^41^44^51^64^74^78^80^101^107^109^112^113^120^151^164^170^178^193
- ;1143|1_1|49^98^160
- ;1145|2_1|30^154
- ;1145|1_1|17^24^70^92^190
- ;1145|1_2|6^15^43^90^119^139^149^180
- ;1146|2_1|46^67^154
- ;1146|1_1|23^24^52^92^93^112^178^184^193
- ;1146|1_2|5^12^26^99^135^195
- ;1147|2_1|53
- ;1147|1_1|17^22^39^59^70^90^126^170^178
- ;1147|1_2|23^51^71^93^111^169^175^184^193
- ;1148|2_1|67
- ;1148|1_1|5^23^72^175
- ;1148|1_2|4^42^60^77^109^133^162^173^194
- ;1149|2_1|6^15^24^26^139^178^195
- ;1149|1_1|8^75^155
- ;1149|1_2|10^30^46^84^117^154^171
- ;1150|2_1|26^120^178
- ;1150|1_1|30^46^67^84^142^154
- ;1150|1_2|8^20^53^75^129^155^174^185
- ;1151|1_1|10^19^83^117^171^191
- ;1151|1_2|29^38^54^67^87^106^132^142^159^189
- ;1152|2_1|48^158
- ;1152|1_1|36^38^105^152^159
- ;1152|1_2|11^19^65^83^147^183^191
- ;1153|1_1|11^16^21^74^145^172
- ;1153|1_2|9^50^66^97^103^115^141^152
- ;1154|2_1|83^147^152
- ;1154|1_2|2^35^48^63^73^128^140^158^179^188
- ;1155|1_1|21^37^52^79^88^97^100^168^172^184
- ;1155|1_2|17^32^82^96^122^137^167^187
- ;1156|2_1|20^75
- ;1156|1_1|4^12^23^70^93^156^164^178^195
- ;1156|1_2|39^59^85^100^126^166^192
- ;1157|1_1|18^58^70^90^93^121^123^126^148^163^167^172^195
- ;1157|1_2|13^24^44^92^112^156^165^190
- ;1158|1_1|4^59^80^82^93^100^111^126^137^156^166^192^193
- ;1158|1_2|16^18^37^70^134^164^178
- ;1159|1_1|13^24^68^96^148^167^180^195
- ;1159|1_2|21^52^79^88^104^136^153^172
- ;1160|1_1|33^41^44^51^91^108^109
- ;1160|1_2|31^72^89^113^123^143
- ;1161|2_1|20
- ;1161|1_1|1^57^113^118
- ;1161|1_2|7^28^41^120^146
- ;1162|1_1|37^50^54^82^83^105^155
- ;1162|1_2|3^27^56^108^163^177
- ;1163|2_1|75
- ;1163|1_1|17^28^39^51^71^77^85^93^101^111^114^120^178^193
- ;1163|1_2|14^34^64^118^151^170
- ;1164|1_1|65^83^126
- ;1164|1_2|25^45^94^130^161
- ;1165|2_1|158
- ;1165|1_1|11^65^152
- ;1165|1_2|36^61^81^105^116^124^144
- ;1166|1_1|44^47^57^74^89^110^113^143^157
- ;1166|1_2|62^76^91^125^150
- ;1167|1_1|18^24^52^82^89^92^95^104^123^136^148^156^165^172^182
- ;1167|1_2|33^58^80^121^131^138
- ;1168|1_1|28^41^59^64^70^80^111^118^120^170
- ;1168|1_2|1^22^57^78^101^107^114
- ;1169|1_1|13^54^79^88^112^121^136^172^189
- ;1169|1_2|68^95^127^148^182
- ;1240|2_1|154^185
- ;1240|1_1|12^15^24^104^149^180^190
- ;1241|2_1|30^46^67
- ;1241|1_1|26^99^139^175^178^195
- ;1242|1_1|6^17^43^70^90^92^111^118^119
- ;1243|2_1|30^46^84^154
- ;1243|1_1|15^26^99^139
- ;1244|2_1|67
- ;1244|1_1|23^58^111^135^156^178^192^193
- ;1245|1_1|5^12^24^52^92^93^112^184^195
- ;1246|1_1|17^23^33^51^52^71^89^126^184
- ;1247|1_1|39^59^93^112^169^175^178^192^195
- ;1248|2_1|53
- ;1248|1_1|22^70^90^101^107^111^170^193
- ;1249|1_1|4^5^23^51^72^99^109^135^184
- ;1250|2_1|185
- ;1250|1_1|26^60^162^169^173^194
- ;1251|2_1|53^67
- ;1251|1_1|42^77^85^93^133^151^175
- ;1252|1_1|10^38^83^117^132^142^171
- ;1253|2_1|6^15^24^26^139^195
- ;1253|1_1|30^46^84^154
- ;1254|2_1|135^170^178
- ;1254|1_1|8^20^27^53^67^75^155^174^185
- ;1255|1_1|8^20^53^75^129^155^174^185
- ;1256|2_1|5^26^149
- ;1256|1_1|10^30^46^84^117^154
- ;1257|2_1|14^93^120^156^175^178
- ;1257|1_1|67^142
- ;1258|1_1|10^19^38^83^117^132^159^171^183
- ;1259|2_1|93^178
- ;1259|1_1|8^67^75^142^154^155^174^185
- ;1260|1_1|29^54^79^87^106^180^189^191
- ;1261|2_1|188
- ;1261|1_1|10^38^83^103^159^171^183
- ;1262|2_1|48^73^158
- ;1262|1_1|11^19^147^152^153^168^191
- ;1263|2_1|63
- ;1263|1_1|25^36^61^65^85^105^126^130^144
- ;1264|1_1|9^11^65^66^88^103^152^153^159^172^191
- ;1265|1_1|19^21^50^97^141^166^187
- ;1266|1_1|16^37^74^115^137^145^168
- ;1267|2_1|85^118
- ;1267|1_1|2^20^35^63^174^188
- ;1268|1_1|23^44^51^52^99^128^131^135^137^140^169^179
- ;1269|2_1|19^83^147^152^183^191
- ;1269|1_1|48^73^158
- ;1270|1_1|21^32^79^88^96^100^122^167^172
- ;1271|2_1|75
- ;1271|1_1|12^17^24^34^39^51^52^59^153^184
- ;1272|1_1|9^37^74^82^97^115^137^145^168^187
- ;1273|1_1|4^12^23^39^52^59^70^93^164^178^192^195
- ;1274|1_1|17^40^85^100^126^156^166^167^184
- ;1275|2_1|20^53^67^75^154^155
- ;1275|1_1|92^107^170
- ;1276|1_1|18^33^44^89^92^121^123^131^163
- ;1277|2_1|154
- ;1277|1_1|5^58^70^90^93^111^126^156^165^195
- ;1278|1_1|13^24^68^79^88^106^112^148^167^172^190
- ;1279|1_1|14^70^101^111^151^156^170^178
- ;1280|1_1|4^17^39^59^93^100^126^134^166^192^193
- ;1281|1_1|16^18^37^74^80^82^115^137^164^187
- ;1282|1_1|12^15^21^24^104^149^153^180^195
- ;1283|1_1|17^52^79^88^172^182^184
- ;1284|1_1|13^32^68^96^106^112^122^136^148^167
- ;QUIT
- Q
- CALW ; Calculate 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 is 0 instead of 2
- S Q2=$G(YSQANS($P(PAIR,"-",2))) S:Q2=2 Q2=0 ;False is 0 instead of 2
- S ADD=$TR((Q1-Q2),"-") ;W ?30,ADD
- S YSRAWRSL("W Inconsistency")=YSRAWRSL("W Inconsistency")+ADD
- Q
- SCORESV ;
- N CNT,I,SEQ,SNAM,SCARR
- K ^TMP($J,"YSCOR")
- ;F SNAM="W Inconsistency","V Invalidity" D
- ;. S YBRS(SNAM,"RSL")=$G(YSRAWRSL(SNAM)) ;Patch to be able to graph the raw results for these two scales
- ;. ;There is no Base Rate or Percentile for these two calculated scales so need to substitute raw for br
- S ^TMP($J,"YSCOR",1)="[ERROR]"
- S CNT=1
- F I=1140:1:1169,1240:1:1284 D ;1142 VS 1143? ADDED 1144 BACK IN FOR W INCONSISTENCY
- .S SEQ=$$GET1^DIQ(601.87,I_",",2,"I")
- .S SNAM=$$GET1^DIQ(601.87,I_",",3,"I")
- .S SCARR(I)=SNAM ;Have to figure out Scale Order on Report - Maybe doesn't matter
- S SEQ=0 F S SEQ=$O(SCARR(SEQ)) Q:SEQ="" D
- .S CNT=CNT+1
- .S SNAM=SCARR(SEQ)
- .;S ^TMP($J,"YSCOR",CNT)=SNAM_"="_$G(YBRS(SNAM,"RSL"))_"^"_YSRAWRSL(SNAM)_"^"_$G(YPRS(SNAM,"RSL"))
- .S ^TMP($J,"YSCOR",CNT)=SNAM_"="_$G(YSRAWRSL(SNAM))_"^"_$G(YBRS(SNAM,"RSL"))_"^"_$G(YPRS(SNAM,"RSL"))
- S ^TMP($J,"YSCOR",1)="[DATA]"
- Q
- EXTANS ;
- ;Extract the T/F responses to each question from YSDATA array
- ;TRUE=1 FALSE=2
- N X,QUEST,ANS,STR,PTR
- S X=2
- F S X=$O(YSDATA(X)) Q:+X=0 D
- .S STR=YSDATA(X),QUES=$P(STR,"^",2),ANS=$P(STR,"^",3),PTR=$P(STR,"^")
- .S ANS=$S(ANS=3919:1,ANS=3920:2,1:"")
- .S YSQANS(QUES)=ANS
- .S YSQANS(QUES,"PTR")=PTR
- .S YSQANS2(PTR)=ANS
- Q
- BR ;Get the Base Rate for each scale
- N SCALSTR,SCAL,PCE,I
- F I=1140:1:1142,1145:1:1169,1240:1:1284 D
- .;S SCAL=^YTT(601.87,I,0)
- .S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- .S RAW=$G(YSRAWRSL(SCAL))
- .S YBRS(SCAL,"RSL")=$P(YBRS(SCAL,"STR"),"^",RAW+1) ;Note RAW+1 because raw values start at 0
- Q
- BRADJ1 ;Adjust the Base Rate score for scales 1-8B and S-PP depending on the X Raw Score
- N SCALSTR,ADJARR,I,SCAL,BR,ADJ,XRAW
- ;1-8B
- F STEND="0^6;0","7^7;10","8^8;9","9^9;8","10^10;7","11^11;6","12^12;5","13^14;4","15^16;3","17^18;2","19^20;1","21^60;0" D
- .D SETADJ(STEND)
- F STEND="61^66;-1","67^71;-2","72^76;-3","77^82;-4","83^87;-5","88^93;-6","94^98;-7","99^104;-8","105^109;-9","110^114;-10","115^121;0" D
- .D SETADJ(STEND)
- S XRAW=YSRAWRSL("X Disclosure")
- S ADJ=ADJARR(XRAW) ;Get the adjustment value based on the Raw X Disclosure Scale value
- F I=1145:1:1156 D
- .S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- .S BR=YBRS(SCAL,"RSL")
- .S BR=BR+ADJ
- .S BR=$$BRFIX(BR)
- .S YBRS(SCAL,"RSL")=BR
- K ADJARR
- ;S-PP
- F STEND="0^6;0","7^8;5","9^10;4","11^12;3","13^16;2","17^20;1","21^60;0" D
- .D SETADJ(STEND)
- F STEND="61^71;-1","72^82;-2","83^93;-3","94^100;-4","101^114;-5","115^121;0" D
- .D SETADJ(STEND)
- S ADJ=ADJARR(XRAW) ;Get the adjustment value based on the Raw X Disclosure Scale value for S-PP
- F I=1157:1:1169 D
- .S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- .S BR=YBRS(SCAL,"RSL")
- .S BR=BR+ADJ
- .S BR=$$BRFIX(BR)
- .S YBRS(SCAL,"RSL")=BR
- Q
- SETADJ(STEND) ; Set up the Base Rate Adjustment Array
- N BEG,END,VAL,I
- S BEG=$P(STEND,";"),END=$P(BEG,"^",2),BEG=$P(BEG,"^"),VAL=$P(STEND,";",2)
- F I=BEG:1:END S ADJARR(I)=VAL
- Q
- BRADJ2 ;Adjust the Base Rate based on Scales A and CC
- N ACC,ABR,CCBR,ADJARR,I
- S ABR=$G(YBRS("A Generalized Anxiety","RSL"))
- S CCBR=$G(YBRS("CC Major Depression","RSL"))
- Q:((ABR<75)!(CCBR<75))
- S ACC=(ABR-75)+(CCBR-75)
- F STEND="0^4;-1","5^9;-2","10^14;-3","15^19;-4","20^24;-5","25^29;-5","30^34;-6","35^39;-6","40^44;-7","45^49;-7","50^54;-8","55^59;-8","60^64;-9","65^69;-9","70^75;-10","76^80;-10" D
- .D SETADJ(STEND)
- S ADJ=ADJARR(ACC)
- F I=1147,1156,1158 D
- .S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- .S BR=YBRS(SCAL,"RSL")
- .S BR=BR+ADJ
- .S BR=$$BRFIX(BR)
- .S YBRS(SCAL,"RSL")=BR
- F STEND="0^4;-1","5^9;-1","10^14;-2","15^19;-2","20^24;-3","25^29;-3","30^34;-3","35^39;-3","40^44;-4","45^49;-4","50^54;-4","55^59;-4","60^64;-5","65^69;-5","70^75;-5","76^80;-5" D
- .D SETADJ(STEND)
- S ADJ=ADJARR(ACC)
- F I=1146,1157 D
- .S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- .S BR=YBRS(SCAL,"RSL")
- .S BR=BR+ADJ
- .S BR=$$BRFIX(BR)
- .S YBRS(SCAL,"RSL")=BR
- Q
- PR ;Get the Percentile for each scale based on adjusted Base Rate for Personality/Psychopathology
- ; Get the Percentile for each Facet Scale based on RAW score for Grossman Facet Scales
- N SCALSTR,SCAL,PCE,I,RAW,BR
- F I=1145:1:1169,1240:1:1284 D
- .;S SCAL=^YTT(601.87,I,0)
- .S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- .S BR=$G(YBRS(SCAL,"RSL"))
- .S YPRS(SCAL,"RSL")=$P(YPRS(SCAL,"STR"),"^",BR+1) ;Note RAW+1 because raw values start at 0
- ;Grossman Facet Percentile
- F I=1240:1:1284 D
- .S SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- .S RAW=$G(YSRAWRSL(SCAL))
- .S YPRS(SCAL,"RSL")=$P(YPRS(SCAL,"STR"),"^",RAW+1) ;Note RAW+1 because raw values start at 0
- Q
- BRFIX(VAL) ;If adjusted base rate <0 set to 0. If >115 set to 115 PATCH X
- I VAL<0 S VAL=0
- I VAL>115 S VAL=115
- Q VAL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSMCMIA 12867 printed Mar 13, 2025@21:24:51 Page 2
- YTSMCMIA ;BAL/KTL - Extension of YTSMCMI4 MHA ANSWERS SPECIAL HANDLING ; 9/14/18 3:19pm
- +1 ;;5.01;MENTAL HEALTH;**151,187,217**;Dec 30, 1994;Build 12
- +2 ;
- +3 ; MCMI4 Scoring
- +4 ;
- +5 ; Handle initial scoring and saving of administration
- +6 ; Invoked from DATA1^YTSMCMI4 when YSTRING=1
- +7 ;Add the MH Score Keys for each scale
- DO ADDRSL
- +8 DO CALW
- +9 ;Get the Base Rate Score
- DO BR
- +10 ;Do the first Adjustment to the Base Rate
- DO BRADJ1
- +11 ;Do second Adjustment to the Base Rate
- DO BRADJ2
- +12 ;Get the Percentile Ranking
- DO PR
- +13 DO SCORESV
- +14 QUIT
- ADDRSL ;Add up the related scored answers for each scale
- +1 NEW LINE,TEXT,NXTQUES,XI
- +2 FOR LINE=1:1
- SET TEXT=$PIECE($TEXT(SCOREDAT+LINE),";",2)
- if TEXT="QUIT"
- QUIT
- Begin DoDot:1
- +3 NEW SCALE,RAWTYPE,SCLRAW,QUESTIONS,I,SNAM,RVAL,ADVAL,NXTLIN,NXTSCL
- +4 SET SCLRAW=$PIECE(TEXT,"|",1,2)
- SET SCALE=$PIECE(TEXT,"|",1)
- SET RAWTYPE=$PIECE(TEXT,"|",2)
- SET QUESTIONS=$PIECE(TEXT,"|",3)
- +5 ;For lines with too many questions, split into two $T lines
- SET NXTLIN=$PIECE($TEXT(SCOREDAT+LINE+1),";",2)
- +6 SET NXTSCL=$PIECE(NXTLIN,"|",1,2)
- +7 IF NXTSCL=SCLRAW
- Begin DoDot:2
- +8 SET NXTQUES=$PIECE(NXTLIN,"|",3)
- +9 SET QUESTIONS=QUESTIONS_"^"_NXTQUES
- +10 SET LINE=LINE+1
- End DoDot:2
- +11 SET SNAM=$$GET1^DIQ(601.87,SCALE_",",3,"I")
- +12 SET RVAL=$PIECE(RAWTYPE,"_")
- SET ADVAL=$PIECE(RAWTYPE,"_",2)
- +13 FOR XI=1:1:$LENGTH(QUESTIONS,U)
- Begin DoDot:2
- +14 NEW NODE,DATA,RAW
- +15 ;YSDATA question nodes start at 3
- SET NODE=$PIECE(QUESTIONS,U,XI)+2
- +16 SET DATA=YSDATA(NODE)
- +17 SET RAW=$$GET1^DIQ(601.75,$PIECE($GET(DATA),U,3)_",",4,"I")
- +18 ;retrieval method section. For each RAWTYPE assign a value to RAW
- +19 ;typical case, YSDATA piece 3 has the MH CHOICE IEN and raw value is in LEGACY field
- +20 ; For MCMI4 exception where additive value depends on the scale.
- +21 ; Therefore additive value defined in table as second "_" piece of the RAWTYPE
- +22 ; First "_" piece is the legacy value of MH CHOICE - 1=True 2=False
- +23 IF RAW=RVAL
- SET YSRAWRSL(SNAM)=$GET(YSRAWRSL(SNAM))+ADVAL
- End DoDot:2
- +24 IF '$DATA(YSRAWRSL(SNAM))
- SET YSRAWRSL(SNAM)=0
- End DoDot:1
- +25 QUIT
- +26 NEW I,SNAM,TOT,MHK,QUES,TAR,VAL,ANS
- +27 KILL YSRAWRSL
- +28 ;1142 VS 1143?
- FOR I=1140:1:1143,1145:1:1169,1240:1:1284
- Begin DoDot:1
- +29 SET SNAM=$$GET1^DIQ(601.87,I_",",3,"I")
- +30 SET TOT=0
- +31 SET MHK=0
- FOR
- SET MHK=$ORDER(^YTT(601.91,"AC",I,MHK))
- if +MHK=0
- QUIT
- Begin DoDot:2
- +32 SET QUES=$$GET1^DIQ(601.91,MHK_",",2,"I")
- +33 SET TAR=$$GET1^DIQ(601.91,MHK_",",3,"I")
- +34 SET VAL=$$GET1^DIQ(601.91,MHK_",",4,"I")
- +35 SET ANS=$GET(YSQANS2(QUES))
- SET ANS=$SELECT(ANS=1:"True",ANS=2:"False",1:"")
- +36 IF ANS=TAR
- SET TOT=TOT+VAL
- End DoDot:2
- +37 ;Save each scale in the YSRAWRSL(scalnam) array which is the format
- +38 ;the calculations expect them to be in.
- +39 SET YSRAWRSL(SNAM)=TOT
- End DoDot:1
- +40 QUIT
- SCOREDAT ;SCALE IEN|RAW VALUE STORAGE TYPE|QUES#^QUES#...
- +1 ;1140|1_1|2^4^5^6^8^9^10^11^12^15^16^17^19^20^21^22^23^24^26^29^30^32^35^36^37^38^39^42^43^46^48^50^51^52^53^54^59^60^63^65^66^67^70^71^72^73^74^75^77^79^82^83^84^85^87^88^90^92^93^96^97^99^100^103^105^106^109^111^112^115^117^119^120
- +2 ;1140|1_1|122^126^128^129^132^133^135^137^139^140^141^142^145^147^149^152^154^155^156^158^159^162^164^166^167^168^169^170^171^172^173^174^175^178^179^180^183^184^185^187^188^189^190^191^192^193^194^195
- +3 ;1141|2_1|65^71^90^99^159^162^187
- +4 ;1141|1_1|2^3^8^20^30^46^67^73^75^84^154^155^158^173^174^185^188
- +5 ;1142|1_1|1^14^16^17^18^22^28^31^32^34^37^39^41^44^51^64^74^78^80^101^107^109^112^113^120^151^164^170^178^193
- +6 ;1143|1_1|49^98^160
- +7 ;1145|2_1|30^154
- +8 ;1145|1_1|17^24^70^92^190
- +9 ;1145|1_2|6^15^43^90^119^139^149^180
- +10 ;1146|2_1|46^67^154
- +11 ;1146|1_1|23^24^52^92^93^112^178^184^193
- +12 ;1146|1_2|5^12^26^99^135^195
- +13 ;1147|2_1|53
- +14 ;1147|1_1|17^22^39^59^70^90^126^170^178
- +15 ;1147|1_2|23^51^71^93^111^169^175^184^193
- +16 ;1148|2_1|67
- +17 ;1148|1_1|5^23^72^175
- +18 ;1148|1_2|4^42^60^77^109^133^162^173^194
- +19 ;1149|2_1|6^15^24^26^139^178^195
- +20 ;1149|1_1|8^75^155
- +21 ;1149|1_2|10^30^46^84^117^154^171
- +22 ;1150|2_1|26^120^178
- +23 ;1150|1_1|30^46^67^84^142^154
- +24 ;1150|1_2|8^20^53^75^129^155^174^185
- +25 ;1151|1_1|10^19^83^117^171^191
- +26 ;1151|1_2|29^38^54^67^87^106^132^142^159^189
- +27 ;1152|2_1|48^158
- +28 ;1152|1_1|36^38^105^152^159
- +29 ;1152|1_2|11^19^65^83^147^183^191
- +30 ;1153|1_1|11^16^21^74^145^172
- +31 ;1153|1_2|9^50^66^97^103^115^141^152
- +32 ;1154|2_1|83^147^152
- +33 ;1154|1_2|2^35^48^63^73^128^140^158^179^188
- +34 ;1155|1_1|21^37^52^79^88^97^100^168^172^184
- +35 ;1155|1_2|17^32^82^96^122^137^167^187
- +36 ;1156|2_1|20^75
- +37 ;1156|1_1|4^12^23^70^93^156^164^178^195
- +38 ;1156|1_2|39^59^85^100^126^166^192
- +39 ;1157|1_1|18^58^70^90^93^121^123^126^148^163^167^172^195
- +40 ;1157|1_2|13^24^44^92^112^156^165^190
- +41 ;1158|1_1|4^59^80^82^93^100^111^126^137^156^166^192^193
- +42 ;1158|1_2|16^18^37^70^134^164^178
- +43 ;1159|1_1|13^24^68^96^148^167^180^195
- +44 ;1159|1_2|21^52^79^88^104^136^153^172
- +45 ;1160|1_1|33^41^44^51^91^108^109
- +46 ;1160|1_2|31^72^89^113^123^143
- +47 ;1161|2_1|20
- +48 ;1161|1_1|1^57^113^118
- +49 ;1161|1_2|7^28^41^120^146
- +50 ;1162|1_1|37^50^54^82^83^105^155
- +51 ;1162|1_2|3^27^56^108^163^177
- +52 ;1163|2_1|75
- +53 ;1163|1_1|17^28^39^51^71^77^85^93^101^111^114^120^178^193
- +54 ;1163|1_2|14^34^64^118^151^170
- +55 ;1164|1_1|65^83^126
- +56 ;1164|1_2|25^45^94^130^161
- +57 ;1165|2_1|158
- +58 ;1165|1_1|11^65^152
- +59 ;1165|1_2|36^61^81^105^116^124^144
- +60 ;1166|1_1|44^47^57^74^89^110^113^143^157
- +61 ;1166|1_2|62^76^91^125^150
- +62 ;1167|1_1|18^24^52^82^89^92^95^104^123^136^148^156^165^172^182
- +63 ;1167|1_2|33^58^80^121^131^138
- +64 ;1168|1_1|28^41^59^64^70^80^111^118^120^170
- +65 ;1168|1_2|1^22^57^78^101^107^114
- +66 ;1169|1_1|13^54^79^88^112^121^136^172^189
- +67 ;1169|1_2|68^95^127^148^182
- +68 ;1240|2_1|154^185
- +69 ;1240|1_1|12^15^24^104^149^180^190
- +70 ;1241|2_1|30^46^67
- +71 ;1241|1_1|26^99^139^175^178^195
- +72 ;1242|1_1|6^17^43^70^90^92^111^118^119
- +73 ;1243|2_1|30^46^84^154
- +74 ;1243|1_1|15^26^99^139
- +75 ;1244|2_1|67
- +76 ;1244|1_1|23^58^111^135^156^178^192^193
- +77 ;1245|1_1|5^12^24^52^92^93^112^184^195
- +78 ;1246|1_1|17^23^33^51^52^71^89^126^184
- +79 ;1247|1_1|39^59^93^112^169^175^178^192^195
- +80 ;1248|2_1|53
- +81 ;1248|1_1|22^70^90^101^107^111^170^193
- +82 ;1249|1_1|4^5^23^51^72^99^109^135^184
- +83 ;1250|2_1|185
- +84 ;1250|1_1|26^60^162^169^173^194
- +85 ;1251|2_1|53^67
- +86 ;1251|1_1|42^77^85^93^133^151^175
- +87 ;1252|1_1|10^38^83^117^132^142^171
- +88 ;1253|2_1|6^15^24^26^139^195
- +89 ;1253|1_1|30^46^84^154
- +90 ;1254|2_1|135^170^178
- +91 ;1254|1_1|8^20^27^53^67^75^155^174^185
- +92 ;1255|1_1|8^20^53^75^129^155^174^185
- +93 ;1256|2_1|5^26^149
- +94 ;1256|1_1|10^30^46^84^117^154
- +95 ;1257|2_1|14^93^120^156^175^178
- +96 ;1257|1_1|67^142
- +97 ;1258|1_1|10^19^38^83^117^132^159^171^183
- +98 ;1259|2_1|93^178
- +99 ;1259|1_1|8^67^75^142^154^155^174^185
- +100 ;1260|1_1|29^54^79^87^106^180^189^191
- +101 ;1261|2_1|188
- +102 ;1261|1_1|10^38^83^103^159^171^183
- +103 ;1262|2_1|48^73^158
- +104 ;1262|1_1|11^19^147^152^153^168^191
- +105 ;1263|2_1|63
- +106 ;1263|1_1|25^36^61^65^85^105^126^130^144
- +107 ;1264|1_1|9^11^65^66^88^103^152^153^159^172^191
- +108 ;1265|1_1|19^21^50^97^141^166^187
- +109 ;1266|1_1|16^37^74^115^137^145^168
- +110 ;1267|2_1|85^118
- +111 ;1267|1_1|2^20^35^63^174^188
- +112 ;1268|1_1|23^44^51^52^99^128^131^135^137^140^169^179
- +113 ;1269|2_1|19^83^147^152^183^191
- +114 ;1269|1_1|48^73^158
- +115 ;1270|1_1|21^32^79^88^96^100^122^167^172
- +116 ;1271|2_1|75
- +117 ;1271|1_1|12^17^24^34^39^51^52^59^153^184
- +118 ;1272|1_1|9^37^74^82^97^115^137^145^168^187
- +119 ;1273|1_1|4^12^23^39^52^59^70^93^164^178^192^195
- +120 ;1274|1_1|17^40^85^100^126^156^166^167^184
- +121 ;1275|2_1|20^53^67^75^154^155
- +122 ;1275|1_1|92^107^170
- +123 ;1276|1_1|18^33^44^89^92^121^123^131^163
- +124 ;1277|2_1|154
- +125 ;1277|1_1|5^58^70^90^93^111^126^156^165^195
- +126 ;1278|1_1|13^24^68^79^88^106^112^148^167^172^190
- +127 ;1279|1_1|14^70^101^111^151^156^170^178
- +128 ;1280|1_1|4^17^39^59^93^100^126^134^166^192^193
- +129 ;1281|1_1|16^18^37^74^80^82^115^137^164^187
- +130 ;1282|1_1|12^15^21^24^104^149^153^180^195
- +131 ;1283|1_1|17^52^79^88^172^182^184
- +132 ;1284|1_1|13^32^68^96^106^112^122^136^148^167
- +133 ;QUIT
- +134 QUIT
- CALW ; Calculate 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 is 0 instead of 2
- SET Q1=$GET(YSQANS($PIECE(PAIR,"-")))
- if Q1=2
- SET Q1=0
- +3 ;False is 0 instead of 2
- 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
- SCORESV ;
- +1 NEW CNT,I,SEQ,SNAM,SCARR
- +2 KILL ^TMP($JOB,"YSCOR")
- +3 ;F SNAM="W Inconsistency","V Invalidity" D
- +4 ;. S YBRS(SNAM,"RSL")=$G(YSRAWRSL(SNAM)) ;Patch to be able to graph the raw results for these two scales
- +5 ;. ;There is no Base Rate or Percentile for these two calculated scales so need to substitute raw for br
- +6 SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
- +7 SET CNT=1
- +8 ;1142 VS 1143? ADDED 1144 BACK IN FOR W INCONSISTENCY
- FOR I=1140:1:1169,1240:1:1284
- Begin DoDot:1
- +9 SET SEQ=$$GET1^DIQ(601.87,I_",",2,"I")
- +10 SET SNAM=$$GET1^DIQ(601.87,I_",",3,"I")
- +11 ;Have to figure out Scale Order on Report - Maybe doesn't matter
- SET SCARR(I)=SNAM
- End DoDot:1
- +12 SET SEQ=0
- FOR
- SET SEQ=$ORDER(SCARR(SEQ))
- if SEQ=""
- QUIT
- Begin DoDot:1
- +13 SET CNT=CNT+1
- +14 SET SNAM=SCARR(SEQ)
- +15 ;S ^TMP($J,"YSCOR",CNT)=SNAM_"="_$G(YBRS(SNAM,"RSL"))_"^"_YSRAWRSL(SNAM)_"^"_$G(YPRS(SNAM,"RSL"))
- +16 SET ^TMP($JOB,"YSCOR",CNT)=SNAM_"="_$GET(YSRAWRSL(SNAM))_"^"_$GET(YBRS(SNAM,"RSL"))_"^"_$GET(YPRS(SNAM,"RSL"))
- End DoDot:1
- +17 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
- +18 QUIT
- EXTANS ;
- +1 ;Extract the T/F responses to each question from YSDATA array
- +2 ;TRUE=1 FALSE=2
- +3 NEW X,QUEST,ANS,STR,PTR
- +4 SET X=2
- +5 FOR
- SET X=$ORDER(YSDATA(X))
- if +X=0
- QUIT
- Begin DoDot:1
- +6 SET STR=YSDATA(X)
- SET QUES=$PIECE(STR,"^",2)
- SET ANS=$PIECE(STR,"^",3)
- SET PTR=$PIECE(STR,"^")
- +7 SET ANS=$SELECT(ANS=3919:1,ANS=3920:2,1:"")
- +8 SET YSQANS(QUES)=ANS
- +9 SET YSQANS(QUES,"PTR")=PTR
- +10 SET YSQANS2(PTR)=ANS
- End DoDot:1
- +11 QUIT
- BR ;Get the Base Rate for each scale
- +1 NEW SCALSTR,SCAL,PCE,I
- +2 FOR I=1140:1:1142,1145:1:1169,1240:1:1284
- Begin DoDot:1
- +3 ;S SCAL=^YTT(601.87,I,0)
- +4 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- +5 SET RAW=$GET(YSRAWRSL(SCAL))
- +6 ;Note RAW+1 because raw values start at 0
- SET YBRS(SCAL,"RSL")=$PIECE(YBRS(SCAL,"STR"),"^",RAW+1)
- End DoDot:1
- +7 QUIT
- BRADJ1 ;Adjust the Base Rate score for scales 1-8B and S-PP depending on the X Raw Score
- +1 NEW SCALSTR,ADJARR,I,SCAL,BR,ADJ,XRAW
- +2 ;1-8B
- +3 FOR STEND="0^6;0","7^7;10","8^8;9","9^9;8","10^10;7","11^11;6","12^12;5","13^14;4","15^16;3","17^18;2","19^20;1","21^60;0"
- Begin DoDot:1
- +4 DO SETADJ(STEND)
- End DoDot:1
- +5 FOR STEND="61^66;-1","67^71;-2","72^76;-3","77^82;-4","83^87;-5","88^93;-6","94^98;-7","99^104;-8","105^109;-9","110^114;-10","115^121;0"
- Begin DoDot:1
- +6 DO SETADJ(STEND)
- End DoDot:1
- +7 SET XRAW=YSRAWRSL("X Disclosure")
- +8 ;Get the adjustment value based on the Raw X Disclosure Scale value
- SET ADJ=ADJARR(XRAW)
- +9 FOR I=1145:1:1156
- Begin DoDot:1
- +10 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- +11 SET BR=YBRS(SCAL,"RSL")
- +12 SET BR=BR+ADJ
- +13 SET BR=$$BRFIX(BR)
- +14 SET YBRS(SCAL,"RSL")=BR
- End DoDot:1
- +15 KILL ADJARR
- +16 ;S-PP
- +17 FOR STEND="0^6;0","7^8;5","9^10;4","11^12;3","13^16;2","17^20;1","21^60;0"
- Begin DoDot:1
- +18 DO SETADJ(STEND)
- End DoDot:1
- +19 FOR STEND="61^71;-1","72^82;-2","83^93;-3","94^100;-4","101^114;-5","115^121;0"
- Begin DoDot:1
- +20 DO SETADJ(STEND)
- End DoDot:1
- +21 ;Get the adjustment value based on the Raw X Disclosure Scale value for S-PP
- SET ADJ=ADJARR(XRAW)
- +22 FOR I=1157:1:1169
- Begin DoDot:1
- +23 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- +24 SET BR=YBRS(SCAL,"RSL")
- +25 SET BR=BR+ADJ
- +26 SET BR=$$BRFIX(BR)
- +27 SET YBRS(SCAL,"RSL")=BR
- End DoDot:1
- +28 QUIT
- SETADJ(STEND) ; Set up the Base Rate Adjustment Array
- +1 NEW BEG,END,VAL,I
- +2 SET BEG=$PIECE(STEND,";")
- SET END=$PIECE(BEG,"^",2)
- SET BEG=$PIECE(BEG,"^")
- SET VAL=$PIECE(STEND,";",2)
- +3 FOR I=BEG:1:END
- SET ADJARR(I)=VAL
- +4 QUIT
- BRADJ2 ;Adjust the Base Rate based on Scales A and CC
- +1 NEW ACC,ABR,CCBR,ADJARR,I
- +2 SET ABR=$GET(YBRS("A Generalized Anxiety","RSL"))
- +3 SET CCBR=$GET(YBRS("CC Major Depression","RSL"))
- +4 if ((ABR<75)!(CCBR<75))
- QUIT
- +5 SET ACC=(ABR-75)+(CCBR-75)
- +6 FOR STEND="0^4;-1","5^9;-2","10^14;-3","15^19;-4","20^24;-5","25^29;-5","30^34;-6","35^39;-6","40^44;-7","45^49;-7","50^54;-8","55^59;-8","60^64;-9","65^69;-9","70^75;-10","76^80;-10"
- Begin DoDot:1
- +7 DO SETADJ(STEND)
- End DoDot:1
- +8 SET ADJ=ADJARR(ACC)
- +9 FOR I=1147,1156,1158
- Begin DoDot:1
- +10 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- +11 SET BR=YBRS(SCAL,"RSL")
- +12 SET BR=BR+ADJ
- +13 SET BR=$$BRFIX(BR)
- +14 SET YBRS(SCAL,"RSL")=BR
- End DoDot:1
- +15 FOR STEND="0^4;-1","5^9;-1","10^14;-2","15^19;-2","20^24;-3","25^29;-3","30^34;-3","35^39;-3","40^44;-4","45^49;-4","50^54;-4","55^59;-4","60^64;-5","65^69;-5","70^75;-5","76^80;-5"
- Begin DoDot:1
- +16 DO SETADJ(STEND)
- End DoDot:1
- +17 SET ADJ=ADJARR(ACC)
- +18 FOR I=1146,1157
- Begin DoDot:1
- +19 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- +20 SET BR=YBRS(SCAL,"RSL")
- +21 SET BR=BR+ADJ
- +22 SET BR=$$BRFIX(BR)
- +23 SET YBRS(SCAL,"RSL")=BR
- End DoDot:1
- +24 QUIT
- PR ;Get the Percentile for each scale based on adjusted Base Rate for Personality/Psychopathology
- +1 ; Get the Percentile for each Facet Scale based on RAW score for Grossman Facet Scales
- +2 NEW SCALSTR,SCAL,PCE,I,RAW,BR
- +3 FOR I=1145:1:1169,1240:1:1284
- Begin DoDot:1
- +4 ;S SCAL=^YTT(601.87,I,0)
- +5 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- +6 SET BR=$GET(YBRS(SCAL,"RSL"))
- +7 ;Note RAW+1 because raw values start at 0
- SET YPRS(SCAL,"RSL")=$PIECE(YPRS(SCAL,"STR"),"^",BR+1)
- End DoDot:1
- +8 ;Grossman Facet Percentile
- +9 FOR I=1240:1:1284
- Begin DoDot:1
- +10 SET SCAL=$$GET1^DIQ(601.87,I_",",3,"I")
- +11 SET RAW=$GET(YSRAWRSL(SCAL))
- +12 ;Note RAW+1 because raw values start at 0
- SET YPRS(SCAL,"RSL")=$PIECE(YPRS(SCAL,"STR"),"^",RAW+1)
- End DoDot:1
- +13 QUIT
- BRFIX(VAL) ;If adjusted base rate <0 set to 0. If >115 set to 115 PATCH X
- +1 IF VAL<0
- SET VAL=0
- +2 IF VAL>115
- SET VAL=115
- +3 QUIT VAL
