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