- 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 Feb 18, 2025@23:45:49 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