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

YTSCOREX.m

Go to the documentation of this file.
  1. YTSCOREX ;SLC/KCM - Score tests without admins ; 1/25/2017
  1. ;;5.01;MENTAL HEALTH;**223,224**;Dec 30, 1994;Build 17
  1. ;
  1. CALC(TEST,ANSWERS,SCORES) ; Calculate and return .SCORES given ANSWERS
  1. ; TEST=name or IEN of instrument
  1. ; .ANSWERS(n,"id")=questionId
  1. ; .ANSWERS(n,"value")=choiceId or integerValue
  1. ; .SCORES(n,"name")=scaleName
  1. ; .SCORES(n,"id")=scaleId
  1. ; .SCORES(n,"raw")=rawScore
  1. ; .SCORES(n,"tscore")=tScore
  1. ; .SCORES("error")=error message if defined
  1. ;
  1. N X,YS,YSDATA
  1. K ^TMP($J)
  1. I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0))
  1. I 'TEST S SCORES("error")="test not found" QUIT
  1. S YS("CODE")=$P($G(^YTT(601.71,TEST,0)),U)
  1. D SCALEG^YTQAPI3(.YSDATA,.YS) ; get scales into ^TMP
  1. S X=$P($G(^YTT(601.71,TEST,9)),U,2) ; check scoring routine
  1. I X'="",(X'="YTSCORE") D COMPLEX(TEST,.ANSWERS,.SCORES) I 1
  1. E D SUMKEY(TEST,.ANSWERS,.SCORES)
  1. Q
  1. SUMKEY(TEST,ANSWERS,SCORES) ; score by summing scoring keys
  1. ; expects ^TMP($J,"YSG",n) to contain scale id's
  1. N I,J,ISCALE,NAME,RAW,QALIST
  1. D BYQSTN(.ANSWERS,.QALIST)
  1. S (I,J)=0 F S I=$O(^TMP($J,"YSG",I)) Q:'I D
  1. . I ^TMP($J,"YSG",I)'?1"Scale".E QUIT ; only use "Scale#" nodes
  1. . S ISCALE=$P($P(^TMP($J,"YSG",I),"=",2),U)
  1. . S NAME=$P($P(^TMP($J,"YSG",I),"=",2),U,4)
  1. . S RAW=$$BYKEY(ISCALE,.QALIST)
  1. . S J=J+1,SCORES(J,"id")=ISCALE,SCORES(J,"name")=NAME,SCORES(J,"raw")=RAW
  1. Q
  1. BYQSTN(ANSWERS,QALIST) ; return QALIST(questionId)=choiceText or value
  1. N I,QSTN,RTYP,VALUE
  1. S I=0 F S I=$O(ANSWERS(I)) Q:'I D
  1. . S QSTN=$G(ANSWERS(I,"id"))
  1. . S QSTN=$S($E(QSTN)="q":+$P(QSTN,"q",2),1:+QSTN)
  1. . QUIT:'QSTN
  1. . S RTYP=$P($G(^YTT(601.72,QSTN,2)),U,2)
  1. . S VALUE=$G(ANSWERS(I,"value"))
  1. . I RTYP=1,($E(VALUE)="c") S VALUE=+$P(VALUE,"c",2) ; MCHOICE
  1. . I RTYP'=1 S VALUE=";1^"_VALUE
  1. . S QALIST(QSTN)=VALUE
  1. Q
  1. BYKEY(SCALE,QALIST) ; returns score based on scoring keys for SCALE
  1. ; .QALIST(questionId)=choiceId (with "q" and "c" removed)
  1. N SUM,KEY,X0,QSTN,TARGET,VALUE,CHOICE,TEXT
  1. S SUM=0
  1. S KEY=0 F S KEY=$O(^YTT(601.91,"AC",SCALE,KEY)) Q:'KEY D
  1. . S X0=^YTT(601.91,KEY,0)
  1. . S QSTN=$P(X0,U,3),CHOICE=$G(QALIST(QSTN)) QUIT:'CHOICE
  1. . S TARGET=$P(X0,U,4),VALUE=$P(X0,U,5)
  1. . S TEXT=$G(^YTT(601.75,CHOICE,1))
  1. . I TEXT=TARGET S SUM=SUM+VALUE
  1. Q SUM
  1. ;
  1. COMPLEX(TEST,ANSWERS,SCORES) ; score by calling routine
  1. ; expects: ^TMP($J,"YSG",n) to contain scale id's
  1. ; expects: YS and YSDATA from CALC
  1. N YSRTN
  1. D MKYSDATA(TEST,.ANSWERS,.YSDATA) ; build YSDATA
  1. S YSRTN=$P($G(^YTT(601.71,TEST,9)),U,2)
  1. S YSRTN="DLLSTR^"_YSRTN_"(.YSDATA,.YS,1)"
  1. D @YSRTN ; call complex scoring routine
  1. I '$D(^TMP($J,"YSCOR")) S SCORES("error")="Complex scoring failed" QUIT
  1. N I,X,NMLIST,SNAME,RAW,TSCORE,SEQ,ID
  1. D NSCALES(.NMLIST) ; create name lookup for scale sequence and id
  1. S I=1 F S I=$O(^TMP($J,"YSCOR",I)) Q:'I D ; iterate named scores
  1. . S X=^TMP($J,"YSCOR",I)
  1. . S SNAME=$P(X,"="),RAW=$P($P(X,"=",2),U),TSCORE=$P($P(X,"=",2),U,2)
  1. . S SEQ=+$P(NMLIST(SNAME),U),ID=$P(NMLIST(SNAME),U,2)
  1. . S SCORES(SEQ,"name")=SNAME,SCORES(SEQ,"raw")=RAW,SCORES(SEQ,"id")=ID
  1. . I $L(TSCORE) S SCORES(SEQ,"tscore")=TSCORE
  1. Q
  1. MKYSDATA(TEST,ANSWERS,YSDATA) ; Convert "tree" array of answers to YSDATA format
  1. N I,N,QSTN,CTNT,QSEQ,SSEQ,RTYP,CHOICE,VAL
  1. S YSDATA(1)="[DATA]",YSDATA(2)=U_TEST_U_$P($G(^YTT(601.71,TEST,0)),U)
  1. S N=2
  1. S I=0 F S I=$O(ANSWERS(I)) Q:'I D
  1. . S QSTN=$G(ANSWERS(I,"id")) QUIT:$E(QSTN)'="q" ; skip intros, etc.
  1. . S QSTN=+$P(QSTN,"q",2) QUIT:'QSTN
  1. . S CTNT=$O(^YTT(601.76,"AE",QSTN,""))
  1. . S QSEQ=0 I CTNT S QSEQ=+$P(^YTT(601.76,CTNT,0),U,3)
  1. . S RTYP=$P($G(^YTT(601.72,QSTN,2)),U,2)
  1. . S VAL=$G(ANSWERS(I,"value")) I VAL="c1155"!(VAL="c1156")!(VAL="c1157") S RTYP=1
  1. . ; handle common MCHOICE questions
  1. . I RTYP=1 D QUIT
  1. . . S CHOICE=$G(ANSWERS(I,"value"))
  1. . . I $E(CHOICE)="c" S CHOICE=+$P(CHOICE,"c",2)
  1. . . S N=N+1,YSDATA(N)=QSTN_U_QSEQ_U_CHOICE
  1. . ; handle long WP questions
  1. . I ($L($G(ANSWERS(I,"value")))>240)!$D(ANSWERS(I,"value","\")) D QUIT
  1. . . N WPIN,WPOUT,J
  1. . . M WPIN=ANSWERS(I,"value")
  1. . . D SPLITWP(.WPIN,.WPOUT)
  1. . . S SSEQ=0,J=0 F S J=$O(WPOUT(J)) Q:'J D
  1. . . . S SSEQ=SSEQ+1,N=N+1,YSDATA(N)=QSTN_U_QSEQ_";"_SSEQ_U_WPOUT(J)
  1. . ; handle other values
  1. . S N=N+1,YSDATA(N)=QSTN_U_QSEQ_";1"_U_$G(ANSWERS(I,"value"))
  1. Q
  1. NSCALES(NMLIST) ; build scale NMLIST(name)=sequence^scaleId
  1. ; expects: ^TMP($J,"YSG",n) from CALC
  1. N I,N,X,GSEQ,SEQ,ALIST,ID,NM
  1. S I=1 F S I=$O(^TMP($J,"YSG",I)) Q:'I D
  1. . S X=^TMP($J,"YSG",I)
  1. . I $E(X,1,5)="Group" S N=$P(X,U,4) S:'N N=I S GSEQ=N*1000 QUIT
  1. . I $E(X,1,5)'="Scale" QUIT
  1. . S N=+$P(X,U,3) S:'N N=I S SEQ=GSEQ+N
  1. . S ID=+$P($P(X,"=",2),U),NM=$P(X,U,4)
  1. . S ALIST(SEQ)=ID_U_NM
  1. S (I,SEQ)=0 F S I=$O(ALIST(I)) Q:'I D
  1. . S SEQ=SEQ+1
  1. . S NMLIST($P(ALIST(I),U,2))=SEQ_U_+ALIST(I)
  1. Q
  1. SPLITWP(IN,OUT) ; split WP into 240 char segments and use | as newline
  1. N I
  1. D ADDSEGS(IN,.OUT)
  1. I $D(IN("\")) S I=0 F S I=$O(IN("\",I)) Q:'I D ADDSEGS(IN("\",I),.OUT)
  1. Q
  1. ADDSEGS(LINE,OUT) ; add 240 char segment to OUT array
  1. ; See ADDSEGS^YTQRQAD2 for similar code. This is a bit more general.
  1. N I,J,X,END,FIRST,LAST
  1. S J=+$O(OUT(""),-1) ; get # of last node
  1. S END=$L(LINE),LAST=0 F I=0:1 D Q:LAST>END ; iterate thru each segment
  1. . S FIRST=(I*240)+1,LAST=(I*240)+240 ; set first&last char positions
  1. . S X=$TR($E(LINE,FIRST,LAST),$C(10),"|") ; set segment, chg newline to |
  1. . S J=J+1,OUT(J)=X ; add segment to OUT
  1. Q
  1. LEGACY(TESTNM,ADFN,AUSER,ANSWERS,SCORES) ; return .SCORES for legacy test
  1. ; .ANSWERS(n,"id")=questionId
  1. ; .ANSWERS(n,"value")=choiceId or integerValue
  1. N YS,YSDATA,I,J,QSTN,RTYP,CHOICE,VALUE,VALSTR
  1. S YS("CODE")=TESTNM,YS("ADATE")=DT,YS("DFN")=ADFN,YS("STAFF")=AUSER
  1. S I=0,VALSTR="" F S I=$O(ANSWERS(I)) Q:'I D
  1. . S QSTN=$G(ANSWERS(I,"id"))
  1. . S QSTN=$S($E(QSTN)="q":+$P(QSTN,"q",2),1:+QSTN) QUIT:'QSTN
  1. . S RTYP=$P($G(^YTT(601.72,QSTN,2)),U,2)
  1. . I RTYP=1,($E(ANSWERS(I,"value"))="c") D
  1. . . S CHOICE=+$P(ANSWERS(I,"value"),"c",2)
  1. . . S VALUE=$P($G(^YTT(601.75,CHOICE,0)),U,2)
  1. . E S VALUE=$G(ANSWERS(I,"value"))
  1. . S VALSTR=VALSTR_VALUE
  1. S YS("R1")=$E(VALSTR,1,200)
  1. S YS("R2")=$E(VALSTR,201,400)
  1. S YS("R3")=$E(VALSTR,401,600)
  1. ; The legacy algorithm below does this with 601.2:
  1. ; - save a backup copy in ^TMP of the day's data for the DFN
  1. ; - add this result set to 601.2 and call the scoring algorithm
  1. ; - generate the report for this administration
  1. ; - replace the day's data for the DFN in 601.2 with what was in ^TMP
  1. N CNT,INC,X,YSCODEN,YSET,ZTREQ
  1. D LEGCR^YTQAPI9(.YSDATA,.YS)
  1. ; Find the scores in the returned YSDATA beginning with line 5 and
  1. ; go until the report begins -- the link that says ^^PROGRESS NOTE^^
  1. S J=0,I=5 F S I=$O(YSDATA(I)) Q:'I Q:YSDATA(I)["^PROGRESS NOTE^" D
  1. . I $E(YSDATA(I))="S" D
  1. . . S J=J+1
  1. . . S SCORES(J,"name")=$P(YSDATA(I),U,2)
  1. . . S SCORES(J,"id")=$P(YSDATA(I),U,3)
  1. . . S SCORES(J,"raw")=$P(YSDATA(I),U,4)
  1. . . S:$L($P(YSDATA(I),U,5)) SCORES(J,"tscore")=$P(YSDATA(I),U,5)
  1. Q
  1. ;
  1. FULLANS(ANSWERS,QADISP) ; List out display values of questions/answers
  1. ; expects .ANSWERS(sequence,"id")="q1234"
  1. ; .ANSWERS(sequence,"value")="c567"
  1. ; returns .QADISP(sequence,"qText")=questionText
  1. ; .QADISP(sequence,"aText")=answerText
  1. N I,J,N,QSTN,QTXT,ATXT,CTXT,DELIM,RTYP
  1. S (I,N)=0 F S I=$O(ANSWERS(I)) Q:'I D
  1. . S QSTN=$G(ANSWERS(I,"id")) QUIT:$E(QSTN)'="q" ; skip intros, etc.
  1. . S QSTN=+$P(QSTN,"q",2) QUIT:'QSTN
  1. . S QTXT="",ATXT=""
  1. . S J=0 F S J=$O(^YTT(601.72,QSTN,1,J)) Q:'J S QTXT=QTXT_$S($L(QTXT):" ",1:"")_^(J,0)
  1. . S CTXT=$O(^YTT(601.76,"AF",TEST,QSTN,0))
  1. . S DELIM=$P(^YTT(601.76,CTXT,0),U,5) ; get delimiter for question text
  1. . S QTXT=DELIM_" "_QTXT
  1. . S RTYP=$P($G(^YTT(601.72,QSTN,2)),U,2)
  1. . I RTYP=1 S ATXT=$G(^YTT(601.75,+$P($G(ANSWERS(I,"value")),"c",2),1)) I 1
  1. . E S ATXT=$TR($G(ANSWERS(I,"value")),$C(10),"|") ;ignore "\" nodes, too long
  1. . S N=N+1,QADISP(N,"qText")=QTXT,QADISP(N,"aText")=ATXT
  1. S QADISP("qCnt")=N
  1. Q
  1. ;
  1. PARTANS(TEST,ANSWERS,QADISP) ; List out display values for designator/legacyValue
  1. ; expects .ANSWERS(sequence,"id")="q1234"
  1. ; .ANSWERS(sequence,"value")="c567"
  1. ; returns .QADISP(sequence,"qText")=designator
  1. ; .QADISP(sequence,"aText")=legacyValue
  1. N I,N,QSTN,QTXT,CTXT,ATXT,RTYP
  1. S (I,N)=0 F S I=$O(ANSWERS(I)) Q:'I D
  1. . S QSTN=$G(ANSWERS(I,"id")) QUIT:$E(QSTN)'="q" ; skip intros, etc.
  1. . S QSTN=+$P(QSTN,"q",2) QUIT:'QSTN
  1. . S CTXT=$O(^YTT(601.76,"AF",TEST,QSTN,0))
  1. . S QTXT=$P(^YTT(601.76,CTXT,0),U,5) ; delimiter as question text
  1. . S RTYP=$P($G(^YTT(601.72,QSTN,2)),U,2)
  1. . S ATXT=""
  1. . I RTYP=1 D
  1. . . N CID S CID=+$P($G(ANSWERS(I,"value")),"c",2)
  1. . . I 'CID!(CID=1155)!(CID=1156)!(CID=1157) S ATXT=" " I 1
  1. . . E S ATXT=$P($G(^YTT(601.75,CID,0)),U,2) ; legacy value as answer text
  1. . S N=N+1,QADISP(N,"qText")=QTXT,QADISP(N,"aText")=ATXT
  1. S QADISP("qCnt")=N
  1. Q
  1. CPRSSTR(TEST,ANSWERS,SCORES) ; build string for CPRS DLL
  1. N I,TESTNM,CNT,STXT,QTXT,QADISP
  1. S TESTNM=$P(^YTT(601.71,TEST,0),U)
  1. ; write full answers if WRITE FULE TEXT (601.71:26) is Yes
  1. I $P(^YTT(601.71,TEST,8),U,6)="Y" D FULLANS(.ANSWERS,.QADISP) I 1
  1. E D PARTANS(TEST,.ANSWERS,.QADISP)
  1. S CNT=0,STXT="",QTXT=""
  1. S I=0 F S I=$O(SCORES(I)) Q:'I D
  1. . S STXT=STXT_"*"_SCORES(I,"id")_"~"_SCORES(I,"raw")
  1. . I $L($G(SCORES(I,"tscore"))) S STXT=STXT_"~"_SCORES(I,"tscore")
  1. S I=0 F S I=$O(QADISP(I)) Q:'I D
  1. . S QTXT=QTXT_"*"_QADISP(I,"qText")_"~"_QADISP(I,"aText")
  1. Q "COMPLETE^"_TESTNM_U_QADISP("qCnt")_U_STXT_U_QTXT_U
  1. ;