YTQRCDB ;BAL/KTL - MHA CLOUD DATABASE ADMIN RPC CALLS; 1/25/2017
;;5.01;MENTAL HEALTH;**239,224,249,250,236**;Dec 30, 1994;Build 25
;
;
; Reference to FILE^DIE in ICR #2053
; Reference to XLFSTR in ICR #19194
;
Q
SAVEADM(ARGS,DATA) ; Save instrument administration and answers
N YSARR,ADMM,ANSRES,SCRRES,TEST,YSLG
S TEST=$G(DATA("name")) I TEST="" D SETERROR^YTQRUTL(404,"Missing Test") Q "/api/mha/cdb/instrument/admin/"_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 "/api/mha/cdb/instrument/admin/"_0
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<1 D SETERROR^YTQRUTL(500,"Error Filing Answers") Q "/api/mha/cdb/instrument/admin/"_0
S YSLG=$$GET1^DIQ(601.71,DATA("instrumentId")_",",23)
I YSLG="Yes" K ^TMP($J) Q "/api/mha/cdb/instrument/admin/"_ADMM ; Don't score legacy instruments
S SCRRES=-1 I ADMM'=0 S SCRRES=$$SAVESCR(ADMM,.DATA)
I SCRRES<0 D SETERROR^YTQRUTL(400,"Error Filing Score")
K ^TMP($J) ;Clean up result setup
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,YSTSC,CNT,YSTSC2,YSTSC3
K ^TMP("YTQ-JSON",$J),YTQRRSLT
K ^TMP($J) N YS
S YS("CODE")=$G(DATA("name"))
D SCALEG^YTQAPI3(.YSDATA,.YS) ;Check if there are any scales for this instrument
I '$D(^TMP($J,"YSG",2)) D Q "/api/mha/cdb/instrument/admin/scores/NOSCORE"
. S ^TMP("YTQ-JSON",$J,1,0)="{}",YTQRRSLT=$NA(^TMP("YTQ-JSON",$J))
. K ^TMP($J)
K ^TMP($J)
D SCOREIT(.DATA,.SCORES)
I '$D(SCORES)!$D(SCORES("error")) 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 YSTSC=$G(SCORES(I,"tscore"))
. S YSTSC2=$G(SCORES(I,"tscore2"))
. S YSTSC3=$G(SCORES(I,"tscore3"))
. I YSRAW'="",(+YSRAW'=YSRAW) S YSRAW=""""_YSRAW_"""" ;String result
. I YSRAW="" S YSRAW="null"
. I YSTSC'="",(+YSTSC'=YSTSC) S YSTSC=""""_YSTSC_"""" ;String result
. I YSTSC="",$D(SCORES(I,"tscore")) S YSTSC="null" ;Must exist but be null, otherwise don't send tscore at all
. I YSTSC2'="",(+YSTSC2'=YSTSC2) S YSTSC2=""""_YSTSC2_"""" ;String result
. I YSTSC2="",$D(SCORES(I,"tscore2")) S YSTSC2="null"
. I YSTSC3'="",(+YSTSC3'=YSTSC3) S YSTSC3=""""_YSTSC3_"""" ;String result
. I YSTSC3="",$D(SCORES(I,"tscore3")) S YSTSC3="null"
. S CNT=CNT+1,^TMP("YTQ-JSON",$J,CNT,0)="{""id"":"_YSID_", ""name"":"""_YSNAM_""", ""raw"":"_YSRAW_$S(YSTSC]"":", ""tscore"":"_YSTSC,1:"")_$S(YSTSC2]"":", ""tscore2"":"_YSTSC2,1:"")_$S(YSTSC3]"":", ""tscore3"":"_YSTSC3,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,YSTSC2,YSTSC3
N SCL,SCLID,RMISS,SCRRES
S SCRRES=1 ;Default OK
N YS
K ^TMP($J,"YSG")
S YS("CODE")=$G(DATA("name"))
D SCALEG^YTQAPI3(.YSDATA,.YS) ;Check if there are any scales for this instrument
I $D(^TMP($J,"YSG",2)),'$D(DATA("results")) S SCRRES=-1 Q SCRRES ;Scales exist but no RESULT data sent
I '$D(^TMP($J,"YSG",2)),'$D(DATA("results")) Q SCRRES ;No scales for instrument no RESULTs, OK.
; 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"))
. S YSTSC2=$G(DATA("results",I,"tscore2"))
. S YSTSC3=$G(DATA("results",I,"tscore3"))
. I $$UP^XLFSTR(YSRAW)="NULL" S YSRAW=""
. I $$UP^XLFSTR(YSTSC)="NULL" S YSTSC=""
. I $$UP^XLFSTR(YSTSC2)="NULL" S YSTSC2=""
. I $$UP^XLFSTR(YSTSC3)="NULL" S YSTSC3=""
. Q:+YSID=0
. S RARR(YSID)=YSNAM_"="_YSRAW
. I YSTSC]"" S RARR(YSID)=RARR(YSID)_U_YSTSC
. I YSTSC2]"" S $P(RARR(YSID),U,3)=YSTSC2
. I YSTSC3]"" S $P(RARR(YSID),U,4)=YSTSC3
S YS("CODE")=$G(DATA("name"))
K ^TMP($J,"YSCOR")
S ^TMP($J,"YSCOR",1)="[DATA]"
S RMISS=0
S I=1 F S I=$O(^TMP($J,"YSG",I)) Q:+I=0!(RMISS'=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)
. I '$D(RARR(SCLID)) S RMISS=1 Q ;Result Missing
. S ^TMP($J,"YSCOR",SCL+1)=$G(RARR(SCLID))
I RMISS=1 S SCRRES=-1 Q SCRRES
K YS S YS("AD")=$G(ADMM)
D UPDSCORE^YTSCORE(.YSDATA,.YS)
Q SCRRES
;
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
N I,ACNT,VAL,ADMIN
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"
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 S YSOK=1 ;,($$REQCSGN^YTQRQAD3(ADMIN)="false")
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 +$G(DATA("consultId"))'=0 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 -1
I '$D(DATA("answers")) D SETERROR^YTQRUTL(404,"Missing Answers") Q -2
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 11914 printed Sep 23, 2025@19:54:47 Page 2
YTQRCDB ;BAL/KTL - MHA CLOUD DATABASE ADMIN RPC CALLS; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**239,224,249,250,236**;Dec 30, 1994;Build 25
+2 ;
+3 ;
+4 ; Reference to FILE^DIE in ICR #2053
+5 ; Reference to XLFSTR in ICR #19194
+6 ;
+7 QUIT
SAVEADM(ARGS,DATA) ; Save instrument administration and answers
+1 NEW YSARR,ADMM,ANSRES,SCRRES,TEST,YSLG
+2 SET TEST=$GET(DATA("name"))
IF TEST=""
DO SETERROR^YTQRUTL(404,"Missing Test")
QUIT "/api/mha/cdb/instrument/admin/"_0
+3 SET DATA("instrumentId")=$ORDER(^YTT(601.71,"B",TEST,0))
+4 IF DATA("instrumentId")=""
SET DATA("instrumentId")=$ORDER(^YTT(601.71,"B",$TRANSLATE(TEST,"_"," "),0))
+5 IF DATA("instrumentId")=""
DO SETERROR^YTQRUTL(404,"Test not found")
QUIT "/api/mha/cdb/instrument/admin/"_0
+6 ; Passed in ADMIN ID for previously scored, New ADMIN ID, 0=Error
SET ADMM=$$FILADMIN(.DATA)
+7 IF ADMM=0
QUIT "/api/mha/cdb/instrument/admin/"_ADMM
+8 SET ANSRES=$$FILANS(ADMM,.DATA)
+9 IF ANSRES<1
DO SETERROR^YTQRUTL(500,"Error Filing Answers")
QUIT "/api/mha/cdb/instrument/admin/"_0
+10 SET YSLG=$$GET1^DIQ(601.71,DATA("instrumentId")_",",23)
+11 ; Don't score legacy instruments
IF YSLG="Yes"
KILL ^TMP($JOB)
QUIT "/api/mha/cdb/instrument/admin/"_ADMM
+12 SET SCRRES=-1
IF ADMM'=0
SET SCRRES=$$SAVESCR(ADMM,.DATA)
+13 IF SCRRES<0
DO SETERROR^YTQRUTL(400,"Error Filing Score")
+14 ;Clean up result setup
KILL ^TMP($JOB)
+15 QUIT "/api/mha/cdb/instrument/admin/"_ADMM
+16 ;
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,YSTSC,CNT,YSTSC2,YSTSC3
+4 KILL ^TMP("YTQ-JSON",$JOB),YTQRRSLT
+5 KILL ^TMP($JOB)
NEW YS
+6 SET YS("CODE")=$GET(DATA("name"))
+7 ;Check if there are any scales for this instrument
DO SCALEG^YTQAPI3(.YSDATA,.YS)
+8 IF '$DATA(^TMP($JOB,"YSG",2))
Begin DoDot:1
+9 SET ^TMP("YTQ-JSON",$JOB,1,0)="{}"
SET YTQRRSLT=$NAME(^TMP("YTQ-JSON",$JOB))
+10 KILL ^TMP($JOB)
End DoDot:1
QUIT "/api/mha/cdb/instrument/admin/scores/NOSCORE"
+11 KILL ^TMP($JOB)
+12 DO SCOREIT(.DATA,.SCORES)
+13 IF '$DATA(SCORES)!$DATA(SCORES("error"))
Begin DoDot:1
+14 DO SETERROR^YTQRUTL(500,"Error Scoring Answers")
+15 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"
+16 SET CNT=1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)="{""results"":["
+17 SET I=0
FOR
SET I=$ORDER(SCORES(I))
if I=""
QUIT
Begin DoDot:1
+18 SET YSID=$GET(SCORES(I,"id"))
+19 SET YSNAM=$GET(SCORES(I,"name"))
+20 SET YSRAW=$GET(SCORES(I,"raw"))
+21 SET YSTSC=$GET(SCORES(I,"tscore"))
+22 SET YSTSC2=$GET(SCORES(I,"tscore2"))
+23 SET YSTSC3=$GET(SCORES(I,"tscore3"))
+24 ;String result
IF YSRAW'=""
IF (+YSRAW'=YSRAW)
SET YSRAW=""""_YSRAW_""""
+25 IF YSRAW=""
SET YSRAW="null"
+26 ;String result
IF YSTSC'=""
IF (+YSTSC'=YSTSC)
SET YSTSC=""""_YSTSC_""""
+27 ;Must exist but be null, otherwise don't send tscore at all
IF YSTSC=""
IF $DATA(SCORES(I,"tscore"))
SET YSTSC="null"
+28 ;String result
IF YSTSC2'=""
IF (+YSTSC2'=YSTSC2)
SET YSTSC2=""""_YSTSC2_""""
+29 IF YSTSC2=""
IF $DATA(SCORES(I,"tscore2"))
SET YSTSC2="null"
+30 ;String result
IF YSTSC3'=""
IF (+YSTSC3'=YSTSC3)
SET YSTSC3=""""_YSTSC3_""""
+31 IF YSTSC3=""
IF $DATA(SCORES(I,"tscore3"))
SET YSTSC3="null"
+32 SET CNT=CNT+1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)="{""id"":"_YSID_", ""name"":"""_YSNAM_""", ""raw"":"_YSRAW_$SELECT(YSTSC]"":", ""tscore"":"_YSTSC,1:"")_$SELECT(YSTSC2]"":", ""tscore2"":"_YSTSC2,1:"")_$SELECT(YSTSC3]"":", ""tscore3"":"_YSTSC3,1:"")_"},"
End DoDot:1
+33 SET ^TMP("YTQ-JSON",$JOB,CNT,0)=$EXTRACT(^TMP("YTQ-JSON",$JOB,CNT,0),1,$LENGTH(^TMP("YTQ-JSON",$JOB,CNT,0))-1)
+34 SET CNT=CNT+1
SET ^TMP("YTQ-JSON",$JOB,CNT,0)="]}"
+35 SET YTQRRSLT=$NAME(^TMP("YTQ-JSON",$JOB))
+36 QUIT "/api/mha/cdb/instrument/admin/scores/OK"
+37 ;
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,YSTSC2,YSTSC3
+4 NEW SCL,SCLID,RMISS,SCRRES
+5 ;Default OK
SET SCRRES=1
+6 NEW YS
+7 KILL ^TMP($JOB,"YSG")
+8 SET YS("CODE")=$GET(DATA("name"))
+9 ;Check if there are any scales for this instrument
DO SCALEG^YTQAPI3(.YSDATA,.YS)
+10 ;Scales exist but no RESULT data sent
IF $DATA(^TMP($JOB,"YSG",2))
IF '$DATA(DATA("results"))
SET SCRRES=-1
QUIT SCRRES
+11 ;No scales for instrument no RESULTs, OK.
IF '$DATA(^TMP($JOB,"YSG",2))
IF '$DATA(DATA("results"))
QUIT SCRRES
+12 ; Sort results by Scale ID for Instrument Scale definition order matching
+13 SET I=0
FOR
SET I=$ORDER(DATA("results",I))
if +I=0
QUIT
Begin DoDot:1
+14 SET YSID=$GET(DATA("results",I,"scaleId"))
+15 SET YSNAM=$GET(DATA("results",I,"scaleName"))
+16 SET YSRAW=$GET(DATA("results",I,"rawScore"))
+17 SET YSTSC=$GET(DATA("results",I,"tscore"))
+18 SET YSTSC2=$GET(DATA("results",I,"tscore2"))
+19 SET YSTSC3=$GET(DATA("results",I,"tscore3"))
+20 IF $$UP^XLFSTR(YSRAW)="NULL"
SET YSRAW=""
+21 IF $$UP^XLFSTR(YSTSC)="NULL"
SET YSTSC=""
+22 IF $$UP^XLFSTR(YSTSC2)="NULL"
SET YSTSC2=""
+23 IF $$UP^XLFSTR(YSTSC3)="NULL"
SET YSTSC3=""
+24 if +YSID=0
QUIT
+25 SET RARR(YSID)=YSNAM_"="_YSRAW
+26 IF YSTSC]""
SET RARR(YSID)=RARR(YSID)_U_YSTSC
+27 IF YSTSC2]""
SET $PIECE(RARR(YSID),U,3)=YSTSC2
+28 IF YSTSC3]""
SET $PIECE(RARR(YSID),U,4)=YSTSC3
End DoDot:1
+29 SET YS("CODE")=$GET(DATA("name"))
+30 KILL ^TMP($JOB,"YSCOR")
+31 SET ^TMP($JOB,"YSCOR",1)="[DATA]"
+32 SET RMISS=0
+33 SET I=1
FOR
SET I=$ORDER(^TMP($JOB,"YSG",I))
if +I=0!(RMISS'=0)
QUIT
Begin DoDot:1
+34 SET SCL=^TMP($JOB,"YSG",I)
SET SCLID=$PIECE($PIECE(SCL,"=",2),U)
SET SCL=$PIECE($PIECE(SCL,"="),"Scale",2)
+35 if +SCL=0!(+SCLID=0)
QUIT
+36 ;Result Missing
IF '$DATA(RARR(SCLID))
SET RMISS=1
QUIT
+37 SET ^TMP($JOB,"YSCOR",SCL+1)=$GET(RARR(SCLID))
End DoDot:1
+38 IF RMISS=1
SET SCRRES=-1
QUIT SCRRES
+39 KILL YS
SET YS("AD")=$GET(ADMM)
+40 DO UPDSCORE^YTSCORE(.YSDATA,.YS)
+41 QUIT SCRRES
+42 ;
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
+4 NEW I,ACNT,VAL,ADMIN
+5 IF '$DATA(DATA("answers"))
DO SETERROR^YTQRUTL(404,"Missing Answers")
QUIT 0
+6 IF '$DATA(DATA("patientId"))
DO SETERROR^YTQRUTL(404,"Missing patient id")
QUIT 0
+7 IF '$DATA(DATA("orderedById"))
DO SETERROR^YTQRUTL(404,"Missing ordering clinician")
QUIT 0
+8 IF '$DATA(DATA("locationId"))
DO SETERROR^YTQRUTL(404,"Missing location")
QUIT 0
+9 SET DATA("source")=$GET(DATA("source"))
IF DATA("source")=""
SET DATA("source")="mhaweb"
+10 IF '$DATA(DATA("administeredById"))
SET DATA("administeredById")=$GET(DUZ)
+11 IF '$DATA(DATA("completedDate"))
SET DATA("completedDate")=$$NOW^XLFDT()
+12 IF '$DATA(DATA("dateSaved"))
SET DATA("dateSaved")=$$NOW^XLFDT()
+13 IF '$DATA(DATA("dateGiven"))
SET DATA("dateGiven")=$$NOW^XLFDT()
+14 ;Always Y?
SET DATA("complete")="YES"
+15 SET (I,ACNT)=0
FOR
SET I=$ORDER(DATA("answers",I))
if I=""
QUIT
Begin DoDot:1
+16 SET VAL=$GET(DATA("answers",I,"value"))
+17 IF VAL="null"
SET DATA("answers",I,"value")="c1155"
QUIT
+18 IF VAL[1156!(VAL[1157)
QUIT
+19 SET ACNT=ACNT+1
End DoDot:1
+20 SET DATA("numAns")=ACNT
+21 SET ADMIN=$$SETADM(.DATA)
+22 QUIT ADMIN
+23 ;
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 ;,($$REQCSGN^YTQRQAD3(ADMIN)="false")
IF $GET(DUZ)=YSORD
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 +$GET(DATA("consultId"))'=0
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 -1
+6 IF '$DATA(DATA("answers"))
DO SETERROR^YTQRUTL(404,"Missing Answers")
QUIT -2
+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
