YTSCDR ;SLC/PIJ - Score CDR ; 01/08/2016
;;5.01;MENTAL HEALTH;**123**;DEC 30,1994;Build 73
;
Q
;
DATA1 ;
S YSINSNAM=$P(YSDATA(2),U,3)
I $G(YSINSNAM)="" S YSINSNAM=$G(YS("CODE"),"NO NAME PASSED")
S NODE=2 F S NODE=$O(YSDATA(NODE)) Q:NODE="" D ; Start at YSDATA(3)
.S DATA=YSDATA(NODE)
.S YSQN=$P(DATA,U,1)
.S YSCDA=$P($G(DATA),U,3)
.D DESGNTR^YTSCORE(YSQN,.DES)
.S LEG=$$GET1^DIQ(601.75,YSCDA_",",4,"I")
.S TMPANS=LEG
.D SCOREANS
Q
;
SCOREANS ;
I (DES=1) D Q ; MEMORY
.S MEM=TMPANS
.I (TMPANS=0) S CDRSCORE=0
.I (TMPANS=1) S CDRSCORE="0.5"
.I (TMPANS=2) S CDRSCORE=1
.I (TMPANS=3) S CDRSCORE=2
.I (TMPANS=4) S CDRSCORE=3
;
I (DES=6)&(TMPANS'=0) D ; Personal Care
.S TMPANS=TMPANS+1 ; No ".5" score
I TMPANS>MEM S HMAJOR=HMAJOR_TMPANS_"^",ABOVE=ABOVE+1
I TMPANS<MEM S LMAJOR=LMAJOR_TMPANS_"^",BELOW=BELOW+1
;
I MEM=-1 Q
I (ABOVE>2)&(BELOW>1) S RESULT=CDRSCORE
I (ABOVE>2)&(BELOW<2) D
.S CDRSCORE=$$MOSTFREQ(HMAJOR)
.I ($L(CDRSCORE,U)-1)>0 D ; tied scores: pick lowest
..S CDRSCORE=$P(CDRSCORE,U,1)
;
I (BELOW>2)&(ABOVE>1) S RESULT=CDRSCORE
I (BELOW>2)&(ABOVE<2) D
.S CDRSCORE=$$MOSTFREQ(LMAJOR)
.I ($L(CDRSCORE,U)-1)>0 D ; tied scores: pick highest
..S CDRSCORE=$P(CDRSCORE,U,2)
;
I (MEM=1)&(ABOVE>2) S CDRSCORE=1
I (MEM=0)&(ABOVE>1) S CDRSCORE="0.5"
I (CDRSCORE=0)&(MEM>0) S CDRSCORE="0.5"
Q
;
MOSTFREQ(STRINGIN) ; Returns most frequent score; ties return a blank
N I
S I=""
S ACOUNT=$L(STRINGIN,U)-1
I ACOUNT=0 Q RESULT
;
F I=1:1:ACOUNT D
.I $P(STRINGIN,U,I)=0 S GOT0=GOT0+1
.I $P(STRINGIN,U,I)=1 S GOT1=GOT1+1
.I $P(STRINGIN,U,I)=2 S GOT2=GOT2+1
.I $P(STRINGIN,U,I)=3 S GOT3=GOT3+1
.I $P(STRINGIN,U,I)=4 S GOT4=GOT4+1
;
I (GOT0>GOT1)&(GOT0>GOT2)&(GOT0>GOT3)&(GOT0>GOT4) S RESULT=0
I (GOT1>GOT0)&(GOT1>GOT2)&(GOT1>GOT3)&(GOT1>GOT4) S RESULT="0.5"
I (GOT2>GOT0)&(GOT2>GOT1)&(GOT2>GOT3)&(GOT2>GOT4) S RESULT=1
I (GOT3>GOT0)&(GOT3>GOT1)&(GOT3>GOT2)&(GOT3>GOT4) S RESULT=2
I (GOT4>GOT0)&(GOT4>GOT1)&(GOT4>GOT2)&(GOT4>GOT3) S RESULT=3
;
; No clear winner, get the ties
I RESULT="" D Q RESULT
.I (GOT0=2)&((GOT0=GOT1)!(GOT0=GOT2)!(GOT0=GOT3)!(GOT0=GOT4)) S RESULT="0^"
.I (GOT1=2)&((GOT1=GOT0)!(GOT1=GOT2)!(GOT1=GOT3)!(GOT1=GOT4)) S RESULT=RESULT_"0.5^"
.I (GOT2=2)&((GOT2=GOT0)!(GOT2=GOT1)!(GOT2=GOT3)!(GOT2=GOT4)) S RESULT=RESULT_"1^"
.I (GOT3=2)&((GOT3=GOT0)!(GOT3=GOT1)!(GOT3=GOT2)!(GOT3=GOT4)) S RESULT="2^"
.I (GOT4=2)&((GOT4=GOT0)!(GOT4=GOT1)!(GOT4=GOT2)!(GOT4=GOT3)) S RESULT="3^"
;
Q RESULT
;
SCORESV ;
I $D(^TMP($J,"YSG",1)),^TMP($J,"YSG",1)="[ERROR]" D Q ;-->out
.K ^TMP($J,"YSCOR")
.S ^TMP($J,"YSCOR",1)="[ERROR]"
.S ^TMP($J,"YSCOR",2)=$G(YSINSNAM)_" Scale not found"
;
S YSSCNAM=$P($G(^TMP($J,"YSG",3)),U,4)
K ^TMP($J,"YSCOR")
S ^TMP($J,"YSCOR",1)="[DATA]"
S ^TMP($J,"YSCOR",2)=$$GET1^DIQ(601.87,518_",",3,"I")_"="_CDRSCORE
Q
;
DLLSTR(YSDATA,YS,YSTRNG) ;
; YSTRNG = 1 Score Instrument
; YSTRNG = 2 get Report Answers and Text
N DATA,DES,LEG,NODE,TOTAL,CDRSCORE
N YSCDA,YSSCNAM,YSINSNAM,YSQN
N RESULT,HMAJOR,LMAJOR,STRINGIN
N GOT0,GOT1,GOT2,GOT3,GOT4
N ABOVE,BELOW,TMPANS,ACOUNT,MEM
;
S (GOT0,GOT1,GOT2,GOT3,GOT4)=0
S (HMAJOR,LMAJOR)=""
S (ACOUNT,CDRSCORE,TOTAL)=0
S (STRINGIN,RESULT)=""
S MEM=-1
S (ABOVE,BELOW,TMPANS)=0
;
I YSTRNG=2 Q ;do nothing, no special text in report
D DATA1
D SCORESV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTSCDR 3437 printed Apr 09, 2024@21:17:13 Page 2
YTSCDR ;SLC/PIJ - Score CDR ; 01/08/2016
+1 ;;5.01;MENTAL HEALTH;**123**;DEC 30,1994;Build 73
+2 ;
+3 QUIT
+4 ;
DATA1 ;
+1 SET YSINSNAM=$PIECE(YSDATA(2),U,3)
+2 IF $GET(YSINSNAM)=""
SET YSINSNAM=$GET(YS("CODE"),"NO NAME PASSED")
+3 ; Start at YSDATA(3)
SET NODE=2
FOR
SET NODE=$ORDER(YSDATA(NODE))
if NODE=""
QUIT
Begin DoDot:1
+4 SET DATA=YSDATA(NODE)
+5 SET YSQN=$PIECE(DATA,U,1)
+6 SET YSCDA=$PIECE($GET(DATA),U,3)
+7 DO DESGNTR^YTSCORE(YSQN,.DES)
+8 SET LEG=$$GET1^DIQ(601.75,YSCDA_",",4,"I")
+9 SET TMPANS=LEG
+10 DO SCOREANS
End DoDot:1
+11 QUIT
+12 ;
SCOREANS ;
+1 ; MEMORY
IF (DES=1)
Begin DoDot:1
+2 SET MEM=TMPANS
+3 IF (TMPANS=0)
SET CDRSCORE=0
+4 IF (TMPANS=1)
SET CDRSCORE="0.5"
+5 IF (TMPANS=2)
SET CDRSCORE=1
+6 IF (TMPANS=3)
SET CDRSCORE=2
+7 IF (TMPANS=4)
SET CDRSCORE=3
End DoDot:1
QUIT
+8 ;
+9 ; Personal Care
IF (DES=6)&(TMPANS'=0)
Begin DoDot:1
+10 ; No ".5" score
SET TMPANS=TMPANS+1
End DoDot:1
+11 IF TMPANS>MEM
SET HMAJOR=HMAJOR_TMPANS_"^"
SET ABOVE=ABOVE+1
+12 IF TMPANS<MEM
SET LMAJOR=LMAJOR_TMPANS_"^"
SET BELOW=BELOW+1
+13 ;
+14 IF MEM=-1
QUIT
+15 IF (ABOVE>2)&(BELOW>1)
SET RESULT=CDRSCORE
+16 IF (ABOVE>2)&(BELOW<2)
Begin DoDot:1
+17 SET CDRSCORE=$$MOSTFREQ(HMAJOR)
+18 ; tied scores: pick lowest
IF ($LENGTH(CDRSCORE,U)-1)>0
Begin DoDot:2
+19 SET CDRSCORE=$PIECE(CDRSCORE,U,1)
End DoDot:2
End DoDot:1
+20 ;
+21 IF (BELOW>2)&(ABOVE>1)
SET RESULT=CDRSCORE
+22 IF (BELOW>2)&(ABOVE<2)
Begin DoDot:1
+23 SET CDRSCORE=$$MOSTFREQ(LMAJOR)
+24 ; tied scores: pick highest
IF ($LENGTH(CDRSCORE,U)-1)>0
Begin DoDot:2
+25 SET CDRSCORE=$PIECE(CDRSCORE,U,2)
End DoDot:2
End DoDot:1
+26 ;
+27 IF (MEM=1)&(ABOVE>2)
SET CDRSCORE=1
+28 IF (MEM=0)&(ABOVE>1)
SET CDRSCORE="0.5"
+29 IF (CDRSCORE=0)&(MEM>0)
SET CDRSCORE="0.5"
+30 QUIT
+31 ;
MOSTFREQ(STRINGIN) ; Returns most frequent score; ties return a blank
+1 NEW I
+2 SET I=""
+3 SET ACOUNT=$LENGTH(STRINGIN,U)-1
+4 IF ACOUNT=0
QUIT RESULT
+5 ;
+6 FOR I=1:1:ACOUNT
Begin DoDot:1
+7 IF $PIECE(STRINGIN,U,I)=0
SET GOT0=GOT0+1
+8 IF $PIECE(STRINGIN,U,I)=1
SET GOT1=GOT1+1
+9 IF $PIECE(STRINGIN,U,I)=2
SET GOT2=GOT2+1
+10 IF $PIECE(STRINGIN,U,I)=3
SET GOT3=GOT3+1
+11 IF $PIECE(STRINGIN,U,I)=4
SET GOT4=GOT4+1
End DoDot:1
+12 ;
+13 IF (GOT0>GOT1)&(GOT0>GOT2)&(GOT0>GOT3)&(GOT0>GOT4)
SET RESULT=0
+14 IF (GOT1>GOT0)&(GOT1>GOT2)&(GOT1>GOT3)&(GOT1>GOT4)
SET RESULT="0.5"
+15 IF (GOT2>GOT0)&(GOT2>GOT1)&(GOT2>GOT3)&(GOT2>GOT4)
SET RESULT=1
+16 IF (GOT3>GOT0)&(GOT3>GOT1)&(GOT3>GOT2)&(GOT3>GOT4)
SET RESULT=2
+17 IF (GOT4>GOT0)&(GOT4>GOT1)&(GOT4>GOT2)&(GOT4>GOT3)
SET RESULT=3
+18 ;
+19 ; No clear winner, get the ties
+20 IF RESULT=""
Begin DoDot:1
+21 IF (GOT0=2)&((GOT0=GOT1)!(GOT0=GOT2)!(GOT0=GOT3)!(GOT0=GOT4))
SET RESULT="0^"
+22 IF (GOT1=2)&((GOT1=GOT0)!(GOT1=GOT2)!(GOT1=GOT3)!(GOT1=GOT4))
SET RESULT=RESULT_"0.5^"
+23 IF (GOT2=2)&((GOT2=GOT0)!(GOT2=GOT1)!(GOT2=GOT3)!(GOT2=GOT4))
SET RESULT=RESULT_"1^"
+24 IF (GOT3=2)&((GOT3=GOT0)!(GOT3=GOT1)!(GOT3=GOT2)!(GOT3=GOT4))
SET RESULT="2^"
+25 IF (GOT4=2)&((GOT4=GOT0)!(GOT4=GOT1)!(GOT4=GOT2)!(GOT4=GOT3))
SET RESULT="3^"
End DoDot:1
QUIT RESULT
+26 ;
+27 QUIT RESULT
+28 ;
SCORESV ;
+1 ;-->out
IF $DATA(^TMP($JOB,"YSG",1))
IF ^TMP($JOB,"YSG",1)="[ERROR]"
Begin DoDot:1
+2 KILL ^TMP($JOB,"YSCOR")
+3 SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
+4 SET ^TMP($JOB,"YSCOR",2)=$GET(YSINSNAM)_" Scale not found"
End DoDot:1
QUIT
+5 ;
+6 SET YSSCNAM=$PIECE($GET(^TMP($JOB,"YSG",3)),U,4)
+7 KILL ^TMP($JOB,"YSCOR")
+8 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
+9 SET ^TMP($JOB,"YSCOR",2)=$$GET1^DIQ(601.87,518_",",3,"I")_"="_CDRSCORE
+10 QUIT
+11 ;
DLLSTR(YSDATA,YS,YSTRNG) ;
+1 ; YSTRNG = 1 Score Instrument
+2 ; YSTRNG = 2 get Report Answers and Text
+3 NEW DATA,DES,LEG,NODE,TOTAL,CDRSCORE
+4 NEW YSCDA,YSSCNAM,YSINSNAM,YSQN
+5 NEW RESULT,HMAJOR,LMAJOR,STRINGIN
+6 NEW GOT0,GOT1,GOT2,GOT3,GOT4
+7 NEW ABOVE,BELOW,TMPANS,ACOUNT,MEM
+8 ;
+9 SET (GOT0,GOT1,GOT2,GOT3,GOT4)=0
+10 SET (HMAJOR,LMAJOR)=""
+11 SET (ACOUNT,CDRSCORE,TOTAL)=0
+12 SET (STRINGIN,RESULT)=""
+13 SET MEM=-1
+14 SET (ABOVE,BELOW,TMPANS)=0
+15 ;
+16 ;do nothing, no special text in report
IF YSTRNG=2
QUIT
+17 DO DATA1
+18 DO SCORESV
+19 QUIT
