YTQRQAD3 ;SLC/KCM - RESTful Calls to set/get MHA administrations ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,141,158,178,182,181,187,199,207,202,204,208,221,238,239**;Dec 30, 1994;Build 16
;
; Reference to ^VA(200) in ICR #10060
; Reference to DIQ in ICR #2056
; Reference to TIUCNSLT in ICR #5546
; Reference to TIUPUTU in ICR #3351
; Reference to TIUSRVA in ICR #5541
; Reference to XLFSTR in ICR #10104
;
REPORT(ARGS,RESULTS) ; build report object identified by ARGS("adminId")
N ADMIN S ADMIN=+$G(ARGS("adminId"))
I '$D(^YTT(601.84,ADMIN,0)) D SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN) QUIT
S RESULTS("adminId")=ADMIN
D REPORT1(ADMIN,.RESULTS)
Q
REPORT1(ADMIN,REPORT,TYPE) ; fill in the report text for ADMIN
N I,REPORT,COMMS,II,CRLF,BCNT,BARR
N RM
N TSTNM,YS,YSDATA,RPRIV
S RM=79
I $G(TYPE)'="NOTE" S RM=512
S CRLF=$C(10)
S RPRIV=1
I $G(TYPE)'="NOTE" D
. K YSDATA
. S TSTNM=$P($G(^YTT(601.71,$P(^YTT(601.84,ADMIN,0),U,3),0)),U)
. S YS("CODE")=TSTNM D PRIVL^YTAPI5(.YSDATA,.YS)
. I $G(YSDATA(1))["[DATA]" I $P($G(YSDATA(2)),U)=0 S RPRIV=0
I RPRIV=0 S RESULTS("text","\",1)="This is a restricted report" Q
D BLDRPT^YTQRRPT(.REPORT,ADMIN,RM)
S BCNT=0 K BARR
S I=0 F S I=$O(REPORT(I)) Q:+I=0 D
. I $TR(REPORT(I)," ")'="" D Q
.. S BCNT=0
. S BCNT=BCNT+1
. I BCNT>2 S BARR(I)=""
I $D(BARR) D
. S I="" F S I=$O(BARR(I)) Q:I="" D
.. K REPORT(I)
S RESULTS("text")=$G(REPORT(1))_CRLF
D WRAPTLT^YTQRRPT(.REPORT,RM) ;Added existing call so web Note display matches CPRS - WYSIWYG
S I=1 F S I=$O(REPORT(I)) Q:'I S RESULTS("text","\",I-1)=REPORT(I)_CRLF
D GETCOM(.COMMS,ADMIN)
I $G(TYPE)'="NOTE",$D(COMMS) D
. S I=$O(RESULTS("text","\",""),-1) I I="" S I=0
. S I=I+1,RESULTS("text","\",I)="---Comments----------------------------------------------------------------"_CRLF ;Add separator
. S II="" F S II=$O(COMMS(II)) Q:II="" D
.. S I=I+1,RESULTS("text","\",I)=COMMS(II)_CRLF
Q
GETCOM(ARR,ADMIN) ;Get the COMMENTS from the Instrument Admin
N WPARR,TMPAR,DELIM,YSIEN,II,JJ,CNT,STR,WRD
S YSIEN=ADMIN_","
S II=$$GET1^DIQ(601.84,YSIEN,10,,"WPARR")
Q:II=""
S CNT=0,STR=""
S II=0 F S II=$O(WPARR(II)) Q:II="" D ;Break up and put back together text by ~
. I WPARR(II)'["~" S STR=STR_WPARR(II) Q
. S STR=STR_$P(WPARR(II),"~"),CNT=CNT+1,TMPAR(CNT)=STR
. F JJ=2:1:$L(WPARR(II),"~")-1 D
.. S CNT=CNT+1,TMPAR(CNT)=$P(WPARR(II),"~",JJ)
. S STR=$P(WPARR(II),"~",$L(WPARR(II),"~"))
I STR]"" S CNT=CNT+1,TMPAR(CNT)=STR
I TMPAR(CNT)="" K TMPAR(CNT) ;remove trailing blank line if null
M ARR=TMPAR
Q
GETNOTE(ARGS,RESULTS) ; build note object based on ARGS("adminId")
N ADMIN S ADMIN=$G(ARGS("adminId"))
I ADMIN="" D SETERROR^YTQRUTL(404,"Admin not sent: "_ADMIN) QUIT
I '$D(^YTT(601.84,ADMIN,0)) D SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN) QUIT
N CONSULT S CONSULT=$P(^YTT(601.84,ADMIN,0),U,15)
S RESULTS("adminId")=ADMIN
S RESULTS("consultId")=$S(+CONSULT:CONSULT,1:"null")
S RESULTS("allowNote")=$$ALWNOTE(ADMIN)
S RESULTS("requireCosigner")=$$REQCSGN(ADMIN)
S RESULTS("cosigner")="null"
I RESULTS("allowNote")="true" D REPORT1(ADMIN,.RESULTS,"NOTE") I 1
E S RESULTS("text")="null"
D SPLTADM^YTQRCAT(ADMIN) ; separate out the admins if CAT
Q
SETNOTE(ARGS,DATA) ; save note in DATA("text") using ARGS("adminId")
;Expects DATA to be in the format returned from BLDRPT^YTQRRPT - The RPC most likely does not do that.
N YS,YSDATA,ADMIN,CONSULT,WRP,ASGN,LSTASGN,PNOT,AGPROG
S ADMIN=$G(DATA("adminId"))
S LSTASGN=$G(DATA("lastAssignment"))
S ASGN=$G(DATA("assignmentId"))
S AGPROG=$D(^XTMP("YTQASMT-SET-"_ASGN,2))
I ADMIN="" D SETERROR^YTQRUTL(404,"Admin not sent: "_ADMIN) QUIT ""
I '$D(^YTT(601.84,ADMIN,0)) D SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN) QUIT ""
S CONSULT=$P(^YTT(601.84,ADMIN,0),U,15)
S PNOT=0
I $$ALWNOTE(ADMIN)'="true" D QUIT "/api/mha/instrument/note/"_PNOT
. ;This is Restricted Instrument, check if lastAssignment=Yes and there is something in the aggregate progress note.
. I +ASGN'=0,(LSTASGN="Yes"),AGPROG S PNOT=$$FILPNOT^YTQRQAD8(ASGN,ADMIN,CONSULT,.DATA,.YS)
I '$D(^YTT(601.84,ADMIN,0)) D SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN) QUIT ""
D TXT2LN(.DATA,.YS) ; parse by CRLF and set YS(#) to note text
D WRAP(.YS,79) ;reformat lines to 79 max chars
S YS("AD")=ADMIN
;D WRAPTLT^YTQRRPT(.YS,79) ;Reformat lines in case user edited progress note
I +$G(DATA("cosigner")) D I $G(YTQRERRS) QUIT "/api/mha/instrument/note/0"
. N YSCSGN S YSCSGN=DATA("cosigner")
. S YS("COSIGNER")=YSCSGN
. I $$REQCSGN(ADMIN,YSCSGN)="true" D ; cosigner can't require cosigner
. . S YSCSGN=$$GET1^DIQ(200,YSCSGN_",",.01)
. . D SETERROR^YTQRUTL(403,YSCSGN_" not allowed to cosign.")
;assignmentID sent in, lastAssignment=Yes/No, $D of aggregate Progress Note
I +ASGN'=0,(LSTASGN'="Yes") D SAVPNOT^YTQRQAD8(ASGN,ADMIN,CONSULT,$G(DATA("cosigner")),.YS) Q "/api/mha/instrument/note/1" ;Dummy 1 instead of Note IEN
I +ASGN'=0,(LSTASGN="Yes"),AGPROG S PNOT=$$FILPNOT^YTQRQAD8(ASGN,ADMIN,CONSULT,.DATA,.YS) Q "/api/mha/instrument/note/"_PNOT
;Either assignmentId not sent (older version of GUI) or single instrument=no aggregate progress note, file individual instrument progress note
I CONSULT S YS("CON")=CONSULT D CCREATE^YTQCONS(.YSDATA,.YS) I 1
E D PCREATE^YTQTIU(.YSDATA,.YS)
I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Note not saved") Q ""
Q "/api/mha/instrument/note/"_$G(YSDATA(2))
;
ALWNOTE(ADMIN) ; return "true" if note could/should be saved
N TEST
S TEST=$P(^YTT(601.84,ADMIN,0),U,3) Q:'TEST "false" ; missing test
Q $$ALWN2(TEST,ADMIN)
;
ALWN2(TEST,ADMIN) ;Entry point if TEST is input
;ADMIN - If specific ADMIN is to be checked
N TITLE,CONSULT,Y,YSISC,YSTITLE
N YSLEG,YSCODE,YSET,YSLEGP
S ADMIN=+$G(ADMIN)
;Look at test definition first
I $L($P($G(^YTT(601.71,TEST,2)),U)) Q "false" ; R PRIVILEGE
I $P($G(^YTT(601.71,TEST,8)),U,8)'="Y" Q "false" ; gen note
;S YSLEGP="" ;Handle Legacy Instruments - ref YTAPI5
;S YSLEG=$P($G(^YTT(601.71,TEST,8)),U,3)
;I YSLEG="Y" D
;. S YSCODE=$P(^YTT(601.71,TEST,0),U)
;. S YSET=$O(^YTT(601,"B",YSCODE,""))
;. I $P(^YTT(601,YSET,0),U,10)="Y"!(YSCODE="GAF")!(YSCODE="ASI") S YSLEGP="true" Q
;. I $P(^YTT(601,YSET,0),U,9)="I" S YSLEGP="true" Q
;. S YSLEGP="false3"
;I +ADMIN=0,(YSLEGP]"") Q YSLEGP ;No ADMIN ID, just look at test definition.
S CONSULT=""
I ADMIN'=0 S CONSULT=$P(^YTT(601.84,ADMIN,0),U,15)
I CONSULT D I 1
. S YSTITLE=$$GET1^DIQ(601.71,TEST_",",30,"E")
. S Y=$$WHATITLE^TIUPUTU(YSTITLE)
. D ISCNSLT^TIUCNSLT(.YSISC,+Y)
. I 'YSISC S YSTITLE="MHA CONSULT"
E S YSTITLE=$$GET1^DIQ(601.71,TEST_",",29,"E")
I $$WHATITLE^TIUPUTU(YSTITLE)'>0 Q "false" ; bad note title
Q "true"
;
NOTE4PT(ADMIN,DATA) ; save progress note text in assignment for a patient-entered admin
N CONSULT,YS,YSDATA,COSIGNER,ASMT,LSTASMT
D BLDRPT^YTQRRPT(.YS,ADMIN,79)
I $$ALWNOTE(ADMIN)'="true" QUIT
S COSIGNER=$G(DATA("cosigner"))
S CONSULT=$G(DATA("consult")) I CONSULT="" S CONSULT=$P(^YTT(601.84,ADMIN,0),U,15)
S ASMT=+$G(DATA("assignmentId"))
S LSTASMT=$G(DATA("lastAssignment"))
D SPLTADM^YTQRCAT(ADMIN) ; separate out the admins if CAT
;S CONSULT=$P(^YTT(601.84,ADMIN,0),U,15)
S YS("AD")=ADMIN
S:COSIGNER]"" YS("COSIGNER")=COSIGNER
;Entry predicated on LSTASMT'=Yes. Therefore=No if updated PE, null if old PE.
;If LSTASMT=null, file progress note immediately
I ASMT'=0,(LSTASMT="No") D SAVPNOT^YTQRQAD8(ASMT,ADMIN,CONSULT,COSIGNER,.YS) Q ;Save in aggregate progress note XTMP instead
; If ASMT=0, file directly for backwards compatibility
I CONSULT S YS("CON")=CONSULT D CCREATE^YTQCONS(.YSDATA,.YS) I 1
E D PCREATE^YTQTIU(.YSDATA,.YS)
I YSDATA(1)'="[DATA]" D SETERROR^YTQRUTL(500,"Note not saved") Q
Q
ALWCSGN(ARGS,RESULTS) ; GET /api/mha/permission/cosign/:adminId/:userId
N ADMIN,COSIGNER,NEEDCSGN
S ADMIN=$G(ARGS("adminId"))
S COSIGNER=$G(ARGS("userId"))
S NEEDCSGN=$$REQCSGN(ADMIN,COSIGNER)
S RESULTS("userId")=COSIGNER
S RESULTS("allowedToCosign")=$S(NEEDCSGN="true":"false",1:"true")
Q
REQCSGN(ADMIN,COSIGNER) ; return "true" if this user requires a cosigner
; if cosigner is passed in, use that instead of orderedBy
N TEST,YSCREQ,YSTITLE,YSPERSON,X0
S X0=$G(^YTT(601.84,ADMIN,0))
S YSPERSON=$G(COSIGNER,$P(X0,U,6)) ; either cosigner or orderedBy
S TEST=$P(X0,U,3),CONSULT=$P(X0,U,15)
; TODO: account for the MHA CONSULT title
S YSTITLE=$S(CONSULT:$P($G(^YTT(601.71,TEST,8)),U,10),1:$P($G(^YTT(601.71,TEST,8)),U,9))
D REQCOS^TIUSRVA(.YSCREQ,YSTITLE,"",YSPERSON,"")
Q $S(YSCREQ:"true",1:"false")
;
NEEDCSGN(ARGS,RESULTS) ; GET /api/mha/permission/needcosign/:userId 208
; Returns "true" if userId requires a cosigner
; Returns "false" if userId does NOT require a cosigner
N YSPERSON,YSTITLE,YSCREQ,INSTS,TEST,II,CONSULT,YSCREQ,CSLIST,INAM,CFLG
S INSTS=$G(ARGS("instrumentList"))
S:INSTS="" INSTS=$G(ARGS("instrumentlist")) ;If query param, xlated to lower
S YSPERSON=$G(ARGS("userId"))
S CFLG="false"
I INSTS="" D Q
. S YSTITLE=$$TITLE^YTQRQAD7()
. D REQCOS^TIUSRVA(.YSCREQ,YSTITLE,"",YSPERSON,"")
. S RESULTS("userId")=YSPERSON
. S RESULTS("needCosigner")=$S(YSCREQ:"true",1:"false")
. S RESULTS("allowNote")="" ;Unknown without instrument list
. Q
;I INSTS="" D SETERROR^YTQRUTL(404,"Instrument List not sent. ") QUIT
S CONSULT=$S($G(ARGS("consult"))]"":1,1:"")
S CFLG="false"
F II=1:1:$L(INSTS,",") D
. S INAM=$P(INSTS,",",II) Q:INAM=""
. S TEST=$O(^YTT(601.71,"B",INAM,"")) Q:+TEST=0
. S YSTITLE=$S(CONSULT:$P($G(^YTT(601.71,TEST,8)),U,10),1:$P($G(^YTT(601.71,TEST,8)),U,9))
. Q:YSTITLE=""
. K YSCREQ
. D REQCOS^TIUSRVA(.YSCREQ,YSTITLE,"",YSPERSON,"")
. S CSLIST=$S($G(YSCREQ)=1:"true",1:"false")
. I CSLIST="true" S CFLG="true"
. S RESULTS("instrumentList",II,"instName")=INAM
. S RESULTS("instrumentList",II,"needCosign")=CSLIST
. S RESULTS("instrumentList",II,"allowNote")=$$ALWN2(TEST)
Q
;
SETCOM(ARGS,DATA) ; save comment in Instrument Admin (F601.84,f10) using ARGS("adminId")
;Expects DATA to contain individual lines of text for the comment. Need to retrieve existing and prepend new lines
N YS,YSDATA,ADMIN,CONSULT,WRP
N YSIEN,YSF,YSERR,N,YSFILEN,YSWP,STR,II,CNT,YSNOW,YST
K ^TMP("YSMHI",$J)
S ADMIN=$G(DATA("adminId"))
I ADMIN="" D SETERROR^YTQRUTL(404,"Admin not sent: "_ADMIN) QUIT ""
I '$D(^YTT(601.84,ADMIN,0)) D SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN) QUIT ""
D TXT2LN(.DATA,.YS) ; parse by CRLF and set YS(#) to note text
D WRAP(.YS,79) ;reformat lines to 79 max chars
S YSNOW=$$HTE^XLFDT($H,"5ZP"),YSNOW=$$UP^XLFSTR(YSNOW)
S YST="0"_$P(YSNOW," ",2,99),YST=$E(YST,$L(YST)-11,$L(YST)),YSNOW=$P(YSNOW," ")_" "_YST
S N=0 F S N=$O(YS(N)) Q:N="" D
. S YS(N)=YS(N)_"~"
S STR="*** Comment Entered By: "_$P($G(^VA(200,DUZ,0)),U)_" Comment Date: "_YSNOW_"~~",CNT=0
S N=0 F S N=$O(YS(N)) Q:N="" D
. F II=1:1:$L(YS(N)) D
.. S STR=STR_$E(YS(N),II) I $L(STR)>198 S CNT=CNT+1,^TMP("YSMHI",$J,CNT)=STR,STR=""
I STR]"" S CNT=CNT+1,^TMP("YSMHI",$J,CNT)=STR
S YSIEN=ADMIN_","
S YSFILEN=601.84
S YSF=10
;==GET EXISTING COMMENT TEXT==
D GET1^DIQ(YSFILEN,YSIEN,YSF,,"YSWP","YSERR")
I '$D(YSERR) D
. S N=0 F S N=$O(YSWP(N)) Q:N="" D
.. S CNT=CNT+1,^TMP("YSMHI",$J,CNT)=YSWP(N)
D WP^DIE(YSFILEN,YSIEN,YSF,,"^TMP(""YSMHI"",$J)","YSERR")
K ^TMP("YSMHI",$J)
I $D(YSERR) D SETERROR^YTQRUTL(500,"Comment not saved") Q "/api/mha/instrument/comment/Error saving comment" Q
Q "/api/mha/instrument/comment/OK"
;
TXT2LN(SRC,DEST) ; Move CRLF delimited text from .SRC into WP lines in .DEST
N IDEST,CRLF,REMAIN
S IDEST=0,CRLF=$C(10)
S REMAIN=$$PARSLN(SRC("text"))
I '$D(SRC("text","\",1)),$L(REMAIN) D QUIT ; done since no continue nodes
. S IDEST=IDEST+1,DEST(IDEST)=REMAIN
N J ; handle continue nodes
S J=0 F S J=$O(SRC("text","\",J)) Q:'J D
. S REMAIN=$$PARSLN(REMAIN_SRC("text","\",J))
I $L(REMAIN) S IDEST=IDEST+1,DEST(IDEST)=REMAIN
Q
PARSLN(TXT) ; Return remainder after parsing text into lines
; expects: CRLF, DEST, IDEST
N X S X=TXT
I '$L(X) Q ""
; Break lines by CRLF. Depending on source line delim could be $c(13) or $c(13,10). CRLF=$c(10) so $TR $c(13) in case it is embedded
F S IDEST=IDEST+1,DEST(IDEST)=$P(X,CRLF),X=$P(X,CRLF,2,99999),DEST(IDEST)=$TR(DEST(IDEST),$C(13)) Q:X'[CRLF
Q $TR(X,$C(13))
WRAP(OUT,MAX) ; Wrap text by space piece word MAX char width
N TMP,STR,II,JJ,PCE,CNT
I +$G(MAX)=0 S MAX=79
M TMP=OUT Q:'$D(TMP)
K OUT
S (CNT,II)=0 F S II=$O(TMP(II)) Q:II="" D
. S STR="" F JJ=1:1:$L(TMP(II)," ") D
.. S PCE=$P(TMP(II)," ",JJ)
.. I $L(STR_PCE_" ")>MAX D Q
... S CNT=CNT+1,OUT(CNT)=$E(STR,1,$L(STR)-1),STR=PCE_" "
.. S STR=STR_PCE_" "
. I STR]"" S CNT=CNT+1,OUT(CNT)=$E(STR,1,$L(STR)-1)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRQAD3 13007 printed Apr 09, 2024@21:24:55 Page 2
YTQRQAD3 ;SLC/KCM - RESTful Calls to set/get MHA administrations ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,141,158,178,182,181,187,199,207,202,204,208,221,238,239**;Dec 30, 1994;Build 16
+2 ;
+3 ; Reference to ^VA(200) in ICR #10060
+4 ; Reference to DIQ in ICR #2056
+5 ; Reference to TIUCNSLT in ICR #5546
+6 ; Reference to TIUPUTU in ICR #3351
+7 ; Reference to TIUSRVA in ICR #5541
+8 ; Reference to XLFSTR in ICR #10104
+9 ;
REPORT(ARGS,RESULTS) ; build report object identified by ARGS("adminId")
+1 NEW ADMIN
SET ADMIN=+$GET(ARGS("adminId"))
+2 IF '$DATA(^YTT(601.84,ADMIN,0))
DO SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN)
QUIT
+3 SET RESULTS("adminId")=ADMIN
+4 DO REPORT1(ADMIN,.RESULTS)
+5 QUIT
REPORT1(ADMIN,REPORT,TYPE) ; fill in the report text for ADMIN
+1 NEW I,REPORT,COMMS,II,CRLF,BCNT,BARR
+2 NEW RM
+3 NEW TSTNM,YS,YSDATA,RPRIV
+4 SET RM=79
+5 IF $GET(TYPE)'="NOTE"
SET RM=512
+6 SET CRLF=$CHAR(10)
+7 SET RPRIV=1
+8 IF $GET(TYPE)'="NOTE"
Begin DoDot:1
+9 KILL YSDATA
+10 SET TSTNM=$PIECE($GET(^YTT(601.71,$PIECE(^YTT(601.84,ADMIN,0),U,3),0)),U)
+11 SET YS("CODE")=TSTNM
DO PRIVL^YTAPI5(.YSDATA,.YS)
+12 IF $GET(YSDATA(1))["[DATA]"
IF $PIECE($GET(YSDATA(2)),U)=0
SET RPRIV=0
End DoDot:1
+13 IF RPRIV=0
SET RESULTS("text","\",1)="This is a restricted report"
QUIT
+14 DO BLDRPT^YTQRRPT(.REPORT,ADMIN,RM)
+15 SET BCNT=0
KILL BARR
+16 SET I=0
FOR
SET I=$ORDER(REPORT(I))
if +I=0
QUIT
Begin DoDot:1
+17 IF $TRANSLATE(REPORT(I)," ")'=""
Begin DoDot:2
+18 SET BCNT=0
End DoDot:2
QUIT
+19 SET BCNT=BCNT+1
+20 IF BCNT>2
SET BARR(I)=""
End DoDot:1
+21 IF $DATA(BARR)
Begin DoDot:1
+22 SET I=""
FOR
SET I=$ORDER(BARR(I))
if I=""
QUIT
Begin DoDot:2
+23 KILL REPORT(I)
End DoDot:2
End DoDot:1
+24 SET RESULTS("text")=$GET(REPORT(1))_CRLF
+25 ;Added existing call so web Note display matches CPRS - WYSIWYG
DO WRAPTLT^YTQRRPT(.REPORT,RM)
+26 SET I=1
FOR
SET I=$ORDER(REPORT(I))
if 'I
QUIT
SET RESULTS("text","\",I-1)=REPORT(I)_CRLF
+27 DO GETCOM(.COMMS,ADMIN)
+28 IF $GET(TYPE)'="NOTE"
IF $DATA(COMMS)
Begin DoDot:1
+29 SET I=$ORDER(RESULTS("text","\",""),-1)
IF I=""
SET I=0
+30 ;Add separator
SET I=I+1
SET RESULTS("text","\",I)="---Comments----------------------------------------------------------------"_CRLF
+31 SET II=""
FOR
SET II=$ORDER(COMMS(II))
if II=""
QUIT
Begin DoDot:2
+32 SET I=I+1
SET RESULTS("text","\",I)=COMMS(II)_CRLF
End DoDot:2
End DoDot:1
+33 QUIT
GETCOM(ARR,ADMIN) ;Get the COMMENTS from the Instrument Admin
+1 NEW WPARR,TMPAR,DELIM,YSIEN,II,JJ,CNT,STR,WRD
+2 SET YSIEN=ADMIN_","
+3 SET II=$$GET1^DIQ(601.84,YSIEN,10,,"WPARR")
+4 if II=""
QUIT
+5 SET CNT=0
SET STR=""
+6 ;Break up and put back together text by ~
SET II=0
FOR
SET II=$ORDER(WPARR(II))
if II=""
QUIT
Begin DoDot:1
+7 IF WPARR(II)'["~"
SET STR=STR_WPARR(II)
QUIT
+8 SET STR=STR_$PIECE(WPARR(II),"~")
SET CNT=CNT+1
SET TMPAR(CNT)=STR
+9 FOR JJ=2:1:$LENGTH(WPARR(II),"~")-1
Begin DoDot:2
+10 SET CNT=CNT+1
SET TMPAR(CNT)=$PIECE(WPARR(II),"~",JJ)
End DoDot:2
+11 SET STR=$PIECE(WPARR(II),"~",$LENGTH(WPARR(II),"~"))
End DoDot:1
+12 IF STR]""
SET CNT=CNT+1
SET TMPAR(CNT)=STR
+13 ;remove trailing blank line if null
IF TMPAR(CNT)=""
KILL TMPAR(CNT)
+14 MERGE ARR=TMPAR
+15 QUIT
GETNOTE(ARGS,RESULTS) ; build note object based on ARGS("adminId")
+1 NEW ADMIN
SET ADMIN=$GET(ARGS("adminId"))
+2 IF ADMIN=""
DO SETERROR^YTQRUTL(404,"Admin not sent: "_ADMIN)
QUIT
+3 IF '$DATA(^YTT(601.84,ADMIN,0))
DO SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN)
QUIT
+4 NEW CONSULT
SET CONSULT=$PIECE(^YTT(601.84,ADMIN,0),U,15)
+5 SET RESULTS("adminId")=ADMIN
+6 SET RESULTS("consultId")=$SELECT(+CONSULT:CONSULT,1:"null")
+7 SET RESULTS("allowNote")=$$ALWNOTE(ADMIN)
+8 SET RESULTS("requireCosigner")=$$REQCSGN(ADMIN)
+9 SET RESULTS("cosigner")="null"
+10 IF RESULTS("allowNote")="true"
DO REPORT1(ADMIN,.RESULTS,"NOTE")
IF 1
+11 IF '$TEST
SET RESULTS("text")="null"
+12 ; separate out the admins if CAT
DO SPLTADM^YTQRCAT(ADMIN)
+13 QUIT
SETNOTE(ARGS,DATA) ; save note in DATA("text") using ARGS("adminId")
+1 ;Expects DATA to be in the format returned from BLDRPT^YTQRRPT - The RPC most likely does not do that.
+2 NEW YS,YSDATA,ADMIN,CONSULT,WRP,ASGN,LSTASGN,PNOT,AGPROG
+3 SET ADMIN=$GET(DATA("adminId"))
+4 SET LSTASGN=$GET(DATA("lastAssignment"))
+5 SET ASGN=$GET(DATA("assignmentId"))
+6 SET AGPROG=$DATA(^XTMP("YTQASMT-SET-"_ASGN,2))
+7 IF ADMIN=""
DO SETERROR^YTQRUTL(404,"Admin not sent: "_ADMIN)
QUIT ""
+8 IF '$DATA(^YTT(601.84,ADMIN,0))
DO SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN)
QUIT ""
+9 SET CONSULT=$PIECE(^YTT(601.84,ADMIN,0),U,15)
+10 SET PNOT=0
+11 IF $$ALWNOTE(ADMIN)'="true"
Begin DoDot:1
+12 ;This is Restricted Instrument, check if lastAssignment=Yes and there is something in the aggregate progress note.
+13 IF +ASGN'=0
IF (LSTASGN="Yes")
IF AGPROG
SET PNOT=$$FILPNOT^YTQRQAD8(ASGN,ADMIN,CONSULT,.DATA,.YS)
End DoDot:1
QUIT "/api/mha/instrument/note/"_PNOT
+14 IF '$DATA(^YTT(601.84,ADMIN,0))
DO SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN)
QUIT ""
+15 ; parse by CRLF and set YS(#) to note text
DO TXT2LN(.DATA,.YS)
+16 ;reformat lines to 79 max chars
DO WRAP(.YS,79)
+17 SET YS("AD")=ADMIN
+18 ;D WRAPTLT^YTQRRPT(.YS,79) ;Reformat lines in case user edited progress note
+19 IF +$GET(DATA("cosigner"))
Begin DoDot:1
+20 NEW YSCSGN
SET YSCSGN=DATA("cosigner")
+21 SET YS("COSIGNER")=YSCSGN
+22 ; cosigner can't require cosigner
IF $$REQCSGN(ADMIN,YSCSGN)="true"
Begin DoDot:2
+23 SET YSCSGN=$$GET1^DIQ(200,YSCSGN_",",.01)
+24 DO SETERROR^YTQRUTL(403,YSCSGN_" not allowed to cosign.")
End DoDot:2
End DoDot:1
IF $GET(YTQRERRS)
QUIT "/api/mha/instrument/note/0"
+25 ;assignmentID sent in, lastAssignment=Yes/No, $D of aggregate Progress Note
+26 ;Dummy 1 instead of Note IEN
IF +ASGN'=0
IF (LSTASGN'="Yes")
DO SAVPNOT^YTQRQAD8(ASGN,ADMIN,CONSULT,$GET(DATA("cosigner")),.YS)
QUIT "/api/mha/instrument/note/1"
+27 IF +ASGN'=0
IF (LSTASGN="Yes")
IF AGPROG
SET PNOT=$$FILPNOT^YTQRQAD8(ASGN,ADMIN,CONSULT,.DATA,.YS)
QUIT "/api/mha/instrument/note/"_PNOT
+28 ;Either assignmentId not sent (older version of GUI) or single instrument=no aggregate progress note, file individual instrument progress note
+29 IF CONSULT
SET YS("CON")=CONSULT
DO CCREATE^YTQCONS(.YSDATA,.YS)
IF 1
+30 IF '$TEST
DO PCREATE^YTQTIU(.YSDATA,.YS)
+31 IF YSDATA(1)'="[DATA]"
DO SETERROR^YTQRUTL(500,"Note not saved")
QUIT ""
+32 QUIT "/api/mha/instrument/note/"_$GET(YSDATA(2))
+33 ;
ALWNOTE(ADMIN) ; return "true" if note could/should be saved
+1 NEW TEST
+2 ; missing test
SET TEST=$PIECE(^YTT(601.84,ADMIN,0),U,3)
if 'TEST
QUIT "false"
+3 QUIT $$ALWN2(TEST,ADMIN)
+4 ;
ALWN2(TEST,ADMIN) ;Entry point if TEST is input
+1 ;ADMIN - If specific ADMIN is to be checked
+2 NEW TITLE,CONSULT,Y,YSISC,YSTITLE
+3 NEW YSLEG,YSCODE,YSET,YSLEGP
+4 SET ADMIN=+$GET(ADMIN)
+5 ;Look at test definition first
+6 ; R PRIVILEGE
IF $LENGTH($PIECE($GET(^YTT(601.71,TEST,2)),U))
QUIT "false"
+7 ; gen note
IF $PIECE($GET(^YTT(601.71,TEST,8)),U,8)'="Y"
QUIT "false"
+8 ;S YSLEGP="" ;Handle Legacy Instruments - ref YTAPI5
+9 ;S YSLEG=$P($G(^YTT(601.71,TEST,8)),U,3)
+10 ;I YSLEG="Y" D
+11 ;. S YSCODE=$P(^YTT(601.71,TEST,0),U)
+12 ;. S YSET=$O(^YTT(601,"B",YSCODE,""))
+13 ;. I $P(^YTT(601,YSET,0),U,10)="Y"!(YSCODE="GAF")!(YSCODE="ASI") S YSLEGP="true" Q
+14 ;. I $P(^YTT(601,YSET,0),U,9)="I" S YSLEGP="true" Q
+15 ;. S YSLEGP="false3"
+16 ;I +ADMIN=0,(YSLEGP]"") Q YSLEGP ;No ADMIN ID, just look at test definition.
+17 SET CONSULT=""
+18 IF ADMIN'=0
SET CONSULT=$PIECE(^YTT(601.84,ADMIN,0),U,15)
+19 IF CONSULT
Begin DoDot:1
+20 SET YSTITLE=$$GET1^DIQ(601.71,TEST_",",30,"E")
+21 SET Y=$$WHATITLE^TIUPUTU(YSTITLE)
+22 DO ISCNSLT^TIUCNSLT(.YSISC,+Y)
+23 IF 'YSISC
SET YSTITLE="MHA CONSULT"
End DoDot:1
IF 1
+24 IF '$TEST
SET YSTITLE=$$GET1^DIQ(601.71,TEST_",",29,"E")
+25 ; bad note title
IF $$WHATITLE^TIUPUTU(YSTITLE)'>0
QUIT "false"
+26 QUIT "true"
+27 ;
NOTE4PT(ADMIN,DATA) ; save progress note text in assignment for a patient-entered admin
+1 NEW CONSULT,YS,YSDATA,COSIGNER,ASMT,LSTASMT
+2 DO BLDRPT^YTQRRPT(.YS,ADMIN,79)
+3 IF $$ALWNOTE(ADMIN)'="true"
QUIT
+4 SET COSIGNER=$GET(DATA("cosigner"))
+5 SET CONSULT=$GET(DATA("consult"))
IF CONSULT=""
SET CONSULT=$PIECE(^YTT(601.84,ADMIN,0),U,15)
+6 SET ASMT=+$GET(DATA("assignmentId"))
+7 SET LSTASMT=$GET(DATA("lastAssignment"))
+8 ; separate out the admins if CAT
DO SPLTADM^YTQRCAT(ADMIN)
+9 ;S CONSULT=$P(^YTT(601.84,ADMIN,0),U,15)
+10 SET YS("AD")=ADMIN
+11 if COSIGNER]""
SET YS("COSIGNER")=COSIGNER
+12 ;Entry predicated on LSTASMT'=Yes. Therefore=No if updated PE, null if old PE.
+13 ;If LSTASMT=null, file progress note immediately
+14 ;Save in aggregate progress note XTMP instead
IF ASMT'=0
IF (LSTASMT="No")
DO SAVPNOT^YTQRQAD8(ASMT,ADMIN,CONSULT,COSIGNER,.YS)
QUIT
+15 ; If ASMT=0, file directly for backwards compatibility
+16 IF CONSULT
SET YS("CON")=CONSULT
DO CCREATE^YTQCONS(.YSDATA,.YS)
IF 1
+17 IF '$TEST
DO PCREATE^YTQTIU(.YSDATA,.YS)
+18 IF YSDATA(1)'="[DATA]"
DO SETERROR^YTQRUTL(500,"Note not saved")
QUIT
+19 QUIT
ALWCSGN(ARGS,RESULTS) ; GET /api/mha/permission/cosign/:adminId/:userId
+1 NEW ADMIN,COSIGNER,NEEDCSGN
+2 SET ADMIN=$GET(ARGS("adminId"))
+3 SET COSIGNER=$GET(ARGS("userId"))
+4 SET NEEDCSGN=$$REQCSGN(ADMIN,COSIGNER)
+5 SET RESULTS("userId")=COSIGNER
+6 SET RESULTS("allowedToCosign")=$SELECT(NEEDCSGN="true":"false",1:"true")
+7 QUIT
REQCSGN(ADMIN,COSIGNER) ; return "true" if this user requires a cosigner
+1 ; if cosigner is passed in, use that instead of orderedBy
+2 NEW TEST,YSCREQ,YSTITLE,YSPERSON,X0
+3 SET X0=$GET(^YTT(601.84,ADMIN,0))
+4 ; either cosigner or orderedBy
SET YSPERSON=$GET(COSIGNER,$PIECE(X0,U,6))
+5 SET TEST=$PIECE(X0,U,3)
SET CONSULT=$PIECE(X0,U,15)
+6 ; TODO: account for the MHA CONSULT title
+7 SET YSTITLE=$SELECT(CONSULT:$PIECE($GET(^YTT(601.71,TEST,8)),U,10),1:$PIECE($GET(^YTT(601.71,TEST,8)),U,9))
+8 DO REQCOS^TIUSRVA(.YSCREQ,YSTITLE,"",YSPERSON,"")
+9 QUIT $SELECT(YSCREQ:"true",1:"false")
+10 ;
NEEDCSGN(ARGS,RESULTS) ; GET /api/mha/permission/needcosign/:userId 208
+1 ; Returns "true" if userId requires a cosigner
+2 ; Returns "false" if userId does NOT require a cosigner
+3 NEW YSPERSON,YSTITLE,YSCREQ,INSTS,TEST,II,CONSULT,YSCREQ,CSLIST,INAM,CFLG
+4 SET INSTS=$GET(ARGS("instrumentList"))
+5 ;If query param, xlated to lower
if INSTS=""
SET INSTS=$GET(ARGS("instrumentlist"))
+6 SET YSPERSON=$GET(ARGS("userId"))
+7 SET CFLG="false"
+8 IF INSTS=""
Begin DoDot:1
+9 SET YSTITLE=$$TITLE^YTQRQAD7()
+10 DO REQCOS^TIUSRVA(.YSCREQ,YSTITLE,"",YSPERSON,"")
+11 SET RESULTS("userId")=YSPERSON
+12 SET RESULTS("needCosigner")=$SELECT(YSCREQ:"true",1:"false")
+13 ;Unknown without instrument list
SET RESULTS("allowNote")=""
+14 QUIT
End DoDot:1
QUIT
+15 ;I INSTS="" D SETERROR^YTQRUTL(404,"Instrument List not sent. ") QUIT
+16 SET CONSULT=$SELECT($GET(ARGS("consult"))]"":1,1:"")
+17 SET CFLG="false"
+18 FOR II=1:1:$LENGTH(INSTS,",")
Begin DoDot:1
+19 SET INAM=$PIECE(INSTS,",",II)
if INAM=""
QUIT
+20 SET TEST=$ORDER(^YTT(601.71,"B",INAM,""))
if +TEST=0
QUIT
+21 SET YSTITLE=$SELECT(CONSULT:$PIECE($GET(^YTT(601.71,TEST,8)),U,10),1:$PIECE($GET(^YTT(601.71,TEST,8)),U,9))
+22 if YSTITLE=""
QUIT
+23 KILL YSCREQ
+24 DO REQCOS^TIUSRVA(.YSCREQ,YSTITLE,"",YSPERSON,"")
+25 SET CSLIST=$SELECT($GET(YSCREQ)=1:"true",1:"false")
+26 IF CSLIST="true"
SET CFLG="true"
+27 SET RESULTS("instrumentList",II,"instName")=INAM
+28 SET RESULTS("instrumentList",II,"needCosign")=CSLIST
+29 SET RESULTS("instrumentList",II,"allowNote")=$$ALWN2(TEST)
End DoDot:1
+30 QUIT
+31 ;
SETCOM(ARGS,DATA) ; save comment in Instrument Admin (F601.84,f10) using ARGS("adminId")
+1 ;Expects DATA to contain individual lines of text for the comment. Need to retrieve existing and prepend new lines
+2 NEW YS,YSDATA,ADMIN,CONSULT,WRP
+3 NEW YSIEN,YSF,YSERR,N,YSFILEN,YSWP,STR,II,CNT,YSNOW,YST
+4 KILL ^TMP("YSMHI",$JOB)
+5 SET ADMIN=$GET(DATA("adminId"))
+6 IF ADMIN=""
DO SETERROR^YTQRUTL(404,"Admin not sent: "_ADMIN)
QUIT ""
+7 IF '$DATA(^YTT(601.84,ADMIN,0))
DO SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN)
QUIT ""
+8 ; parse by CRLF and set YS(#) to note text
DO TXT2LN(.DATA,.YS)
+9 ;reformat lines to 79 max chars
DO WRAP(.YS,79)
+10 SET YSNOW=$$HTE^XLFDT($HOROLOG,"5ZP")
SET YSNOW=$$UP^XLFSTR(YSNOW)
+11 SET YST="0"_$PIECE(YSNOW," ",2,99)
SET YST=$EXTRACT(YST,$LENGTH(YST)-11,$LENGTH(YST))
SET YSNOW=$PIECE(YSNOW," ")_" "_YST
+12 SET N=0
FOR
SET N=$ORDER(YS(N))
if N=""
QUIT
Begin DoDot:1
+13 SET YS(N)=YS(N)_"~"
End DoDot:1
+14 SET STR="*** Comment Entered By: "_$PIECE($GET(^VA(200,DUZ,0)),U)_" Comment Date: "_YSNOW_"~~"
SET CNT=0
+15 SET N=0
FOR
SET N=$ORDER(YS(N))
if N=""
QUIT
Begin DoDot:1
+16 FOR II=1:1:$LENGTH(YS(N))
Begin DoDot:2
+17 SET STR=STR_$EXTRACT(YS(N),II)
IF $LENGTH(STR)>198
SET CNT=CNT+1
SET ^TMP("YSMHI",$JOB,CNT)=STR
SET STR=""
End DoDot:2
End DoDot:1
+18 IF STR]""
SET CNT=CNT+1
SET ^TMP("YSMHI",$JOB,CNT)=STR
+19 SET YSIEN=ADMIN_","
+20 SET YSFILEN=601.84
+21 SET YSF=10
+22 ;==GET EXISTING COMMENT TEXT==
+23 DO GET1^DIQ(YSFILEN,YSIEN,YSF,,"YSWP","YSERR")
+24 IF '$DATA(YSERR)
Begin DoDot:1
+25 SET N=0
FOR
SET N=$ORDER(YSWP(N))
if N=""
QUIT
Begin DoDot:2
+26 SET CNT=CNT+1
SET ^TMP("YSMHI",$JOB,CNT)=YSWP(N)
End DoDot:2
End DoDot:1
+27 DO WP^DIE(YSFILEN,YSIEN,YSF,,"^TMP(""YSMHI"",$J)","YSERR")
+28 KILL ^TMP("YSMHI",$JOB)
+29 IF $DATA(YSERR)
DO SETERROR^YTQRUTL(500,"Comment not saved")
QUIT "/api/mha/instrument/comment/Error saving comment"
QUIT
+30 QUIT "/api/mha/instrument/comment/OK"
+31 ;
TXT2LN(SRC,DEST) ; Move CRLF delimited text from .SRC into WP lines in .DEST
+1 NEW IDEST,CRLF,REMAIN
+2 SET IDEST=0
SET CRLF=$CHAR(10)
+3 SET REMAIN=$$PARSLN(SRC("text"))
+4 ; done since no continue nodes
IF '$DATA(SRC("text","\",1))
IF $LENGTH(REMAIN)
Begin DoDot:1
+5 SET IDEST=IDEST+1
SET DEST(IDEST)=REMAIN
End DoDot:1
QUIT
+6 ; handle continue nodes
NEW J
+7 SET J=0
FOR
SET J=$ORDER(SRC("text","\",J))
if 'J
QUIT
Begin DoDot:1
+8 SET REMAIN=$$PARSLN(REMAIN_SRC("text","\",J))
End DoDot:1
+9 IF $LENGTH(REMAIN)
SET IDEST=IDEST+1
SET DEST(IDEST)=REMAIN
+10 QUIT
PARSLN(TXT) ; Return remainder after parsing text into lines
+1 ; expects: CRLF, DEST, IDEST
+2 NEW X
SET X=TXT
+3 IF '$LENGTH(X)
QUIT ""
+4 ; Break lines by CRLF. Depending on source line delim could be $c(13) or $c(13,10). CRLF=$c(10) so $TR $c(13) in case it is embedded
+5 FOR
SET IDEST=IDEST+1
SET DEST(IDEST)=$PIECE(X,CRLF)
SET X=$PIECE(X,CRLF,2,99999)
SET DEST(IDEST)=$TRANSLATE(DEST(IDEST),$CHAR(13))
if X'[CRLF
QUIT
+6 QUIT $TRANSLATE(X,$CHAR(13))
WRAP(OUT,MAX) ; Wrap text by space piece word MAX char width
+1 NEW TMP,STR,II,JJ,PCE,CNT
+2 IF +$GET(MAX)=0
SET MAX=79
+3 MERGE TMP=OUT
if '$DATA(TMP)
QUIT
+4 KILL OUT
+5 SET (CNT,II)=0
FOR
SET II=$ORDER(TMP(II))
if II=""
QUIT
Begin DoDot:1
+6 SET STR=""
FOR JJ=1:1:$LENGTH(TMP(II)," ")
Begin DoDot:2
+7 SET PCE=$PIECE(TMP(II)," ",JJ)
+8 IF $LENGTH(STR_PCE_" ")>MAX
Begin DoDot:3
+9 SET CNT=CNT+1
SET OUT(CNT)=$EXTRACT(STR,1,$LENGTH(STR)-1)
SET STR=PCE_" "
End DoDot:3
QUIT
+10 SET STR=STR_PCE_" "
End DoDot:2
+11 IF STR]""
SET CNT=CNT+1
SET OUT(CNT)=$EXTRACT(STR,1,$LENGTH(STR)-1)
End DoDot:1
+12 QUIT
+13 ;
