Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQRQAD2

YTQRQAD2.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. SAVEADM(ARGS,DATA) ; save answers and return /ys/mha/admin/{adminId}
  1. I $G(DATA("assignmentId"))?36ANP G POSTADM^YTQRCRW
  1. N ADMIN
  1. S ADMIN=$$QASAVE(.DATA) QUIT:'ADMIN "" ; create admin & answer records
  1. ;
  1. ; create a note if this was patient-entered
  1. N ASMT,CPLT,PTENT,LSTASMT,PNOT,AGPROG,TMPYS
  1. S ASMT=DATA("assignmentId")
  1. S LSTASMT=$G(DATA("lastAssignment"))
  1. S CPLT=$S(DATA("complete")="true":"Y",1:"N")
  1. S PTENT=($G(^XTMP("YTQASMT-SET-"_ASMT,1,"entryMode"))="patient")
  1. I (CPLT="Y"),PTENT,(LSTASMT'="Yes") D NOTE4PT^YTQRQAD3(ADMIN,.DATA)
  1. ;
  1. ; update the assignment with adminId, remove completed admins/assignments
  1. N I,NOD,REMAIN
  1. S NOD="YTQASMT-SET-"_ASMT,REMAIN=0
  1. S I=0 F S I=$O(^XTMP(NOD,1,"instruments",I)) Q:'I D
  1. . I ^XTMP(NOD,1,"instruments",I,"id")=DATA("instrumentId") D QUIT
  1. . . ; remove instrument if complete and staff-entered
  1. . . I 'PTENT,(CPLT="Y") K ^XTMP(NOD,1,"instruments",I) QUIT
  1. . . ;I CPLT="Y" K ^XTMP(NOD,1,"instruments",I) QUIT ; patient-entered (may need to keep)
  1. . . S ^XTMP(NOD,1,"instruments",I,"adminId")=ADMIN
  1. . . S ^XTMP(NOD,1,"instruments",I,"complete")=DATA("complete")
  1. . . I CPLT'="Y" S REMAIN=1
  1. . I $G(^XTMP(NOD,1,"instruments",I,"complete"))'="true" S REMAIN=1
  1. I PTENT,(LSTASMT="Yes"),(CPLT="Y") D
  1. . I $$ALWNOTE^YTQRQAD3(ADMIN)="true" D BLDRPT^YTQRRPT(.TMPYS,ADMIN,79)
  1. . D SPLTADM^YTQRCAT(ADMIN) ; separate out the admins if CAT
  1. S AGPROG=$D(^XTMP(NOD,2))
  1. ;I LSTASMT="Yes",AGPROG S PNOT=$$FILPNOT^YTQRQAD8(ASMT,"","","",.TMPYS)
  1. ;Last instrument=Yes and either saved aggregate progress note or TMPYS from current PE instrument.
  1. I LSTASMT="Yes",(AGPROG!$D(TMPYS)) S PNOT=$$FILPNOT^YTQRQAD8(ASMT,ADMIN,"","",.TMPYS)
  1. ;Check for consolidated progress note node 2. If exists, ASMT deleted in YTQRQAD8
  1. I 'REMAIN,'$D(^XTMP(NOD,2)),$D(^XTMP(NOD,0)) D DELASMT1^YTQRQAD1(ASMT)
  1. Q "/api/mha/instrument/admin/"_ADMIN ; was erroneously /ys/mha/admin/
  1. ;
  1. QASAVE(DATA) ; save questions and answers in DATA
  1. ; loop through DATA to create ANS array, then YSDATA array
  1. ; ANS(#)=questionId^choiceId <-- radio group question
  1. ; ANS(#,#)=wp value <-- all others
  1. N I,QNUM,QANS,QID,VAL,ANS,RT1,ADMIN
  1. S QNUM=0,QANS=0
  1. S I=0 F S I=$O(DATA("answers",I)) Q:'I D
  1. . S QID=DATA("answers",I,"id")
  1. . S VAL=DATA("answers",I,"value")
  1. . QUIT:$E(QID)'="q" ; skip intros, sections
  1. . S QNUM=QNUM+1 ; QNUM is sequence w/o intros
  1. . S QID=$E(QID,2,999) ; remove the "q"
  1. . I VAL="null" S ANS(QNUM)=QID_U_"NOT ASKED" QUIT
  1. . ; QANS is number answered, don't include skipped (1155 or 1157)
  1. . I '((VAL="c1155")!(VAL="c1157")) S QANS=QANS+1
  1. . S RT1=0 ; response type 1 is choice question
  1. . I VAL="c1155"!(VAL="c1156")!(VAL="c1157") S RT1=1
  1. . I $P($G(^YTT(601.72,QID,2)),U,2)=1 S RT1=1
  1. . I RT1 S ANS(QNUM)=QID_U_$E(VAL,2,999) QUIT
  1. . S ANS(QNUM)=QID D TXT2ANS(I,QNUM) ; handle longer WP values
  1. K DATA("answers") ; now in ANS array (which may be large)
  1. ; save admin itself
  1. S ADMIN=$$SETADM(.DATA,QANS)
  1. Q:'ADMIN ""
  1. ; save the answers
  1. N YSDATA
  1. S ANS("AD")=ADMIN
  1. D SAVEALL^YTQAPI17(.YSDATA,.ANS)
  1. I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Answers not saved") Q ""
  1. Q ADMIN
  1. ;
  1. SETADM(DATA,NUM) ; return the id for new/updated admin
  1. N YSDATA,YS,NODE,ADMIN,ADMINDT,ASMTID,YSERR
  1. S ASMTID=DATA("assignmentId")
  1. S NODE=$S(ASMTID?36ANP:"YTQCPRS-",1:"YTQASMT-SET-")_ASMTID
  1. S ADMIN=+$G(DATA("adminId"))
  1. I '$D(^XTMP(NODE)) D QUIT 0
  1. . S YSERR="Unable to create admin."
  1. . I ADMIN,$P($G(^YTT(601.84,ADMIN,0)),U,9)="Y" S YSERR=YSERR_" Admin was already saved." I 1
  1. . E S YSERR=YSERR_" (Scratch assignment was missing)."
  1. . D SETERROR^YTQRUTL(500,YSERR)
  1. I 'ADMIN S ADMIN=$$ADM4ASMT(NODE,DATA("instrumentId")) ; auto-save fix
  1. ;Admin Date added so user can select previous date, time is arbitrary based on current MHA standard
  1. S ADMINDT=$G(^XTMP(NODE,1,"adminDate")) I ADMINDT]"" S ADMINDT=$$ETFM(ADMINDT) S:ADMINDT ADMINDT=ADMINDT_"."_$P($$NOW^XLFDT(),".",2)
  1. S YS("FILEN")=601.84
  1. I ADMIN S YS("IEN")=ADMIN I 1
  1. E S YS(1)=".01^NEW^1"
  1. S YS(2)="1^`"_$G(^XTMP(NODE,1,"patient","dfn"))
  1. S YS(3)="2^`"_DATA("instrumentId")
  1. S YS(4)="3^"_$S(ADMINDT]"":ADMINDT,1:$G(^XTMP(NODE,1,"date")))
  1. ;S YS(4)="3^"_$G(^XTMP(NODE,1,"date"))
  1. S YS(5)="4^NOW"
  1. S YS(6)="5^`"_$G(^XTMP(NODE,1,"orderedBy"))
  1. S YS(7)="6^`"_$G(^XTMP(NODE,1,"interview"))
  1. S YS(8)="7^N"
  1. S YS(9)="8^"_$S(DATA("complete")="true":"YES",1:"NO")
  1. S YS(10)="9^"_NUM
  1. S YS(11)="13^`"_$G(^XTMP(NODE,1,"location"))
  1. I '$L($G(DATA("source"))) S DATA("source")="web"
  1. S YS(12)="15^"_DATA("source")
  1. I $D(^XTMP(NODE,1,"consult")),($G(^XTMP(NODE,1,"consult"))]"") S YS(13)="17^"_^XTMP(NODE,1,"consult")
  1. D ADMSAVE^YTQAPI1(.YSDATA,.YS)
  1. I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Unable to create admin") Q 0
  1. I 'ADMIN Q $P(YSDATA(2),U,2) ; create new admin, ien found in 2nd piece
  1. Q ADMIN ; otherwise we're updating existing admin
  1. ;
  1. ETFM(YSDT) ;External to FM
  1. ;YSDT = DATE in external
  1. N X,Y
  1. I YSDT["@" S YSDT=$P(YSDT,"@")
  1. S X=YSDT D ^%DT
  1. I Y<0 S Y="" ;Invalid YSDT
  1. Q Y
  1. ADM4ASMT(NODE,TESTID) ; return adminId if one has been saved for assignment
  1. N I,CURADM
  1. S CURADM=0
  1. S I=0 F S I=$O(^XTMP(NODE,1,"instruments",I)) Q:'I D Q:CURADM
  1. . I $G(^XTMP(NODE,1,"instruments",I,"id"))'=TESTID Q
  1. . I $G(^XTMP(NODE,1,"instruments",I,"adminId"))>0 S CURADM=^XTMP(NODE,1,"instruments",I,"adminId")
  1. I $L(CURADM,"-")>0 S CURADM=0 ; only "real" admins, not UUID's
  1. Q CURADM
  1. ;
  1. GETADM(ARGS,RESULTS) ; get answers for administration identified by ARGS("adminId")
  1. I '$L($G(ARGS("adminId"))) D SETERROR^YTQRUTL(404,"Missing admin parameter") Q
  1. I ARGS("adminId")?36ANP1"-".N G GETADM^YTQRCRW
  1. I $D(^YTT(601.84,ARGS("adminId")))<10 D Q
  1. . D SETERROR^YTQRUTL(404,"Admin not found: "_ARGS("adminId"))
  1. ;
  1. N ADMIN,X0,TST,QID,ANS,CTNT,SEQ,TYP,VAL,TOT,NA,TMP,I,J,N,L
  1. S ADMIN=ARGS("adminId"),X0=^YTT(601.84,ADMIN,0),TST=$P(X0,U,3)
  1. S RESULTS("adminId")=ADMIN
  1. S RESULTS("complete")=$S($P(X0,U,9)="Y":"true",1:"false")
  1. S RESULTS("instrumentId")=TST
  1. ; iterate through answers to get values and sort by sequence
  1. S (TOT,NA)=0 ; total questions & not answered count
  1. S QID=0 F S QID=$O(^YTT(601.85,"AC",ADMIN,QID)) Q:'QID D
  1. . S CTNT=$O(^YTT(601.76,"AF",TST,QID,0))
  1. . S SEQ=$P($G(^YTT(601.76,+CTNT,0)),U,3) S:'SEQ SEQ=1
  1. . S TYP=+$P($G(^YTT(601.72,QID,2)),U,2)
  1. . S ANS=0 F S ANS=$O(^YTT(601.85,"AC",ADMIN,QID,ANS)) Q:'ANS D
  1. . . S VAL=$P(^YTT(601.85,ANS,0),U,4),TOT=TOT+1
  1. . . I VAL="NOT ASKED"!(VAL=1155)!(VAL=1157) S NA=NA+1 ; skipped=not answered
  1. . . I VAL="NOT ASKED" S TMP(+SEQ)=QID_U_"null" QUIT ; not asked
  1. . . I VAL=1155!(VAL=1156)!(VAL=1157) S TYP=1 ; skipped values
  1. . . I TYP=1 S TMP(+SEQ)=QID_U_"c"_VAL QUIT ; mult choice
  1. . . S VAL=$G(^YTT(601.85,ANS,1,1,0)) ; integer, etc.
  1. . . I TYP'=5,(TYP'=11) S TMP(+SEQ)=QID_U_VAL QUIT
  1. . . S (N,L)=0 F S N=$O(^YTT(601.85,ANS,1,N)) Q:'N D ; memo and checkbox fields
  1. . . . S VAL=$G(^YTT(601.85,ANS,1,N,0))
  1. . . . I '$D(TMP(+SEQ)) S TMP(+SEQ)=QID_U_$TR(VAL,"|",$C(10)) I 1
  1. . . . E S L=L+1,TMP(+SEQ,L)=$TR(VAL,"|",$C(10))
  1. N CATPROG S CATPROG=$$CHKPROG^YTQRCAT(ADMIN)
  1. I CATPROG>-1 S RESULTS("progress")=CATPROG I 1
  1. E S RESULTS("progress")=$S(TOT>0:$P((((TOT-NA)/TOT)*100)+.5,"."),1:0)
  1. ; now move sorted responses from TMP into "answers" nodes
  1. S I="",N=0 F S I=$O(TMP(I)) Q:'$L(I) S N=N+1 D
  1. . S RESULTS("answers",N,"id")="q"_$P(TMP(I),U)
  1. . S RESULTS("answers",N,"value")=$P(TMP(I),U,2,999)
  1. . I $D(TMP(I))>9 S J="",L=0 F S J=$O(TMP(I,J)) Q:'$L(J) S L=L+1 D
  1. . . S RESULTS("answers",N,"value","\",L)=TMP(I,J)
  1. Q
  1. TXT2ANS(IDX,QNUM) ; Convert web to ANS format for DATA(IDX)
  1. ; expects DATA,ANS
  1. N LEN,LN,NODE,J
  1. S LEN=240,LN=0
  1. S NODE=DATA("answers",IDX,"value")
  1. D ADDSEGS(NODE)
  1. I $D(DATA("answers",IDX,"value","\")) D
  1. . F J=1:1 Q:'$D(DATA("answers",IDX,"value","\",J)) D
  1. . . S NODE=DATA("answers",IDX,"value","\",J)
  1. . . D ADDSEGS(NODE)
  1. Q
  1. ADDSEGS(NODE) ; split text in node into LEN segments with "|" for newlines
  1. ; expects DATA,ANS,LEN,LN
  1. N I,X,END,FIRST,LAST
  1. S END=$L(NODE),LAST=0 F I=0:1 D Q:LAST>END ; iterate thru each segment
  1. . S FIRST=(I*LEN)+1,LAST=(I*LEN)+LEN,LN=LN+1 ; set first&last char positions
  1. . S X=$TR($E(NODE,FIRST,LAST),$C(10),"|") ; set segment, chg newline to |
  1. . S ANS(QNUM,LN)=X
  1. Q
  1. GETCHKS(ARGS,RESULTS) ; verify answer string & return check messages if needed
  1. ;ARGS("q6440")="c2420" -- may be choice id
  1. ;ARGS("q6439")="08/07/2019" -- or literal
  1. S RESULTS("count")=0
  1. I ARGS("instrumentName")="BAM-C" D VERIFY^YTSBAMC(.ARGS,.RESULTS)
  1. I ARGS("instrumentName")="BAM-R" D VERIFY^YTSBAMR(.ARGS,.RESULTS)
  1. I ARGS("instrumentName")="BAM-IOP" D VERIFY^YTSBAMI(.ARGS,.RESULTS)
  1. I ARGS("instrumentName")="BAM-C-CBT-SUD" D VERIFY^YTSBAMCC(.ARGS,.RESULTS)
  1. I ARGS("instrumentName")="BAM-R-CSG-SUD" D VERIFY^YTSBAMRC(.ARGS,.RESULTS)
  1. I ARGS("instrumentName")="BAM-IOP-CSG-SUD" D VERIFY^YTSBAMIC(.ARGS,.RESULTS)
  1. I ARGS("instrumentName")="SODU" D VERIFY^YTSSODU(.ARGS,.RESULTS)
  1. Q