YTQRCDB ;BAL/KTL - MHA CLOUD DATABASE ADMIN RPC CALLS; 1/25/2017
;;5.01;MENTAL HEALTH;**239,224,249**;Dec 30, 1994;Build 30
;
;
; Reference to FILE^DIE in ICR #2053
Q
SAVEADM(ARGS,DATA) ; Save instrument administration and answers
N YSARR,ADMM,ANSRES,SCRRES
S ADMM=$$FILADMIN(.DATA) ; Passed in ADMIN ID for previously scored, New ADMIN ID, 0=Error
I ADMM=0 Q "/api/mha/cdb/instrument/admin/"_ADMM
S ANSRES=$$FILANS(ADMM,.DATA)
I ANSRES=0 D SETERROR^YTQRUTL(500,"Error Filing Answers") S ADMM=0
I ADMM'=0,$D(DATA("results")) D SAVESCR(ADMM,.DATA)
Q "/api/mha/cdb/instrument/admin/"_ADMM
;
SCORADM(ARGS,DATA) ;Score administration
;Used when scoring algorithm for this instrument not yet implemented in cloud app
N DATAOUT,ERRARY,JSONOUT,SCORES,I
N YSID,YSNAM,YSRAW,YSTSCR,CNT
K ^TMP("YTQ-JSON",$J),YTQRRSLT
D SCOREIT(.DATA,.SCORES)
I '$D(SCORES) D Q "/api/mha/cdb/instrument/admin/scores/NOTOK"
. D SETERROR^YTQRUTL(500,"Error Scoring Answers")
. S ^TMP("YTQ-JSON",$J,1,0)="ERROR",YTQRRSLT=$NA(^TMP("YTQ-JSON",$J))
S CNT=1,^TMP("YTQ-JSON",$J,CNT,0)="{""results"":["
S I=0 F S I=$O(SCORES(I)) Q:I="" D
. S YSID=$G(SCORES(I,"id"))
. S YSNAM=$G(SCORES(I,"name"))
. S YSRAW=$G(SCORES(I,"raw"))
. S YSTSCR=$G(SCORES(I,"tscore"))
. S CNT=CNT+1,^TMP("YTQ-JSON",$J,CNT,0)="{""id"":"_YSID_", ""name"":"""_YSNAM_""", ""raw"":"_YSRAW_$S(YSTSCR]"":", ""tscore"":"_YSTSCR_"},",1:"},")
S ^TMP("YTQ-JSON",$J,CNT,0)=$E(^TMP("YTQ-JSON",$J,CNT,0),1,$L(^TMP("YTQ-JSON",$J,CNT,0))-1)
S CNT=CNT+1,^TMP("YTQ-JSON",$J,CNT,0)="]}"
S YTQRRSLT=$NA(^TMP("YTQ-JSON",$J))
Q "/api/mha/cdb/instrument/admin/scores/OK"
;
SAVESCR(ADMM,DATA) ;Save scores for admin for instruments scored in cloud app and passed in
; ADMM = ADMINID
; DATA = ARRAY OF RESULTS
N RARR,I,YS,YSID,YSNAM,YSRAW,YSTSC
N SCL,SCLID
Q:'$D(DATA("results"))
; Sort results by Scale ID for Instrument Scale definition order matching
S I=0 F S I=$O(DATA("results",I)) Q:+I=0 D
. S YSID=$G(DATA("results",I,"scaleId"))
. S YSNAM=$G(DATA("results",I,"scaleName"))
. S YSRAW=$G(DATA("results",I,"rawScore"))
. S YSTSC=$G(DATA("results",I,"tScore"))
. Q:+YSID=0
. S RARR(YSID)=YSNAM_"="_YSRAW
. I YSTSC]"" S RARR(YSID)=RARR(YSID)_U_YSTSC
S YS("CODE")=$G(DATA("name"))
K ^TMP($J,"YSG")
D SCALEG^YTQAPI3(.YSDATA,.YS)
K ^TMP($J,"YSCOR")
S ^TMP($J,"YSCOR",1)="[DATA]"
S I=1 F S I=$O(^TMP($J,"YSG",I)) Q:+I=0 D
. S SCL=^TMP($J,"YSG",I),SCLID=$P($P(SCL,"=",2),U),SCL=$P($P(SCL,"="),"Scale",2)
. Q:+SCL=0!(+SCLID=0)
. S ^TMP($J,"YSCOR",SCL+1)=$G(RARR(SCLID))
K YS S YS("AD")=$G(ADMM)
D UPDSCORE^YTSCORE(.YSDATA,.YS)
Q
;
FILADMIN(DATA) ;Get YSARR and file mh administration
; Expects required MH ADMINISTRATION fields in DATA(prop)
; Expects answers in the DATA("answers",i,"id"/"value") array
N ANSWERS,TEST
N I,ACNT,VAL,ADMIN
S TEST=$G(DATA("name")) I TEST="" D SETERROR^YTQRUTL(404,"Missing Test") Q 0
S DATA("instrumentId")=$O(^YTT(601.71,"B",TEST,0))
I DATA("instrumentId")="" S DATA("instrumentId")=$O(^YTT(601.71,"B",$TR(TEST,"_"," "),0))
I DATA("instrumentId")="" D SETERROR^YTQRUTL(404,"Test not found") Q 0
I '$D(DATA("answers")) D SETERROR^YTQRUTL(404,"Missing Answers") Q 0
I '$D(DATA("patientId")) D SETERROR^YTQRUTL(404,"Missing patient id") Q 0
I '$D(DATA("orderedById")) D SETERROR^YTQRUTL(404,"Missing ordering clinician") Q 0
I '$D(DATA("locationId")) D SETERROR^YTQRUTL(404,"Missing location") Q 0
S DATA("source")=$G(DATA("source")) I DATA("source")="" S DATA("source")="mhaweb"
S DATA("consultId")=$G(YSARR("consultId"))
I '$D(DATA("administeredById")) S DATA("administeredById")=$G(DUZ)
I '$D(DATA("completedDate")) S DATA("completedDate")=$$NOW^XLFDT()
I '$D(DATA("dateSaved")) S DATA("dateSaved")=$$NOW^XLFDT()
I '$D(DATA("dateGiven")) S DATA("dateGiven")=$$NOW^XLFDT()
S DATA("complete")="YES" ;Always Y?
S (I,ACNT)=0 F S I=$O(DATA("answers",I)) Q:I="" D
. S VAL=$G(DATA("answers",I,"value"))
. I VAL="null" S DATA("answers",I,"value")="c1155" Q
. I VAL[1156!(VAL[1157) Q
. S ACNT=ACNT+1
S DATA("numAns")=ACNT
S ADMIN=$$SETADM(.DATA)
Q ADMIN
;
RVW(ARGS,DATA) ; update admin REVIEWED status
; Requires input
; DATA("adminId")
;
N YS,ADMIN,YTERR,YSORD,YSCMPLT,YSOK,YSMESS,N0
S YSMESS="",YSOK=""
S ADMIN=+$G(DATA("adminId"))
I DATA("adminId")="" S YSMESS="Administration not sent."
I '$D(^YTT(601.84,ADMIN))="" S YSMESS="Administration not found."
S N0=$G(^YTT(601.84,ADMIN,0)),YSORD=$P(N0,U,6),YSCMPLT=$P(N0,U,9)
I $G(DUZ)=YSORD,($$REQCSGN^YTQRQAD3(ADMIN)="false") S YSOK=1
S YS(601.84,ADMIN_",",19)=YSOK
D FILE^DIE("","YS","YTERR")
S YSOK=$S(YSOK=1:"SUCCESS",1:"FAIL")
I $D(YTERR) S YSMESS="Unable to update admin",YSOK="FAIL"
;I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Unable to update admin") Q 0
Q "/api/mha/cdb/instrument/admin/reviewed/"_YSOK_U_YSMESS ; otherwise we're updating existing admin
;
SETADM(DATA) ; return the id for new/updated admin
; Requires input
; DATA("patientId")
; DATA("orderedById")
; DATA("administeredById")
; DATA("completedDate")
; DATA("dateSaved")
; DATA("dateGiven")
; DATA("instrumentId")
; Optional
; DATA("adminId") - if updating existing admin
; DATA("cosignerId")
N YSDATA,YS,ADMIN
S ADMIN=+$G(DATA("adminId"))
S YS("FILEN")=601.84
I ADMIN S YS("IEN")=ADMIN I 1
E S YS(1)=".01^NEW^1"
S YS(2)="1^`"_DATA("patientId")
S YS(3)="2^`"_DATA("instrumentId")
S YS(4)="3^"_DATA("dateGiven")
S YS(5)="4^NOW"
S YS(6)="5^`"_DATA("orderedById")
S YS(7)="6^`"_DATA("administeredById")
S YS(8)="7^N"
S YS(9)="8^"_DATA("complete")
S YS(10)="9^"_DATA("numAns")
S YS(11)="13^`"_DATA("locationId")
I '$L($G(DATA("source"))) S DATA("source")="web"
S YS(12)="15^"_DATA("source")
I DATA("consultId")]"" S YS(13)="17^"_DATA("consultId")
D ADMSAVE^YTQAPI1(.YSDATA,.YS)
I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Unable to create admin") Q 0
I 'ADMIN Q $P(YSDATA(2),U,2) ; create new admin, ien found in 2nd piece
Q ADMIN ; otherwise we're updating existing admin
;
FILANS(ADMIN,DATA) ; File Answers for an ADMIN
; Requires: ADMIN = IEN of MH ADMINISTRATION
; DATA("answers",i,"id"/"value")
N ARSL
I +$G(ADMIN)=0 D SETERROR^YTQRUTL(404,"Missing ADMIN ID") Q 0
I '$D(^YTT(601.84,ADMIN)) D SETERROR^YTQRUTL(404,"Invalid ADMIN ID") Q 0
I '$D(DATA("answers")) D SETERROR^YTQRUTL(404,"Missing Answers") Q 0
S ARSL=$$QASAVE(ADMIN,.DATA)
Q ARSL
;
QASAVE(ADMIN,DATA) ; save questions and answers in DATA
; loop through DATA to create ANS array, then YSDATA array
; ANS(#)=questionId^choiceId <-- radio group question
; ANS(#,#)=wp value <-- all others
; Return: 1 = Success
; 0 = Failure
N I,QNUM,QANS,QID,VAL,ANS,RT1
S QNUM=0,QANS=0
S I=0 F S I=$O(DATA("answers",I)) Q:'I D
. S QID=DATA("answers",I,"id")
. S VAL=DATA("answers",I,"value")
. QUIT:$E(QID)'="q" ; skip intros, sections
. S QNUM=QNUM+1 ; QNUM is sequence w/o intros
. S QID=$E(QID,2,999) ; remove the "q"
. I VAL="null" S ANS(QNUM)=QID_U_"NOT ASKED" QUIT
. ; QANS is number answered, don't include skipped (1155 or 1157)
. I '((VAL="c1155")!(VAL="c1157")) S QANS=QANS+1
. S RT1=0 ; response type 1 is choice question
. I VAL="c1155"!(VAL="c1156")!(VAL="c1157") S RT1=1
. I $P($G(^YTT(601.72,QID,2)),U,2)=1 S RT1=1
. I RT1 S ANS(QNUM)=QID_U_$E(VAL,2,999) QUIT
. S ANS(QNUM)=QID D TXT2ANS(I,QNUM) ; handle longer WP values
K DATA("answers") ; now in ANS array (which may be large)
; save the answers
N YSDATA
S ANS("AD")=ADMIN
D SAVEALL^YTQAPI17(.YSDATA,.ANS)
I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Answers not saved") Q 0
Q 1
TXT2ANS(IDX,QNUM) ; Convert web to ANS format for DATA(IDX)
; expects DATA,ANS
N LEN,LN,NODE,J
S LEN=240,LN=0
S NODE=DATA("answers",IDX,"value")
D ADDSEGS(NODE)
I $D(DATA("answers",IDX,"value","\")) D
. F J=1:1 Q:'$D(DATA("answers",IDX,"value","\",J)) D
. . S NODE=DATA("answers",IDX,"value","\",J)
. . D ADDSEGS(NODE)
Q
ADDSEGS(NODE) ; split text in node into LEN segments with "|" for newlines
; expects DATA,ANS,LEN,LN
N I,X,END,FIRST,LAST
S END=$L(NODE),LAST=0 F I=0:1 D Q:LAST>END ; iterate thru each segment
. S FIRST=(I*LEN)+1,LAST=(I*LEN)+LEN,LN=LN+1 ; set first&last char positions
. S X=$TR($E(NODE,FIRST,LAST),$C(10),"|") ; set segment, chg newline to |
. S ANS(QNUM,LN)=X
Q
;
SCOREIT(DATA,SCORES) ; Score instrument based on incoming answers.
; Expects DATA("test")=TEST NAME
; Expects answers in the DATA("answers",i,"id"/"value") array
N TEST,ANSWERS,YSLG
I '$D(N) N N S N=0 ;Initialize for reports if needed.
S TEST=$G(DATA("name")) I TEST="" D SETERROR^YTQRUTL(404,"Missing Test") Q
S DATA("instrumentId")=$O(^YTT(601.71,"B",TEST,0))
I DATA("instrumentId")="" S DATA("instrumentId")=$O(^YTT(601.71,"B",$TR(TEST,"_"," "),0))
I DATA("instrumentId")="" D SETERROR^YTQRUTL(404,"Test not found") Q
I '$D(DATA("answers")) D SETERROR^YTQRUTL(404,"Missing Answers") Q
S YSLG=$$GET1^DIQ(601.71,DATA("instrumentId")_",",23)
I YSLG="Yes" D LGSCORE(.DATA,.SCORES) Q ;-->out Score legacy answers in 601.85
M ANSWERS=DATA("answers")
D CALC^YTSCOREX(TEST,.ANSWERS,.SCORES)
Q
LGSCORE(DATA,SCORES) ;
;
N TESTNM,ADFN,AUSER,ANSWERS
I '$D(DATA("patientId")) D SETERROR^YTQRUTL(404,"Missing patient id") Q
S TESTNM=$G(DATA("name"))
S ADFN=DATA("patientId")
S AUSER=$G(DATA("orderedById")) S:'AUSER AUSER=DUZ
M ANSWERS=DATA("answers")
D LEGACY^YTSCOREX(TESTNM,ADFN,AUSER,.ANSWERS,.SCORES)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRCDB 9704 printed Dec 13, 2024@02:18:42 Page 2
YTQRCDB ;BAL/KTL - MHA CLOUD DATABASE ADMIN RPC CALLS; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**239,224,249**;Dec 30, 1994;Build 30
+2 ;
+3 ;
+4 ; Reference to FILE^DIE in ICR #2053
+5 QUIT
SAVEADM(ARGS,DATA) ; Save instrument administration and answers
+1 NEW YSARR,ADMM,ANSRES,SCRRES
+2 ; Passed in ADMIN ID for previously scored, New ADMIN ID, 0=Error
SET ADMM=$$FILADMIN(.DATA)
+3 IF ADMM=0
QUIT "/api/mha/cdb/instrument/admin/"_ADMM
+4 SET ANSRES=$$FILANS(ADMM,.DATA)
+5 IF ANSRES=0
DO SETERROR^YTQRUTL(500,"Error Filing Answers")
SET ADMM=0
+6 IF ADMM'=0
IF $DATA(DATA("results"))
DO SAVESCR(ADMM,.DATA)
+7 QUIT "/api/mha/cdb/instrument/admin/"_ADMM
+8 ;
SCORADM(ARGS,DATA) ;Score administration
+1 ;Used when scoring algorithm for this instrument not yet implemented in cloud app
+2 NEW DATAOUT,ERRARY,JSONOUT,SCORES,I
+3 NEW YSID,YSNAM,YSRAW,YSTSCR,CNT
+4 KILL ^TMP("YTQ-JSON",$JOB),YTQRRSLT
+5 DO SCOREIT(.DATA,.SCORES)
+6 IF '$DATA(SCORES)
Begin DoDot:1
+7 DO SETERROR^YTQRUTL(500,"Error Scoring Answers")
+8 SET ^TMP("YTQ-JSON",$JOB,1,0)="ERROR"
SET YTQRRSLT=$NAME(^TMP("YTQ-JSON",$JOB))
End DoDot:1
QUIT "/api/mha/cdb/instrument/admin/scores/NOTOK"
+9 SET CNT=1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)="{""results"":["
+10 SET I=0
FOR
SET I=$ORDER(SCORES(I))
if I=""
QUIT
Begin DoDot:1
+11 SET YSID=$GET(SCORES(I,"id"))
+12 SET YSNAM=$GET(SCORES(I,"name"))
+13 SET YSRAW=$GET(SCORES(I,"raw"))
+14 SET YSTSCR=$GET(SCORES(I,"tscore"))
+15 SET CNT=CNT+1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)="{""id"":"_YSID_", ""name"":"""_YSNAM_""", ""raw"":"_YSRAW_$SELECT(YSTSCR]"":", ""tscore"":"_YSTSCR_"},",1:"},")
End DoDot:1
+16 SET ^TMP("YTQ-JSON",$JOB,CNT,0)=$EXTRACT(^TMP("YTQ-JSON",$JOB,CNT,0),1,$LENGTH(^TMP("YTQ-JSON",$JOB,CNT,0))-1)
+17 SET CNT=CNT+1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)="]}"
+18 SET YTQRRSLT=$NAME(^TMP("YTQ-JSON",$JOB))
+19 QUIT "/api/mha/cdb/instrument/admin/scores/OK"
+20 ;
SAVESCR(ADMM,DATA) ;Save scores for admin for instruments scored in cloud app and passed in
+1 ; ADMM = ADMINID
+2 ; DATA = ARRAY OF RESULTS
+3 NEW RARR,I,YS,YSID,YSNAM,YSRAW,YSTSC
+4 NEW SCL,SCLID
+5 if '$DATA(DATA("results"))
QUIT
+6 ; Sort results by Scale ID for Instrument Scale definition order matching
+7 SET I=0
FOR
SET I=$ORDER(DATA("results",I))
if +I=0
QUIT
Begin DoDot:1
+8 SET YSID=$GET(DATA("results",I,"scaleId"))
+9 SET YSNAM=$GET(DATA("results",I,"scaleName"))
+10 SET YSRAW=$GET(DATA("results",I,"rawScore"))
+11 SET YSTSC=$GET(DATA("results",I,"tScore"))
+12 if +YSID=0
QUIT
+13 SET RARR(YSID)=YSNAM_"="_YSRAW
+14 IF YSTSC]""
SET RARR(YSID)=RARR(YSID)_U_YSTSC
End DoDot:1
+15 SET YS("CODE")=$GET(DATA("name"))
+16 KILL ^TMP($JOB,"YSG")
+17 DO SCALEG^YTQAPI3(.YSDATA,.YS)
+18 KILL ^TMP($JOB,"YSCOR")
+19 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
+20 SET I=1
FOR
SET I=$ORDER(^TMP($JOB,"YSG",I))
if +I=0
QUIT
Begin DoDot:1
+21 SET SCL=^TMP($JOB,"YSG",I)
SET SCLID=$PIECE($PIECE(SCL,"=",2),U)
SET SCL=$PIECE($PIECE(SCL,"="),"Scale",2)
+22 if +SCL=0!(+SCLID=0)
QUIT
+23 SET ^TMP($JOB,"YSCOR",SCL+1)=$GET(RARR(SCLID))
End DoDot:1
+24 KILL YS
SET YS("AD")=$GET(ADMM)
+25 DO UPDSCORE^YTSCORE(.YSDATA,.YS)
+26 QUIT
+27 ;
FILADMIN(DATA) ;Get YSARR and file mh administration
+1 ; Expects required MH ADMINISTRATION fields in DATA(prop)
+2 ; Expects answers in the DATA("answers",i,"id"/"value") array
+3 NEW ANSWERS,TEST
+4 NEW I,ACNT,VAL,ADMIN
+5 SET TEST=$GET(DATA("name"))
IF TEST=""
DO SETERROR^YTQRUTL(404,"Missing Test")
QUIT 0
+6 SET DATA("instrumentId")=$ORDER(^YTT(601.71,"B",TEST,0))
+7 IF DATA("instrumentId")=""
SET DATA("instrumentId")=$ORDER(^YTT(601.71,"B",$TRANSLATE(TEST,"_"," "),0))
+8 IF DATA("instrumentId")=""
DO SETERROR^YTQRUTL(404,"Test not found")
QUIT 0
+9 IF '$DATA(DATA("answers"))
DO SETERROR^YTQRUTL(404,"Missing Answers")
QUIT 0
+10 IF '$DATA(DATA("patientId"))
DO SETERROR^YTQRUTL(404,"Missing patient id")
QUIT 0
+11 IF '$DATA(DATA("orderedById"))
DO SETERROR^YTQRUTL(404,"Missing ordering clinician")
QUIT 0
+12 IF '$DATA(DATA("locationId"))
DO SETERROR^YTQRUTL(404,"Missing location")
QUIT 0
+13 SET DATA("source")=$GET(DATA("source"))
IF DATA("source")=""
SET DATA("source")="mhaweb"
+14 SET DATA("consultId")=$GET(YSARR("consultId"))
+15 IF '$DATA(DATA("administeredById"))
SET DATA("administeredById")=$GET(DUZ)
+16 IF '$DATA(DATA("completedDate"))
SET DATA("completedDate")=$$NOW^XLFDT()
+17 IF '$DATA(DATA("dateSaved"))
SET DATA("dateSaved")=$$NOW^XLFDT()
+18 IF '$DATA(DATA("dateGiven"))
SET DATA("dateGiven")=$$NOW^XLFDT()
+19 ;Always Y?
SET DATA("complete")="YES"
+20 SET (I,ACNT)=0
FOR
SET I=$ORDER(DATA("answers",I))
if I=""
QUIT
Begin DoDot:1
+21 SET VAL=$GET(DATA("answers",I,"value"))
+22 IF VAL="null"
SET DATA("answers",I,"value")="c1155"
QUIT
+23 IF VAL[1156!(VAL[1157)
QUIT
+24 SET ACNT=ACNT+1
End DoDot:1
+25 SET DATA("numAns")=ACNT
+26 SET ADMIN=$$SETADM(.DATA)
+27 QUIT ADMIN
+28 ;
RVW(ARGS,DATA) ; update admin REVIEWED status
+1 ; Requires input
+2 ; DATA("adminId")
+3 ;
+4 NEW YS,ADMIN,YTERR,YSORD,YSCMPLT,YSOK,YSMESS,N0
+5 SET YSMESS=""
SET YSOK=""
+6 SET ADMIN=+$GET(DATA("adminId"))
+7 IF DATA("adminId")=""
SET YSMESS="Administration not sent."
+8 IF '$DATA(^YTT(601.84,ADMIN))=""
SET YSMESS="Administration not found."
+9 SET N0=$GET(^YTT(601.84,ADMIN,0))
SET YSORD=$PIECE(N0,U,6)
SET YSCMPLT=$PIECE(N0,U,9)
+10 IF $GET(DUZ)=YSORD
IF ($$REQCSGN^YTQRQAD3(ADMIN)="false")
SET YSOK=1
+11 SET YS(601.84,ADMIN_",",19)=YSOK
+12 DO FILE^DIE("","YS","YTERR")
+13 SET YSOK=$SELECT(YSOK=1:"SUCCESS",1:"FAIL")
+14 IF $DATA(YTERR)
SET YSMESS="Unable to update admin"
SET YSOK="FAIL"
+15 ;I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Unable to update admin") Q 0
+16 ; otherwise we're updating existing admin
QUIT "/api/mha/cdb/instrument/admin/reviewed/"_YSOK_U_YSMESS
+17 ;
SETADM(DATA) ; return the id for new/updated admin
+1 ; Requires input
+2 ; DATA("patientId")
+3 ; DATA("orderedById")
+4 ; DATA("administeredById")
+5 ; DATA("completedDate")
+6 ; DATA("dateSaved")
+7 ; DATA("dateGiven")
+8 ; DATA("instrumentId")
+9 ; Optional
+10 ; DATA("adminId") - if updating existing admin
+11 ; DATA("cosignerId")
+12 NEW YSDATA,YS,ADMIN
+13 SET ADMIN=+$GET(DATA("adminId"))
+14 SET YS("FILEN")=601.84
+15 IF ADMIN
SET YS("IEN")=ADMIN
IF 1
+16 IF '$TEST
SET YS(1)=".01^NEW^1"
+17 SET YS(2)="1^`"_DATA("patientId")
+18 SET YS(3)="2^`"_DATA("instrumentId")
+19 SET YS(4)="3^"_DATA("dateGiven")
+20 SET YS(5)="4^NOW"
+21 SET YS(6)="5^`"_DATA("orderedById")
+22 SET YS(7)="6^`"_DATA("administeredById")
+23 SET YS(8)="7^N"
+24 SET YS(9)="8^"_DATA("complete")
+25 SET YS(10)="9^"_DATA("numAns")
+26 SET YS(11)="13^`"_DATA("locationId")
+27 IF '$LENGTH($GET(DATA("source")))
SET DATA("source")="web"
+28 SET YS(12)="15^"_DATA("source")
+29 IF DATA("consultId")]""
SET YS(13)="17^"_DATA("consultId")
+30 DO ADMSAVE^YTQAPI1(.YSDATA,.YS)
+31 IF YSDATA(1)'="[DATA]"
DO SETERROR^YTQRUTL(500,"Unable to create admin")
QUIT 0
+32 ; create new admin, ien found in 2nd piece
IF 'ADMIN
QUIT $PIECE(YSDATA(2),U,2)
+33 ; otherwise we're updating existing admin
QUIT ADMIN
+34 ;
FILANS(ADMIN,DATA) ; File Answers for an ADMIN
+1 ; Requires: ADMIN = IEN of MH ADMINISTRATION
+2 ; DATA("answers",i,"id"/"value")
+3 NEW ARSL
+4 IF +$GET(ADMIN)=0
DO SETERROR^YTQRUTL(404,"Missing ADMIN ID")
QUIT 0
+5 IF '$DATA(^YTT(601.84,ADMIN))
DO SETERROR^YTQRUTL(404,"Invalid ADMIN ID")
QUIT 0
+6 IF '$DATA(DATA("answers"))
DO SETERROR^YTQRUTL(404,"Missing Answers")
QUIT 0
+7 SET ARSL=$$QASAVE(ADMIN,.DATA)
+8 QUIT ARSL
+9 ;
QASAVE(ADMIN,DATA) ; save questions and answers in DATA
+1 ; loop through DATA to create ANS array, then YSDATA array
+2 ; ANS(#)=questionId^choiceId <-- radio group question
+3 ; ANS(#,#)=wp value <-- all others
+4 ; Return: 1 = Success
+5 ; 0 = Failure
+6 NEW I,QNUM,QANS,QID,VAL,ANS,RT1
+7 SET QNUM=0
SET QANS=0
+8 SET I=0
FOR
SET I=$ORDER(DATA("answers",I))
if 'I
QUIT
Begin DoDot:1
+9 SET QID=DATA("answers",I,"id")
+10 SET VAL=DATA("answers",I,"value")
+11 ; skip intros, sections
if $EXTRACT(QID)'="q"
QUIT
+12 ; QNUM is sequence w/o intros
SET QNUM=QNUM+1
+13 ; remove the "q"
SET QID=$EXTRACT(QID,2,999)
+14 IF VAL="null"
SET ANS(QNUM)=QID_U_"NOT ASKED"
QUIT
+15 ; QANS is number answered, don't include skipped (1155 or 1157)
+16 IF '((VAL="c1155")!(VAL="c1157"))
SET QANS=QANS+1
+17 ; response type 1 is choice question
SET RT1=0
+18 IF VAL="c1155"!(VAL="c1156")!(VAL="c1157")
SET RT1=1
+19 IF $PIECE($GET(^YTT(601.72,QID,2)),U,2)=1
SET RT1=1
+20 IF RT1
SET ANS(QNUM)=QID_U_$EXTRACT(VAL,2,999)
QUIT
+21 ; handle longer WP values
SET ANS(QNUM)=QID
DO TXT2ANS(I,QNUM)
End DoDot:1
+22 ; now in ANS array (which may be large)
KILL DATA("answers")
+23 ; save the answers
+24 NEW YSDATA
+25 SET ANS("AD")=ADMIN
+26 DO SAVEALL^YTQAPI17(.YSDATA,.ANS)
+27 IF YSDATA(1)'="[DATA]"
DO SETERROR^YTQRUTL(500,"Answers not saved")
QUIT 0
+28 QUIT 1
TXT2ANS(IDX,QNUM) ; Convert web to ANS format for DATA(IDX)
+1 ; expects DATA,ANS
+2 NEW LEN,LN,NODE,J
+3 SET LEN=240
SET LN=0
+4 SET NODE=DATA("answers",IDX,"value")
+5 DO ADDSEGS(NODE)
+6 IF $DATA(DATA("answers",IDX,"value","\"))
Begin DoDot:1
+7 FOR J=1:1
if '$DATA(DATA("answers",IDX,"value","\",J))
QUIT
Begin DoDot:2
+8 SET NODE=DATA("answers",IDX,"value","\",J)
+9 DO ADDSEGS(NODE)
End DoDot:2
End DoDot:1
+10 QUIT
ADDSEGS(NODE) ; split text in node into LEN segments with "|" for newlines
+1 ; expects DATA,ANS,LEN,LN
+2 NEW I,X,END,FIRST,LAST
+3 ; iterate thru each segment
SET END=$LENGTH(NODE)
SET LAST=0
FOR I=0:1
Begin DoDot:1
+4 ; set first&last char positions
SET FIRST=(I*LEN)+1
SET LAST=(I*LEN)+LEN
SET LN=LN+1
+5 ; set segment, chg newline to |
SET X=$TRANSLATE($EXTRACT(NODE,FIRST,LAST),$CHAR(10),"|")
+6 SET ANS(QNUM,LN)=X
End DoDot:1
if LAST>END
QUIT
+7 QUIT
+8 ;
SCOREIT(DATA,SCORES) ; Score instrument based on incoming answers.
+1 ; Expects DATA("test")=TEST NAME
+2 ; Expects answers in the DATA("answers",i,"id"/"value") array
+3 NEW TEST,ANSWERS,YSLG
+4 ;Initialize for reports if needed.
IF '$DATA(N)
NEW N
SET N=0
+5 SET TEST=$GET(DATA("name"))
IF TEST=""
DO SETERROR^YTQRUTL(404,"Missing Test")
QUIT
+6 SET DATA("instrumentId")=$ORDER(^YTT(601.71,"B",TEST,0))
+7 IF DATA("instrumentId")=""
SET DATA("instrumentId")=$ORDER(^YTT(601.71,"B",$TRANSLATE(TEST,"_"," "),0))
+8 IF DATA("instrumentId")=""
DO SETERROR^YTQRUTL(404,"Test not found")
QUIT
+9 IF '$DATA(DATA("answers"))
DO SETERROR^YTQRUTL(404,"Missing Answers")
QUIT
+10 SET YSLG=$$GET1^DIQ(601.71,DATA("instrumentId")_",",23)
+11 ;-->out Score legacy answers in 601.85
IF YSLG="Yes"
DO LGSCORE(.DATA,.SCORES)
QUIT
+12 MERGE ANSWERS=DATA("answers")
+13 DO CALC^YTSCOREX(TEST,.ANSWERS,.SCORES)
+14 QUIT
LGSCORE(DATA,SCORES) ;
+1 ;
+2 NEW TESTNM,ADFN,AUSER,ANSWERS
+3 IF '$DATA(DATA("patientId"))
DO SETERROR^YTQRUTL(404,"Missing patient id")
QUIT
+4 SET TESTNM=$GET(DATA("name"))
+5 SET ADFN=DATA("patientId")
+6 SET AUSER=$GET(DATA("orderedById"))
if 'AUSER
SET AUSER=DUZ
+7 MERGE ANSWERS=DATA("answers")
+8 DO LEGACY^YTSCOREX(TESTNM,ADFN,AUSER,.ANSWERS,.SCORES)
+9 QUIT
