Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTSCDR

YTSCDR.m

Go to the documentation of this file.
  1. YTSCDR ;SLC/PIJ - Score CDR ; 01/08/2016
  1. ;;5.01;MENTAL HEALTH;**123**;DEC 30,1994;Build 73
  1. ;
  1. Q
  1. ;
  1. DATA1 ;
  1. S YSINSNAM=$P(YSDATA(2),U,3)
  1. I $G(YSINSNAM)="" S YSINSNAM=$G(YS("CODE"),"NO NAME PASSED")
  1. S NODE=2 F S NODE=$O(YSDATA(NODE)) Q:NODE="" D ; Start at YSDATA(3)
  1. .S DATA=YSDATA(NODE)
  1. .S YSQN=$P(DATA,U,1)
  1. .S YSCDA=$P($G(DATA),U,3)
  1. .D DESGNTR^YTSCORE(YSQN,.DES)
  1. .S LEG=$$GET1^DIQ(601.75,YSCDA_",",4,"I")
  1. .S TMPANS=LEG
  1. .D SCOREANS
  1. Q
  1. ;
  1. SCOREANS ;
  1. I (DES=1) D Q ; MEMORY
  1. .S MEM=TMPANS
  1. .I (TMPANS=0) S CDRSCORE=0
  1. .I (TMPANS=1) S CDRSCORE="0.5"
  1. .I (TMPANS=2) S CDRSCORE=1
  1. .I (TMPANS=3) S CDRSCORE=2
  1. .I (TMPANS=4) S CDRSCORE=3
  1. ;
  1. I (DES=6)&(TMPANS'=0) D ; Personal Care
  1. .S TMPANS=TMPANS+1 ; No ".5" score
  1. I TMPANS>MEM S HMAJOR=HMAJOR_TMPANS_"^",ABOVE=ABOVE+1
  1. I TMPANS<MEM S LMAJOR=LMAJOR_TMPANS_"^",BELOW=BELOW+1
  1. ;
  1. I MEM=-1 Q
  1. I (ABOVE>2)&(BELOW>1) S RESULT=CDRSCORE
  1. I (ABOVE>2)&(BELOW<2) D
  1. .S CDRSCORE=$$MOSTFREQ(HMAJOR)
  1. .I ($L(CDRSCORE,U)-1)>0 D ; tied scores: pick lowest
  1. ..S CDRSCORE=$P(CDRSCORE,U,1)
  1. ;
  1. I (BELOW>2)&(ABOVE>1) S RESULT=CDRSCORE
  1. I (BELOW>2)&(ABOVE<2) D
  1. .S CDRSCORE=$$MOSTFREQ(LMAJOR)
  1. .I ($L(CDRSCORE,U)-1)>0 D ; tied scores: pick highest
  1. ..S CDRSCORE=$P(CDRSCORE,U,2)
  1. ;
  1. I (MEM=1)&(ABOVE>2) S CDRSCORE=1
  1. I (MEM=0)&(ABOVE>1) S CDRSCORE="0.5"
  1. I (CDRSCORE=0)&(MEM>0) S CDRSCORE="0.5"
  1. Q
  1. ;
  1. MOSTFREQ(STRINGIN) ; Returns most frequent score; ties return a blank
  1. N I
  1. S I=""
  1. S ACOUNT=$L(STRINGIN,U)-1
  1. I ACOUNT=0 Q RESULT
  1. ;
  1. F I=1:1:ACOUNT D
  1. .I $P(STRINGIN,U,I)=0 S GOT0=GOT0+1
  1. .I $P(STRINGIN,U,I)=1 S GOT1=GOT1+1
  1. .I $P(STRINGIN,U,I)=2 S GOT2=GOT2+1
  1. .I $P(STRINGIN,U,I)=3 S GOT3=GOT3+1
  1. .I $P(STRINGIN,U,I)=4 S GOT4=GOT4+1
  1. ;
  1. I (GOT0>GOT1)&(GOT0>GOT2)&(GOT0>GOT3)&(GOT0>GOT4) S RESULT=0
  1. I (GOT1>GOT0)&(GOT1>GOT2)&(GOT1>GOT3)&(GOT1>GOT4) S RESULT="0.5"
  1. I (GOT2>GOT0)&(GOT2>GOT1)&(GOT2>GOT3)&(GOT2>GOT4) S RESULT=1
  1. I (GOT3>GOT0)&(GOT3>GOT1)&(GOT3>GOT2)&(GOT3>GOT4) S RESULT=2
  1. I (GOT4>GOT0)&(GOT4>GOT1)&(GOT4>GOT2)&(GOT4>GOT3) S RESULT=3
  1. ;
  1. ; No clear winner, get the ties
  1. I RESULT="" D Q RESULT
  1. .I (GOT0=2)&((GOT0=GOT1)!(GOT0=GOT2)!(GOT0=GOT3)!(GOT0=GOT4)) S RESULT="0^"
  1. .I (GOT1=2)&((GOT1=GOT0)!(GOT1=GOT2)!(GOT1=GOT3)!(GOT1=GOT4)) S RESULT=RESULT_"0.5^"
  1. .I (GOT2=2)&((GOT2=GOT0)!(GOT2=GOT1)!(GOT2=GOT3)!(GOT2=GOT4)) S RESULT=RESULT_"1^"
  1. .I (GOT3=2)&((GOT3=GOT0)!(GOT3=GOT1)!(GOT3=GOT2)!(GOT3=GOT4)) S RESULT="2^"
  1. .I (GOT4=2)&((GOT4=GOT0)!(GOT4=GOT1)!(GOT4=GOT2)!(GOT4=GOT3)) S RESULT="3^"
  1. ;
  1. Q RESULT
  1. ;
  1. SCORESV ;
  1. I $D(^TMP($J,"YSG",1)),^TMP($J,"YSG",1)="[ERROR]" D Q ;-->out
  1. .K ^TMP($J,"YSCOR")
  1. .S ^TMP($J,"YSCOR",1)="[ERROR]"
  1. .S ^TMP($J,"YSCOR",2)=$G(YSINSNAM)_" Scale not found"
  1. ;
  1. S YSSCNAM=$P($G(^TMP($J,"YSG",3)),U,4)
  1. K ^TMP($J,"YSCOR")
  1. S ^TMP($J,"YSCOR",1)="[DATA]"
  1. S ^TMP($J,"YSCOR",2)=$$GET1^DIQ(601.87,518_",",3,"I")_"="_CDRSCORE
  1. Q
  1. ;
  1. DLLSTR(YSDATA,YS,YSTRNG) ;
  1. ; YSTRNG = 1 Score Instrument
  1. ; YSTRNG = 2 get Report Answers and Text
  1. N DATA,DES,LEG,NODE,TOTAL,CDRSCORE
  1. N YSCDA,YSSCNAM,YSINSNAM,YSQN
  1. N RESULT,HMAJOR,LMAJOR,STRINGIN
  1. N GOT0,GOT1,GOT2,GOT3,GOT4
  1. N ABOVE,BELOW,TMPANS,ACOUNT,MEM
  1. ;
  1. S (GOT0,GOT1,GOT2,GOT3,GOT4)=0
  1. S (HMAJOR,LMAJOR)=""
  1. S (ACOUNT,CDRSCORE,TOTAL)=0
  1. S (STRINGIN,RESULT)=""
  1. S MEM=-1
  1. S (ABOVE,BELOW,TMPANS)=0
  1. ;
  1. I YSTRNG=2 Q ;do nothing, no special text in report
  1. D DATA1
  1. D SCORESV
  1. Q