- YTQRQAD2 ;SLC/KCM - RESTful Calls to set/get MHA administrations ;Oct 31, 2024@13:37:11
- ;;5.01;MENTAL HEALTH;**130,141,173,178,182,181,199,202,204,208,233,223,234,238,250**;Dec 30, 1994;Build 26
- ;
- 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,YSERR
- S ASMTID=DATA("assignmentId")
- S NODE=$S(ASMTID?36ANP:"YTQCPRS-",1:"YTQASMT-SET-")_ASMTID
- S ADMIN=+$G(DATA("adminId"))
- I '$D(^XTMP(NODE)) D QUIT 0
- . S YSERR="Unable to create admin."
- . I ADMIN,$P($G(^YTT(601.84,ADMIN,0)),U,9)="Y" S YSERR=YSERR_" Admin was already saved." I 1
- . E S YSERR=YSERR_" (Scratch assignment was missing)."
- . D SETERROR^YTQRUTL(500,YSERR)
- 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 9360 printed Feb 18, 2025@23:45:12 Page 2
- YTQRQAD2 ;SLC/KCM - RESTful Calls to set/get MHA administrations ;Oct 31, 2024@13:37:11
- +1 ;;5.01;MENTAL HEALTH;**130,141,173,178,182,181,199,202,204,208,233,223,234,238,250**;Dec 30, 1994;Build 26
- +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,YSERR
- +2 SET ASMTID=DATA("assignmentId")
- +3 SET NODE=$SELECT(ASMTID?36ANP:"YTQCPRS-",1:"YTQASMT-SET-")_ASMTID
- +4 SET ADMIN=+$GET(DATA("adminId"))
- +5 IF '$DATA(^XTMP(NODE))
- Begin DoDot:1
- +6 SET YSERR="Unable to create admin."
- +7 IF ADMIN
- IF $PIECE($GET(^YTT(601.84,ADMIN,0)),U,9)="Y"
- SET YSERR=YSERR_" Admin was already saved."
- IF 1
- +8 IF '$TEST
- SET YSERR=YSERR_" (Scratch assignment was missing)."
- +9 DO SETERROR^YTQRUTL(500,YSERR)
- End DoDot:1
- QUIT 0
- +10 ; auto-save fix
- IF 'ADMIN
- SET ADMIN=$$ADM4ASMT(NODE,DATA("instrumentId"))
- +11 ;Admin Date added so user can select previous date, time is arbitrary based on current MHA standard
- +12 SET ADMINDT=$GET(^XTMP(NODE,1,"adminDate"))
- IF ADMINDT]""
- SET ADMINDT=$$ETFM(ADMINDT)
- if ADMINDT
- SET ADMINDT=ADMINDT_"."_$PIECE($$NOW^XLFDT(),".",2)
- +13 SET YS("FILEN")=601.84
- +14 IF ADMIN
- SET YS("IEN")=ADMIN
- IF 1
- +15 IF '$TEST
- SET YS(1)=".01^NEW^1"
- +16 SET YS(2)="1^`"_$GET(^XTMP(NODE,1,"patient","dfn"))
- +17 SET YS(3)="2^`"_DATA("instrumentId")
- +18 SET YS(4)="3^"_$SELECT(ADMINDT]"":ADMINDT,1:$GET(^XTMP(NODE,1,"date")))
- +19 ;S YS(4)="3^"_$G(^XTMP(NODE,1,"date"))
- +20 SET YS(5)="4^NOW"
- +21 SET YS(6)="5^`"_$GET(^XTMP(NODE,1,"orderedBy"))
- +22 SET YS(7)="6^`"_$GET(^XTMP(NODE,1,"interview"))
- +23 SET YS(8)="7^N"
- +24 SET YS(9)="8^"_$SELECT(DATA("complete")="true":"YES",1:"NO")
- +25 SET YS(10)="9^"_NUM
- +26 SET YS(11)="13^`"_$GET(^XTMP(NODE,1,"location"))
- +27 IF '$LENGTH($GET(DATA("source")))
- SET DATA("source")="web"
- +28 SET YS(12)="15^"_DATA("source")
- +29 IF $DATA(^XTMP(NODE,1,"consult"))
- IF ($GET(^XTMP(NODE,1,"consult"))]"")
- SET YS(13)="17^"_^XTMP(NODE,1,"consult")
- +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 ;
- 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