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 Dec 13, 2024@02:19:58 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
