YTQRQAD2 ;SLC/KCM - RESTful Calls to set/get MHA administrations ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,141,173,178,182,181,199,202,204,208,233,223,234,238**;Dec 30, 1994;Build 25
;
SAVEADM(ARGS,DATA) ; save answers and return /ys/mha/admin/{adminId}
I $G(DATA("assignmentId"))?36ANP G POSTADM^YTQRCRW
N ADMIN
S ADMIN=$$QASAVE(.DATA) QUIT:'ADMIN "" ; create admin & answer records
;
; create a note if this was patient-entered
N ASMT,CPLT,PTENT,LSTASMT,PNOT,AGPROG,TMPYS
S ASMT=DATA("assignmentId")
S LSTASMT=$G(DATA("lastAssignment"))
S CPLT=$S(DATA("complete")="true":"Y",1:"N")
S PTENT=($G(^XTMP("YTQASMT-SET-"_ASMT,1,"entryMode"))="patient")
I (CPLT="Y"),PTENT,(LSTASMT'="Yes") D NOTE4PT^YTQRQAD3(ADMIN,.DATA)
;
; update the assignment with adminId, remove completed admins/assignments
N I,NOD,REMAIN
S NOD="YTQASMT-SET-"_ASMT,REMAIN=0
S I=0 F S I=$O(^XTMP(NOD,1,"instruments",I)) Q:'I D
. I ^XTMP(NOD,1,"instruments",I,"id")=DATA("instrumentId") D QUIT
. . ; remove instrument if complete and staff-entered
. . I 'PTENT,(CPLT="Y") K ^XTMP(NOD,1,"instruments",I) QUIT
. . ;I CPLT="Y" K ^XTMP(NOD,1,"instruments",I) QUIT ; patient-entered (may need to keep)
. . S ^XTMP(NOD,1,"instruments",I,"adminId")=ADMIN
. . S ^XTMP(NOD,1,"instruments",I,"complete")=DATA("complete")
. . I CPLT'="Y" S REMAIN=1
. I $G(^XTMP(NOD,1,"instruments",I,"complete"))'="true" S REMAIN=1
I PTENT,(LSTASMT="Yes"),(CPLT="Y") D
. I $$ALWNOTE^YTQRQAD3(ADMIN)="true" D BLDRPT^YTQRRPT(.TMPYS,ADMIN,79)
. D SPLTADM^YTQRCAT(ADMIN) ; separate out the admins if CAT
S AGPROG=$D(^XTMP(NOD,2))
;I LSTASMT="Yes",AGPROG S PNOT=$$FILPNOT^YTQRQAD8(ASMT,"","","",.TMPYS)
;Last instrument=Yes and either saved aggregate progress note or TMPYS from current PE instrument.
I LSTASMT="Yes",(AGPROG!$D(TMPYS)) S PNOT=$$FILPNOT^YTQRQAD8(ASMT,ADMIN,"","",.TMPYS)
;Check for consolidated progress note node 2. If exists, ASMT deleted in YTQRQAD8
I 'REMAIN,'$D(^XTMP(NOD,2)),$D(^XTMP(NOD,0)) D DELASMT1^YTQRQAD1(ASMT)
Q "/api/mha/instrument/admin/"_ADMIN ; was erroneously /ys/mha/admin/
;
QASAVE(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
N I,QNUM,QANS,QID,VAL,ANS,RT1,ADMIN
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 admin itself
S ADMIN=$$SETADM(.DATA,QANS)
Q:'ADMIN ""
; 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 ""
Q ADMIN
;
SETADM(DATA,NUM) ; return the id for new/updated admin
N YSDATA,YS,NODE,ADMIN,ADMINDT,ASMTID
S ASMTID=DATA("assignmentId")
S NODE=$S(ASMTID?36ANP:"YTQCPRS-",1:"YTQASMT-SET-")_ASMTID
S ADMIN=+$G(DATA("adminId"))
I 'ADMIN S ADMIN=$$ADM4ASMT(NODE,DATA("instrumentId")) ; auto-save fix
;Admin Date added so user can select previous date, time is arbitrary based on current MHA standard
S ADMINDT=$G(^XTMP(NODE,1,"adminDate")) I ADMINDT]"" S ADMINDT=$$ETFM(ADMINDT) S:ADMINDT ADMINDT=ADMINDT_"."_$P($$NOW^XLFDT(),".",2)
S YS("FILEN")=601.84
I ADMIN S YS("IEN")=ADMIN I 1
E S YS(1)=".01^NEW^1"
S YS(2)="1^`"_$G(^XTMP(NODE,1,"patient","dfn"))
S YS(3)="2^`"_DATA("instrumentId")
S YS(4)="3^"_$S(ADMINDT]"":ADMINDT,1:$G(^XTMP(NODE,1,"date")))
;S YS(4)="3^"_$G(^XTMP(NODE,1,"date"))
S YS(5)="4^NOW"
S YS(6)="5^`"_$G(^XTMP(NODE,1,"orderedBy"))
S YS(7)="6^`"_$G(^XTMP(NODE,1,"interview"))
S YS(8)="7^N"
S YS(9)="8^"_$S(DATA("complete")="true":"YES",1:"NO")
S YS(10)="9^"_NUM
S YS(11)="13^`"_$G(^XTMP(NODE,1,"location"))
I '$L($G(DATA("source"))) S DATA("source")="web"
S YS(12)="15^"_DATA("source")
I $D(^XTMP(NODE,1,"consult")),($G(^XTMP(NODE,1,"consult"))]"") S YS(13)="17^"_^XTMP(NODE,1,"consult")
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
;
ETFM(YSDT) ;External to FM
;YSDT = DATE in external
N X,Y
I YSDT["@" S YSDT=$P(YSDT,"@")
S X=YSDT D ^%DT
I Y<0 S Y="" ;Invalid YSDT
Q Y
ADM4ASMT(NODE,TESTID) ; return adminId if one has been saved for assignment
N I,CURADM
S CURADM=0
S I=0 F S I=$O(^XTMP(NODE,1,"instruments",I)) Q:'I D Q:CURADM
. I $G(^XTMP(NODE,1,"instruments",I,"id"))'=TESTID Q
. I $G(^XTMP(NODE,1,"instruments",I,"adminId"))>0 S CURADM=^XTMP(NODE,1,"instruments",I,"adminId")
I $L(CURADM,"-")>0 S CURADM=0 ; only "real" admins, not UUID's
Q CURADM
;
GETADM(ARGS,RESULTS) ; get answers for administration identified by ARGS("adminId")
I '$L($G(ARGS("adminId"))) D SETERROR^YTQRUTL(404,"Missing admin parameter") Q
I ARGS("adminId")?36ANP1"-".N G GETADM^YTQRCRW
I $D(^YTT(601.84,ARGS("adminId")))<10 D Q
. D SETERROR^YTQRUTL(404,"Admin not found: "_ARGS("adminId"))
;
N ADMIN,X0,TST,QID,ANS,CTNT,SEQ,TYP,VAL,TOT,NA,TMP,I,J,N,L
S ADMIN=ARGS("adminId"),X0=^YTT(601.84,ADMIN,0),TST=$P(X0,U,3)
S RESULTS("adminId")=ADMIN
S RESULTS("complete")=$S($P(X0,U,9)="Y":"true",1:"false")
S RESULTS("instrumentId")=TST
; iterate through answers to get values and sort by sequence
S (TOT,NA)=0 ; total questions & not answered count
S QID=0 F S QID=$O(^YTT(601.85,"AC",ADMIN,QID)) Q:'QID D
. S CTNT=$O(^YTT(601.76,"AF",TST,QID,0))
. S SEQ=$P($G(^YTT(601.76,+CTNT,0)),U,3) S:'SEQ SEQ=1
. S TYP=+$P($G(^YTT(601.72,QID,2)),U,2)
. S ANS=0 F S ANS=$O(^YTT(601.85,"AC",ADMIN,QID,ANS)) Q:'ANS D
. . S VAL=$P(^YTT(601.85,ANS,0),U,4),TOT=TOT+1
. . I VAL="NOT ASKED"!(VAL=1155)!(VAL=1157) S NA=NA+1 ; skipped=not answered
. . I VAL="NOT ASKED" S TMP(+SEQ)=QID_U_"null" QUIT ; not asked
. . I VAL=1155!(VAL=1156)!(VAL=1157) S TYP=1 ; skipped values
. . I TYP=1 S TMP(+SEQ)=QID_U_"c"_VAL QUIT ; mult choice
. . S VAL=$G(^YTT(601.85,ANS,1,1,0)) ; integer, etc.
. . I TYP'=5,(TYP'=11) S TMP(+SEQ)=QID_U_VAL QUIT
. . S (N,L)=0 F S N=$O(^YTT(601.85,ANS,1,N)) Q:'N D ; memo and checkbox fields
. . . S VAL=$G(^YTT(601.85,ANS,1,N,0))
. . . I '$D(TMP(+SEQ)) S TMP(+SEQ)=QID_U_$TR(VAL,"|",$C(10)) I 1
. . . E S L=L+1,TMP(+SEQ,L)=$TR(VAL,"|",$C(10))
N CATPROG S CATPROG=$$CHKPROG^YTQRCAT(ADMIN)
I CATPROG>-1 S RESULTS("progress")=CATPROG I 1
E S RESULTS("progress")=$S(TOT>0:$P((((TOT-NA)/TOT)*100)+.5,"."),1:0)
; now move sorted responses from TMP into "answers" nodes
S I="",N=0 F S I=$O(TMP(I)) Q:'$L(I) S N=N+1 D
. S RESULTS("answers",N,"id")="q"_$P(TMP(I),U)
. S RESULTS("answers",N,"value")=$P(TMP(I),U,2,999)
. I $D(TMP(I))>9 S J="",L=0 F S J=$O(TMP(I,J)) Q:'$L(J) S L=L+1 D
. . S RESULTS("answers",N,"value","\",L)=TMP(I,J)
Q
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
GETCHKS(ARGS,RESULTS) ; verify answer string & return check messages if needed
;ARGS("q6440")="c2420" -- may be choice id
;ARGS("q6439")="08/07/2019" -- or literal
S RESULTS("count")=0
I ARGS("instrumentName")="BAM-C" D VERIFY^YTSBAMC(.ARGS,.RESULTS)
I ARGS("instrumentName")="BAM-R" D VERIFY^YTSBAMR(.ARGS,.RESULTS)
I ARGS("instrumentName")="BAM-IOP" D VERIFY^YTSBAMI(.ARGS,.RESULTS)
I ARGS("instrumentName")="BAM-C-CBT-SUD" D VERIFY^YTSBAMCC(.ARGS,.RESULTS)
I ARGS("instrumentName")="BAM-R-CSG-SUD" D VERIFY^YTSBAMRC(.ARGS,.RESULTS)
I ARGS("instrumentName")="BAM-IOP-CSG-SUD" D VERIFY^YTSBAMIC(.ARGS,.RESULTS)
I ARGS("instrumentName")="SODU" D VERIFY^YTSSODU(.ARGS,.RESULTS)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRQAD2 9083 printed Nov 22, 2024@17:28:56 Page 2
YTQRQAD2 ;SLC/KCM - RESTful Calls to set/get MHA administrations ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,141,173,178,182,181,199,202,204,208,233,223,234,238**;Dec 30, 1994;Build 25
+2 ;
SAVEADM(ARGS,DATA) ; save answers and return /ys/mha/admin/{adminId}
+1 IF $GET(DATA("assignmentId"))?36ANP
GOTO POSTADM^YTQRCRW
+2 NEW ADMIN
+3 ; create admin & answer records
SET ADMIN=$$QASAVE(.DATA)
if 'ADMIN
QUIT ""
+4 ;
+5 ; create a note if this was patient-entered
+6 NEW ASMT,CPLT,PTENT,LSTASMT,PNOT,AGPROG,TMPYS
+7 SET ASMT=DATA("assignmentId")
+8 SET LSTASMT=$GET(DATA("lastAssignment"))
+9 SET CPLT=$SELECT(DATA("complete")="true":"Y",1:"N")
+10 SET PTENT=($GET(^XTMP("YTQASMT-SET-"_ASMT,1,"entryMode"))="patient")
+11 IF (CPLT="Y")
IF PTENT
IF (LSTASMT'="Yes")
DO NOTE4PT^YTQRQAD3(ADMIN,.DATA)
+12 ;
+13 ; update the assignment with adminId, remove completed admins/assignments
+14 NEW I,NOD,REMAIN
+15 SET NOD="YTQASMT-SET-"_ASMT
SET REMAIN=0
+16 SET I=0
FOR
SET I=$ORDER(^XTMP(NOD,1,"instruments",I))
if 'I
QUIT
Begin DoDot:1
+17 IF ^XTMP(NOD,1,"instruments",I,"id")=DATA("instrumentId")
Begin DoDot:2
+18 ; remove instrument if complete and staff-entered
+19 IF 'PTENT
IF (CPLT="Y")
KILL ^XTMP(NOD,1,"instruments",I)
QUIT
+20 ;I CPLT="Y" K ^XTMP(NOD,1,"instruments",I) QUIT ; patient-entered (may need to keep)
+21 SET ^XTMP(NOD,1,"instruments",I,"adminId")=ADMIN
+22 SET ^XTMP(NOD,1,"instruments",I,"complete")=DATA("complete")
+23 IF CPLT'="Y"
SET REMAIN=1
End DoDot:2
QUIT
+24 IF $GET(^XTMP(NOD,1,"instruments",I,"complete"))'="true"
SET REMAIN=1
End DoDot:1
+25 IF PTENT
IF (LSTASMT="Yes")
IF (CPLT="Y")
Begin DoDot:1
+26 IF $$ALWNOTE^YTQRQAD3(ADMIN)="true"
DO BLDRPT^YTQRRPT(.TMPYS,ADMIN,79)
+27 ; separate out the admins if CAT
DO SPLTADM^YTQRCAT(ADMIN)
End DoDot:1
+28 SET AGPROG=$DATA(^XTMP(NOD,2))
+29 ;I LSTASMT="Yes",AGPROG S PNOT=$$FILPNOT^YTQRQAD8(ASMT,"","","",.TMPYS)
+30 ;Last instrument=Yes and either saved aggregate progress note or TMPYS from current PE instrument.
+31 IF LSTASMT="Yes"
IF (AGPROG!$DATA(TMPYS))
SET PNOT=$$FILPNOT^YTQRQAD8(ASMT,ADMIN,"","",.TMPYS)
+32 ;Check for consolidated progress note node 2. If exists, ASMT deleted in YTQRQAD8
+33 IF 'REMAIN
IF '$DATA(^XTMP(NOD,2))
IF $DATA(^XTMP(NOD,0))
DO DELASMT1^YTQRQAD1(ASMT)
+34 ; was erroneously /ys/mha/admin/
QUIT "/api/mha/instrument/admin/"_ADMIN
+35 ;
QASAVE(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 NEW I,QNUM,QANS,QID,VAL,ANS,RT1,ADMIN
+5 SET QNUM=0
SET QANS=0
+6 SET I=0
FOR
SET I=$ORDER(DATA("answers",I))
if 'I
QUIT
Begin DoDot:1
+7 SET QID=DATA("answers",I,"id")
+8 SET VAL=DATA("answers",I,"value")
+9 ; skip intros, sections
if $EXTRACT(QID)'="q"
QUIT
+10 ; QNUM is sequence w/o intros
SET QNUM=QNUM+1
+11 ; remove the "q"
SET QID=$EXTRACT(QID,2,999)
+12 IF VAL="null"
SET ANS(QNUM)=QID_U_"NOT ASKED"
QUIT
+13 ; QANS is number answered, don't include skipped (1155 or 1157)
+14 IF '((VAL="c1155")!(VAL="c1157"))
SET QANS=QANS+1
+15 ; response type 1 is choice question
SET RT1=0
+16 IF VAL="c1155"!(VAL="c1156")!(VAL="c1157")
SET RT1=1
+17 IF $PIECE($GET(^YTT(601.72,QID,2)),U,2)=1
SET RT1=1
+18 IF RT1
SET ANS(QNUM)=QID_U_$EXTRACT(VAL,2,999)
QUIT
+19 ; handle longer WP values
SET ANS(QNUM)=QID
DO TXT2ANS(I,QNUM)
End DoDot:1
+20 ; now in ANS array (which may be large)
KILL DATA("answers")
+21 ; save admin itself
+22 SET ADMIN=$$SETADM(.DATA,QANS)
+23 if 'ADMIN
QUIT ""
+24 ; save the answers
+25 NEW YSDATA
+26 SET ANS("AD")=ADMIN
+27 DO SAVEALL^YTQAPI17(.YSDATA,.ANS)
+28 IF YSDATA(1)'="[DATA]"
DO SETERROR^YTQRUTL(500,"Answers not saved")
QUIT ""
+29 QUIT ADMIN
+30 ;
SETADM(DATA,NUM) ; return the id for new/updated admin
+1 NEW YSDATA,YS,NODE,ADMIN,ADMINDT,ASMTID
+2 SET ASMTID=DATA("assignmentId")
+3 SET NODE=$SELECT(ASMTID?36ANP:"YTQCPRS-",1:"YTQASMT-SET-")_ASMTID
+4 SET ADMIN=+$GET(DATA("adminId"))
+5 ; auto-save fix
IF 'ADMIN
SET ADMIN=$$ADM4ASMT(NODE,DATA("instrumentId"))
+6 ;Admin Date added so user can select previous date, time is arbitrary based on current MHA standard
+7 SET ADMINDT=$GET(^XTMP(NODE,1,"adminDate"))
IF ADMINDT]""
SET ADMINDT=$$ETFM(ADMINDT)
if ADMINDT
SET ADMINDT=ADMINDT_"."_$PIECE($$NOW^XLFDT(),".",2)
+8 SET YS("FILEN")=601.84
+9 IF ADMIN
SET YS("IEN")=ADMIN
IF 1
+10 IF '$TEST
SET YS(1)=".01^NEW^1"
+11 SET YS(2)="1^`"_$GET(^XTMP(NODE,1,"patient","dfn"))
+12 SET YS(3)="2^`"_DATA("instrumentId")
+13 SET YS(4)="3^"_$SELECT(ADMINDT]"":ADMINDT,1:$GET(^XTMP(NODE,1,"date")))
+14 ;S YS(4)="3^"_$G(^XTMP(NODE,1,"date"))
+15 SET YS(5)="4^NOW"
+16 SET YS(6)="5^`"_$GET(^XTMP(NODE,1,"orderedBy"))
+17 SET YS(7)="6^`"_$GET(^XTMP(NODE,1,"interview"))
+18 SET YS(8)="7^N"
+19 SET YS(9)="8^"_$SELECT(DATA("complete")="true":"YES",1:"NO")
+20 SET YS(10)="9^"_NUM
+21 SET YS(11)="13^`"_$GET(^XTMP(NODE,1,"location"))
+22 IF '$LENGTH($GET(DATA("source")))
SET DATA("source")="web"
+23 SET YS(12)="15^"_DATA("source")
+24 IF $DATA(^XTMP(NODE,1,"consult"))
IF ($GET(^XTMP(NODE,1,"consult"))]"")
SET YS(13)="17^"_^XTMP(NODE,1,"consult")
+25 DO ADMSAVE^YTQAPI1(.YSDATA,.YS)
+26 IF YSDATA(1)'="[DATA]"
DO SETERROR^YTQRUTL(500,"Unable to create admin")
QUIT 0
+27 ; create new admin, ien found in 2nd piece
IF 'ADMIN
QUIT $PIECE(YSDATA(2),U,2)
+28 ; otherwise we're updating existing admin
QUIT ADMIN
+29 ;
ETFM(YSDT) ;External to FM
+1 ;YSDT = DATE in external
+2 NEW X,Y
+3 IF YSDT["@"
SET YSDT=$PIECE(YSDT,"@")
+4 SET X=YSDT
DO ^%DT
+5 ;Invalid YSDT
IF Y<0
SET Y=""
+6 QUIT Y
ADM4ASMT(NODE,TESTID) ; return adminId if one has been saved for assignment
+1 NEW I,CURADM
+2 SET CURADM=0
+3 SET I=0
FOR
SET I=$ORDER(^XTMP(NODE,1,"instruments",I))
if 'I
QUIT
Begin DoDot:1
+4 IF $GET(^XTMP(NODE,1,"instruments",I,"id"))'=TESTID
QUIT
+5 IF $GET(^XTMP(NODE,1,"instruments",I,"adminId"))>0
SET CURADM=^XTMP(NODE,1,"instruments",I,"adminId")
End DoDot:1
if CURADM
QUIT
+6 ; only "real" admins, not UUID's
IF $LENGTH(CURADM,"-")>0
SET CURADM=0
+7 QUIT CURADM
+8 ;
GETADM(ARGS,RESULTS) ; get answers for administration identified by ARGS("adminId")
+1 IF '$LENGTH($GET(ARGS("adminId")))
DO SETERROR^YTQRUTL(404,"Missing admin parameter")
QUIT
+2 IF ARGS("adminId")?36ANP1"-".N
GOTO GETADM^YTQRCRW
+3 IF $DATA(^YTT(601.84,ARGS("adminId")))<10
Begin DoDot:1
+4 DO SETERROR^YTQRUTL(404,"Admin not found: "_ARGS("adminId"))
End DoDot:1
QUIT
+5 ;
+6 NEW ADMIN,X0,TST,QID,ANS,CTNT,SEQ,TYP,VAL,TOT,NA,TMP,I,J,N,L
+7 SET ADMIN=ARGS("adminId")
SET X0=^YTT(601.84,ADMIN,0)
SET TST=$PIECE(X0,U,3)
+8 SET RESULTS("adminId")=ADMIN
+9 SET RESULTS("complete")=$SELECT($PIECE(X0,U,9)="Y":"true",1:"false")
+10 SET RESULTS("instrumentId")=TST
+11 ; iterate through answers to get values and sort by sequence
+12 ; total questions & not answered count
SET (TOT,NA)=0
+13 SET QID=0
FOR
SET QID=$ORDER(^YTT(601.85,"AC",ADMIN,QID))
if 'QID
QUIT
Begin DoDot:1
+14 SET CTNT=$ORDER(^YTT(601.76,"AF",TST,QID,0))
+15 SET SEQ=$PIECE($GET(^YTT(601.76,+CTNT,0)),U,3)
if 'SEQ
SET SEQ=1
+16 SET TYP=+$PIECE($GET(^YTT(601.72,QID,2)),U,2)
+17 SET ANS=0
FOR
SET ANS=$ORDER(^YTT(601.85,"AC",ADMIN,QID,ANS))
if 'ANS
QUIT
Begin DoDot:2
+18 SET VAL=$PIECE(^YTT(601.85,ANS,0),U,4)
SET TOT=TOT+1
+19 ; skipped=not answered
IF VAL="NOT ASKED"!(VAL=1155)!(VAL=1157)
SET NA=NA+1
+20 ; not asked
IF VAL="NOT ASKED"
SET TMP(+SEQ)=QID_U_"null"
QUIT
+21 ; skipped values
IF VAL=1155!(VAL=1156)!(VAL=1157)
SET TYP=1
+22 ; mult choice
IF TYP=1
SET TMP(+SEQ)=QID_U_"c"_VAL
QUIT
+23 ; integer, etc.
SET VAL=$GET(^YTT(601.85,ANS,1,1,0))
+24 IF TYP'=5
IF (TYP'=11)
SET TMP(+SEQ)=QID_U_VAL
QUIT
+25 ; memo and checkbox fields
SET (N,L)=0
FOR
SET N=$ORDER(^YTT(601.85,ANS,1,N))
if 'N
QUIT
Begin DoDot:3
+26 SET VAL=$GET(^YTT(601.85,ANS,1,N,0))
+27 IF '$DATA(TMP(+SEQ))
SET TMP(+SEQ)=QID_U_$TRANSLATE(VAL,"|",$CHAR(10))
IF 1
+28 IF '$TEST
SET L=L+1
SET TMP(+SEQ,L)=$TRANSLATE(VAL,"|",$CHAR(10))
End DoDot:3
End DoDot:2
End DoDot:1
+29 NEW CATPROG
SET CATPROG=$$CHKPROG^YTQRCAT(ADMIN)
+30 IF CATPROG>-1
SET RESULTS("progress")=CATPROG
IF 1
+31 IF '$TEST
SET RESULTS("progress")=$SELECT(TOT>0:$PIECE((((TOT-NA)/TOT)*100)+.5,"."),1:0)
+32 ; now move sorted responses from TMP into "answers" nodes
+33 SET I=""
SET N=0
FOR
SET I=$ORDER(TMP(I))
if '$LENGTH(I)
QUIT
SET N=N+1
Begin DoDot:1
+34 SET RESULTS("answers",N,"id")="q"_$PIECE(TMP(I),U)
+35 SET RESULTS("answers",N,"value")=$PIECE(TMP(I),U,2,999)
+36 IF $DATA(TMP(I))>9
SET J=""
SET L=0
FOR
SET J=$ORDER(TMP(I,J))
if '$LENGTH(J)
QUIT
SET L=L+1
Begin DoDot:2
+37 SET RESULTS("answers",N,"value","\",L)=TMP(I,J)
End DoDot:2
End DoDot:1
+38 QUIT
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
GETCHKS(ARGS,RESULTS) ; verify answer string & return check messages if needed
+1 ;ARGS("q6440")="c2420" -- may be choice id
+2 ;ARGS("q6439")="08/07/2019" -- or literal
+3 SET RESULTS("count")=0
+4 IF ARGS("instrumentName")="BAM-C"
DO VERIFY^YTSBAMC(.ARGS,.RESULTS)
+5 IF ARGS("instrumentName")="BAM-R"
DO VERIFY^YTSBAMR(.ARGS,.RESULTS)
+6 IF ARGS("instrumentName")="BAM-IOP"
DO VERIFY^YTSBAMI(.ARGS,.RESULTS)
+7 IF ARGS("instrumentName")="BAM-C-CBT-SUD"
DO VERIFY^YTSBAMCC(.ARGS,.RESULTS)
+8 IF ARGS("instrumentName")="BAM-R-CSG-SUD"
DO VERIFY^YTSBAMRC(.ARGS,.RESULTS)
+9 IF ARGS("instrumentName")="BAM-IOP-CSG-SUD"
DO VERIFY^YTSBAMIC(.ARGS,.RESULTS)
+10 IF ARGS("instrumentName")="SODU"
DO VERIFY^YTSSODU(.ARGS,.RESULTS)
+11 QUIT
