Routine: YTQRCDB3

YTQRCDB3 ;BAL/KTL - MHA CLOUD DATABASE REPORT/NOTE RPC CALLS; 1/25/2017

 ;;5.01;MENTAL HEALTH;**239,224**;Dec 30, 1994;Build 17

 ; Reference to ^DPT in ICR #10035

PENOTE(ARGS,DATA) ;Patient Entry progress note

 N II,DFN,ADMERR,TXT,DARR,NOTERSL

 N TCNT,CCNT

 S DFN=$G(DATA("dfn")) I +DFN=0!'$D(^DPT(DFN)) D SETERROR^YTQRUTL(404,"Invalid patient ID: "_DFN) Q "/api/mha/cdb/instrument/note/0"

 S II=0 F  S II=$O(DATA("notes",II)) Q:II=""  D

 . S ADMIN=$G(DATA("notes",II,"adminId")) Q:+ADMIN=0

 . I $P($G(^YTT(601.84,ADMIN,0)),U,2)'=DFN S ADMERR=$G(ADMERR)_" : "_ADMIN K DATA("notes",II)  ;Admin does not match passed in patient

 I $G(ADMERR) D SETERROR^YTQRUTL(404,"Administration IDs do not match patient "_ADMERR) W !,ADMERR

 I '$D(DATA("notes")) Q "/api/mha/cdb/instrument/note/0"  ;No valid admins

 D PRSNOTE(.ARGS,.DATA,.TXT,"PE")

 S II=0 F  S II=$O(TXT(II)) Q:II=""  D

 . S TCNT=$G(TCNT)+1

 . I TCNT=1 S DARR("text")=TXT(II) Q

 . S CCNT=$G(CCNT)+1

 . S DARR("text","\",CCNT)=TXT(II)

 S II=$O(DATA("notes","")),DARR("adminId")=DATA("notes",II,"adminId")

 S NOTERSL=$$SETNOTE(.ARGS,.DARR)

 Q NOTERSL

SENOTE(ARGS,DATA) ;Staff Entry progress note

PRSNOTE(ARGS,DATA,TXT,YSTYPE) ;Parse the incoming note JSON and branch accordingly.

 N I,J,TXTARR,ADMIN,CONSULT,ALWNOTE,RESULTS,CNT

 N COSIGNER,HDR,NCNT

 S CNT=0

 S I=0 F  S I=$O(DATA("notes",I)) Q:+I=0  D

 . S ADMIN=$G(DATA("notes",I,"adminId"))

 . S COSIGNER=$G(DATA("notes",I,"cosigner"))

 . I +ADMIN=0 D SETERROR^YTQRUTL(404,"Admin not sent: "_ADMIN) Q

 . I '$D(^YTT(601.84,ADMIN,0)) D SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN) Q

 . K RESULTS

 . I '$D(DATA("notes",I,"text"))!($G(DATA("notes",I,"text"))="null") D GETNOTE(ADMIN,COSIGNER,.RESULTS)  ;No text passed in, generate from VistA MH REPORT template

 . I $D(DATA("notes",I,"text")),(DATA("notes",I,"text")'="null") D  ;PE/SE and note body sent

 .. S NCNT=0

 .. I $G(YSTYPE)="PE" D  ;PE needs patient header added

 ... D BLDHDR^YTQRCDB4(.HDR,ADMIN,79)

 ... S J=0 F  S J=$O(HDR(J)) Q:J=""  D

 .... S NCNT=NCNT+1,RESULTS("text","\",NCNT)=HDR(J)

 .. S J=0 F  S J=$O(DATA("notes",I,"text",J)) Q:J=""  D

 ... S NCNT=NCNT+1,RESULTS("text","\",NCNT)=DATA("notes",I,"text",J)

 . I $G(RESULTS("text"))="null" Q

 . ;Now text is normalized in RESULTS whether sent in or generated through VistA.

 . I CNT'=0 D

 .. S CNT=CNT+1,$P(TXTARR(CNT),"_",75)="" ;Add Note Divider

 . S J=0 F  S J=$O(RESULTS("text","\",J)) Q:J=""  D  ;RESULTS format back into sequential TXTARR array

 .. S CNT=CNT+1,TXTARR(CNT)=RESULTS("text","\",J)

 ;At this point all Cloud generated and VistA generated PNOTE text in TXTARR

 M TXT=TXTARR

GETNOTE(ADMIN,COSIGNER,RESULTS) ; build note object based on ARGS("adminId")

 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^YTQRQAD3(ADMIN)

 S RESULTS("requireCosigner")=$$REQCSGN^YTQRQAD3(ADMIN)

 S RESULTS("cosigner")=$S(COSIGNER'="":COSIGNER,1:"null")

 I RESULTS("allowNote")="true" D REPORT1^YTQRQAD3(ADMIN,.RESULTS,"NOTE") I 1  ;ADMIN=Administration IEN, RESULTS array for report, NOTE=PROGRESS NOTE

 E  S RESULTS("text")="null"

 D SPLTADM^YTQRCAT(ADMIN) ; separate out the admins if CAT

SETNOTE(ARGS,DATA) ; save note in DATA("text") using ARGS("adminId")

 ;Expects DATA to be in the format returned from BLDRPT^YTQRRPT

 ;All instrument progress notes should be in DATA("text"), even for multiple instrument assignments

 N YS,YSDATA,ADMIN,CONSULT,WRP,ASGN,LSTASGN,PNOT,AGPROG

 S ADMIN=$G(DATA("adminId"))

 S ASGN=$G(DATA("assignmentId"))

 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 '$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

 I $G(DATA("cosigner"))]"" S YS("COSIGNER")=DATA("cosigner")

 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/cdb/instrument/note/"_$G(YSDATA(2))

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

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRCDB3   5791     printed  Mar 13, 2025@21:23:35                                                                                                                                                                                                    Page 2

YTQRCDB3  ;BAL/KTL - MHA CLOUD DATABASE REPORT/NOTE RPC CALLS; 1/25/2017

 +1       ;;5.01;MENTAL HEALTH;**239,224**;Dec 30, 1994;Build 17

 +2       ;

 +3       ; Reference to ^DPT in ICR #10035

 +4       ;

 +5        QUIT

PENOTE(ARGS,DATA) ;Patient Entry progress note

 +1        NEW II,DFN,ADMERR,TXT,DARR,NOTERSL

 +2        NEW TCNT,CCNT

 +3        SET DFN=$GET(DATA("dfn"))

           IF +DFN=0!'$DATA(^DPT(DFN))

               DO SETERROR^YTQRUTL(404,"Invalid patient ID: "_DFN)

               QUIT "/api/mha/cdb/instrument/note/0"

 +4        SET II=0

FOR

               SET II=$ORDER(DATA("notes",II))

               if II=""

                   QUIT

               Begin DoDot:1

 +5                SET ADMIN=$GET(DATA("notes",II,"adminId"))

                   if +ADMIN=0

                       QUIT

 +6       ;Admin does not match passed in patient

                   IF $PIECE($GET(^YTT(601.84,ADMIN,0)),U,2)'=DFN

                       SET ADMERR=$GET(ADMERR)_" : "_ADMIN

                       KILL DATA("notes",II)

               End DoDot:1

 +7        IF $GET(ADMERR)

               DO SETERROR^YTQRUTL(404,"Administration IDs do not match patient "_ADMERR)

               WRITE !,ADMERR

 +8       ;No valid admins

           IF '$DATA(DATA("notes"))

               QUIT "/api/mha/cdb/instrument/note/0"

 +9        DO PRSNOTE(.ARGS,.DATA,.TXT,"PE")

 +10       SET II=0

FOR

               SET II=$ORDER(TXT(II))

               if II=""

                   QUIT

               Begin DoDot:1

 +11               SET TCNT=$GET(TCNT)+1

 +12               IF TCNT=1

                       SET DARR("text")=TXT(II)

                       QUIT

 +13               SET CCNT=$GET(CCNT)+1

 +14               SET DARR("text","\",CCNT)=TXT(II)

               End DoDot:1

 +15       SET II=$ORDER(DATA("notes",""))

           SET DARR("adminId")=DATA("notes",II,"adminId")

 +16       SET NOTERSL=$$SETNOTE(.ARGS,.DARR)

 +17       QUIT NOTERSL

 +18       QUIT

SENOTE(ARGS,DATA) ;Staff Entry progress note

 +1        QUIT

PRSNOTE(ARGS,DATA,TXT,YSTYPE) ;Parse the incoming note JSON and branch accordingly.

 +1        NEW I,J,TXTARR,ADMIN,CONSULT,ALWNOTE,RESULTS,CNT

 +2        NEW COSIGNER,HDR,NCNT

 +3        SET CNT=0

 +4        SET I=0

FOR

               SET I=$ORDER(DATA("notes",I))

               if +I=0

                   QUIT

               Begin DoDot:1

 +5                SET ADMIN=$GET(DATA("notes",I,"adminId"))

 +6                SET COSIGNER=$GET(DATA("notes",I,"cosigner"))

 +7                IF +ADMIN=0

                       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                KILL RESULTS

 +10      ;No text passed in, generate from VistA MH REPORT template

                   IF '$DATA(DATA("notes",I,"text"))!($GET(DATA("notes",I,"text"))="null")

                       DO GETNOTE(ADMIN,COSIGNER,.RESULTS)

 +11      ;PE/SE and note body sent

                   IF $DATA(DATA("notes",I,"text"))

                       IF (DATA("notes",I,"text")'="null")

                           Begin DoDot:2

 +12                           SET NCNT=0

 +13      ;PE needs patient header added

                               IF $GET(YSTYPE)="PE"

                                   Begin DoDot:3

 +14                                   DO BLDHDR^YTQRCDB4(.HDR,ADMIN,79)

 +15                                   SET J=0

FOR

                                           SET J=$ORDER(HDR(J))

                                           if J=""

                                               QUIT

                                           Begin DoDot:4

 +16                                           SET NCNT=NCNT+1

                                               SET RESULTS("text","\",NCNT)=HDR(J)

                                           End DoDot:4

                                   End DoDot:3

 +17                           SET J=0

FOR

                                   SET J=$ORDER(DATA("notes",I,"text",J))

                                   if J=""

                                       QUIT

                                   Begin DoDot:3

 +18                                   SET NCNT=NCNT+1

                                       SET RESULTS("text","\",NCNT)=DATA("notes",I,"text",J)

                                   End DoDot:3

                           End DoDot:2

 +19               IF $GET(RESULTS("text"))="null"

                       QUIT

 +20      ;Now text is normalized in RESULTS whether sent in or generated through VistA.

 +21               IF CNT'=0

                       Begin DoDot:2

 +22      ;Add Note Divider

                           SET CNT=CNT+1

                           SET $PIECE(TXTARR(CNT),"_",75)=""

                       End DoDot:2

 +23      ;RESULTS format back into sequential TXTARR array

                   SET J=0

FOR

                       SET J=$ORDER(RESULTS("text","\",J))

                       if J=""

                           QUIT

                       Begin DoDot:2

 +24                       SET CNT=CNT+1

                           SET TXTARR(CNT)=RESULTS("text","\",J)

                       End DoDot:2

               End DoDot:1

 +25      ;At this point all Cloud generated and VistA generated PNOTE text in TXTARR

 +26       MERGE TXT=TXTARR

 +27       QUIT

GETNOTE(ADMIN,COSIGNER,RESULTS) ; build note object based on ARGS("adminId")

 +1        IF '$DATA(^YTT(601.84,ADMIN,0))

               DO SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN)

               QUIT

 +2        NEW CONSULT

           SET CONSULT=$PIECE(^YTT(601.84,ADMIN,0),U,15)

 +3        SET RESULTS("adminId")=ADMIN

 +4        SET RESULTS("consultId")=$SELECT(+CONSULT:CONSULT,1:"null")

 +5        SET RESULTS("allowNote")=$$ALWNOTE^YTQRQAD3(ADMIN)

 +6        SET RESULTS("requireCosigner")=$$REQCSGN^YTQRQAD3(ADMIN)

 +7        SET RESULTS("cosigner")=$SELECT(COSIGNER'="":COSIGNER,1:"null")

 +8       ;ADMIN=Administration IEN, RESULTS array for report, NOTE=PROGRESS NOTE

           IF RESULTS("allowNote")="true"

               DO REPORT1^YTQRQAD3(ADMIN,.RESULTS,"NOTE")

               IF 1

 +9       IF '$TEST

               SET RESULTS("text")="null"

 +10      ; separate out the admins if CAT

           DO SPLTADM^YTQRCAT(ADMIN)

 +11       QUIT

SETNOTE(ARGS,DATA) ; save note in DATA("text") using ARGS("adminId")

 +1       ;Expects DATA to be in the format returned from BLDRPT^YTQRRPT

 +2       ;All instrument progress notes should be in DATA("text"), even for multiple instrument assignments

 +3        NEW YS,YSDATA,ADMIN,CONSULT,WRP,ASGN,LSTASGN,PNOT,AGPROG

 +4        SET ADMIN=$GET(DATA("adminId"))

 +5        SET ASGN=$GET(DATA("assignmentId"))

 +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        SET CONSULT=$PIECE(^YTT(601.84,ADMIN,0),U,15)

 +9        SET PNOT=0

 +10       IF '$DATA(^YTT(601.84,ADMIN,0))

               DO SETERROR^YTQRUTL(404,"Admin not found: "_ADMIN)

               QUIT ""

 +11      ; parse by CRLF and set YS(#) to note text

           DO TXT2LN(.DATA,.YS)

 +12      ;reformat lines to 79 max chars

           DO WRAP(.YS,79)

 +13       SET YS("AD")=ADMIN

 +14       IF $GET(DATA("cosigner"))]""

               SET YS("COSIGNER")=DATA("cosigner")

 +15       IF CONSULT

               SET YS("CON")=CONSULT

               DO CCREATE^YTQCONS(.YSDATA,.YS)

               IF 1

 +16      IF '$TEST

               DO PCREATE^YTQTIU(.YSDATA,.YS)

 +17       IF YSDATA(1)'="[DATA]"

               DO SETERROR^YTQRUTL(500,"Note not saved")

               QUIT ""

 +18       QUIT "/api/mha/cdb/instrument/note/"_$GET(YSDATA(2))

 +19      ;

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      ;

YTQRCDB3.m