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