YSBDD1 ;SLC/DSB - MHA DASHBOARD Drilldown ; Apr 01, 2021@16:30
;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
;
; Reference to DEM^VADPT in ICR #7109
; Reference to ^DGPF(26.15,"B") in ICR #5991
; Reference to SDAPI^SDAMA301 in ICR #4433
; Reference to GETINF^DGPFAPIH in ICR #4903
; Reference to TIUSRVL in ICR #2812
Q
PATIENT(DFN,DATAOUT) ;
N VADM,VAPA
D DEM^VADPT
D ADD^VADPT
S DATAOUT("patient_information","name")=VADM(1)
S DATAOUT("patient_information","sex")=$P(VADM(5),U,2)
S DATAOUT("patient_information","dob")=$P(VADM(3),U,2)
S DATAOUT("patient_information","age")=VADM(4)
S DATAOUT("patient_information","social")=$P(VADM(2),U,2)
S DATAOUT("patient_information","address1")=VAPA(1)
S DATAOUT("patient_information","address2")=VAPA(2)
S DATAOUT("patient_information","address3")=VAPA(3)
S DATAOUT("patient_information","city")=VAPA(4)
S DATAOUT("patient_information","state")=$P(VAPA(5),U,2)
S DATAOUT("patient_information","zipcode")=VAPA(6)
S DATAOUT("patient_information","phone_number")=VAPA(8)
S DATAOUT("patient_information","cell_phone")=$P($G(^DPT(DFN,.13)),U,4)
Q
;
HRPTPROF(JSONOUT,DFN) ;
N PRFNAME,IDX,YSDARRAY,SDCOUNT,NOW,YSDT,SDTIME,HRRVWDT,DHRR,TIUIDX,DATAOUT,ERRARY,PIDX,FIDX,TIUINVDT,DATEFOUND,SAFHEAD,SAFDCL,CSREHEAD
N APPTLIST,NODE,OUTPXENC,IEN,PRV,PRVLIST,FTRLIST,DATE,ENCOUNTER,I,YSVISIT,NIDX,STATUS,PREFS,OPCUT
N PATTYP
N SAFSCNO,SAFSCYES,CSRENEW,CSREUPD,SITES,HFCLIST,SAFREV
S NOW=$$NOW^XLFDT
S YSDT=$P(NOW,".",1)
D HRINIT^YSBRPC(.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.CSREHEAD,.CSRENEW,.CSREUPD,.SITES)
;D GETLST^XPAR(.SAFHFC,"SYS","YSB SAFETY PLAN HF CATEGORY")
;D GETLST^XPAR(.SAFHEAD,"SYS","YSB SAFETY PLAN HEADER TEXT")
;D GETLST^XPAR(.SAFDCL,"SYS","YSB SAFETY PLAN DECLINE")
;D GETLST^XPAR(.CSREHFC,"SYS","YSB CSRE HF CATEGORY")
;D GETLST^XPAR(.CSREHEAD,"SYS","YSB CSRE HEADER TEXT")
S DATAOUT("high_risk_patient_profile","patient_record_flag",1,"flag_name")=""
S DATAOUT("high_risk_patient_profile","patient_record_flag",1,"review_date")=""
S DATAOUT("high_risk_patient_profile","patient_record_flag",1,"due/overdue")=""
S DATAOUT("high_risk_patient_profile","patient_record_flag",1,"prf_actions")=""
S DATAOUT("high_risk_patient_profile","patient_record_flag",1,"action_date")=""
S (HRRVWDT,DHRR)=0
S (PRFNAME,PRFIEN,IDX)=0 F S PRFNAME=$O(^DGPF(26.15,"B",PRFNAME)) Q:PRFNAME']"" D
.N PRFIEN,RSLT,PRFDATA,HISTIDX,LSTHIST,PRFACT,NXTHIDX,NXTHDT
.S PRFIEN=$O(^DGPF(26.15,"B",PRFNAME,""))
.S RSLT=$$GETINF^DGPFAPIH(DFN,PRFIEN_";DGPF(26.15,","","","PRFDATA")
.I RSLT=0 Q
.S LSTHIST=$O(PRFDATA("HIST",""),-1)
.S HISTIDX="A" F S HISTIDX=$O(PRFDATA("HIST",HISTIDX),-1) Q:'HISTIDX D
..S IDX=IDX+1
..S PRFACT=$P(PRFDATA("HIST",HISTIDX,"ACTION"),U,2)
..S NXTHIDX=$O(PRFDATA("HIST",HISTIDX))
..S NXTHDT="UNK" ;I NXTHIDX]"" S NXTHDT=$P($P($G(PRFDATA("HIST",NXTHIDX,"DATETIME")),U,2),"@")
..S DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"flag_name")=PRFNAME
..I $P(PRFDATA("REVIEWDT"),U,2)="" S $P(PRFDATA("REVIEWDT"),U,2)="N/A"
..S DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"review_date")=$S(HISTIDX=LSTHIST:$P(PRFDATA("REVIEWDT"),U,2),PRFACT="INACTIVATE":"N/A",1:NXTHDT) ;Need to review this later
..I PRFIEN=2 D ;save the High Risk dates for later use
...I $$FMTH^XLFDT($P(PRFDATA("REVIEWDT"),U,1),1)'>DHRR Q
...S HRRVWDT=$P(PRFDATA("REVIEWDT"),U,1),DHRR=$$FMTH^XLFDT($P(PRFDATA("REVIEWDT"),U,1),1)
..S DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"due/overdue")=$S(HISTIDX=LSTHIST:$$GETDUE^YSBWHIGH($P(PRFDATA("REVIEWDT"),U),YSDT),PRFACT="INACTIVATE":"N/A",1:"UNK")
..S DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"prf_actions")=PRFACT
..S DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"action_date")=$P($P(PRFDATA("HIST",HISTIDX,"DATETIME"),U,2),"@")
; scheduled appointments
K ^TMP($J,"SDAMA301")
N FROMTO
;S FROMTO=91
S FROMTO=365
S YSDARRAY(1)=$$FMADD^XLFDT(YSDT,-FROMTO)_";"_$$FMADD^XLFDT(YSDT,FROMTO)
S YSDARRAY(3)="R;I;NS;NSR;CC;CCR;CP;CPR;NT;"
S YSDARRAY(4)=DFN
S YSDARRAY("FLDS")="1;2;12;13;18;22"
S YSDARRAY("SORT")="P"
S SDCOUNT=$$SDAPI^SDAMA301(.YSDARRAY)
M APPTLIST=^TMP($J,"SDAMA301",DFN)
;add ^SCE("ADFN" loop to detect Outpatient Encounters with no visit. These will be marked as unscheduled
S (PIDX,FIDX)=0
S SDTIME=$$FMADD^XLFDT(YSDT,-FROMTO-1),OPCUT=$$FMADD^XLFDT(YSDT,FROMTO)
F S SDTIME=$O(^SCE("ADFN",DFN,SDTIME)) Q:'SDTIME!(SDTIME>OPCUT) D
.I $D(APPTLIST(SDTIME)) Q ;already got this visit, must be scheduled
.S OUTPXENC=$O(^SCE("ADFN",DFN,SDTIME,0))
.S NODE=^SCE(OUTPXENC,0)
.S APPTLIST(SDTIME)=SDTIME_U_$P(NODE,U,4)_";"_$$GET1^DIQ(44,$P(NODE,U,4),.01)_"^^^^^^^^^^"_OUTPXENC_U_$P(NODE,U,3)_";"_$$GET1^DIQ(40.7,$P(NODE,U,3),1)_"^^^^^4;UV^^^^;;WALK-IN"
; split appointments into past and previous
;sort previous appointments by reverse date
S SDTIME=NOW-.000001
F S SDTIME=$O(APPTLIST(SDTIME),-1) Q:'SDTIME D
.I '$$CHKCLIN(APPTLIST(SDTIME)) K APPTLIST(SDTIME) Q ;not ED or MH clinic - delete
.I $P(APPTLIST(SDTIME),U,22)="11;FUTURE;FUTURE" Q ;in the future, possible for an appt later today
.S PIDX=PIDX+1
.S PRVLIST(PIDX)=APPTLIST(SDTIME)
.K APPTLIST(SDTIME)
;sort future appointments - all previous appts are deleted
S SDTIME=0 F S SDTIME=$O(APPTLIST(SDTIME)) Q:'SDTIME D
.I '$$CHKCLIN(APPTLIST(SDTIME)) Q
.S FIDX=FIDX+1
.S FTRLIST(FIDX)=APPTLIST(SDTIME)
; handle previous appointments
N PSTAT
S PIDX=0 F S PIDX=$O(PRVLIST(PIDX)) Q:'PIDX D
.S NIDX=0
.S NODE=PRVLIST(PIDX)
.S STATUS=$P(NODE,U,22),PSTAT=$P(STATUS,";",3)
.S STATUS=$P($P($P(NODE,U,22),";",3)," &") ; also removes " & AUTO-REBOOK"
.I STATUS["NO ACTION TAKEN",(PSTAT'["CHECKED") Q ;No positive state of this encounter.
.I STATUS["NO ACT TAKN",(PSTAT'["CHECKED") Q ;Inpatient No action taken
.I PSTAT["CHECKED" S STATUS=PSTAT ;For Checked In/Checked Out replace NO ACTION TAKEN status
.S SDTIME=+NODE
.S ENCOUNTER=$P(NODE,U,12)
.S YSVISIT="" I ENCOUNTER S YSVISIT=$P(^SCE(ENCOUNTER,0),U,5)
.S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"location")=$P($P(NODE,U,2),";",2)
.S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"date")=$$FMTE^XLFDT(SDTIME,5)
.S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"provider")="N/A"
.S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"status")=$P($P(NODE,U,22),";",3)
.I YSVISIT D
..S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"status")="COMPLETED"
..I $P(NODE,U,18)="4;UV" S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"status")="WALK-IN"
..S (IEN,PRV)="" F S IEN=$O(^AUPNVPRV("AD",YSVISIT,IEN)) Q:'IEN D Q:PRV ;DBIA 2316
...S NODE=^AUPNVPRV(IEN,0)
...I $P(NODE,U,4)="P" S PRV=+NODE
...Q
..I PRV D
...S PRV=$$GET1^DIQ(200,PRV_",",.01)
...S $P(PRV,",",2)=" "_$P(PRV,",",2) ;add a space between last and first name so GUI column can wrap
...S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"provider")=PRV
..K ^TMP("TIULIST",$J)
..D NOTES^TIUSRVLV("",YSVISIT)
..;loop through ^TMP("TIULIST",$J) and set TIUDA to each value
..S DATE="" F S DATE=$O(^TMP("TIULIST",$J,DATE)) Q:'DATE D
...S I="" F S I=$O(^TMP("TIULIST",$J,DATE,I)) Q:'I D
....I $P(^TMP("TIULIST",$J,DATE,I),U,7)'="completed" Q ;only completed (signed) notes.
....S NIDX=NIDX+1
....S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"notes",NIDX,"docID")=+^TMP("TIULIST",$J,DATE,I)
....S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"notes",NIDX,"docName")=$P(^TMP("TIULIST",$J,DATE,I),U,2)
.I 'NIDX S DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"notes")=""
; handle future appointments
S FIDX=0 F S FIDX=$O(FTRLIST(FIDX)) Q:'FIDX D
.S NODE=FTRLIST(FIDX)
.S SDTIME=+NODE
.S DATAOUT("high_risk_patient_profile","future_appointments",FIDX,"location")=$P($P(NODE,U,2),";",2)
.S DATAOUT("high_risk_patient_profile","future_appointments",FIDX,"date")=$$FMTE^XLFDT(SDTIME,5)
K ^TMP($J,"SDAMA301")
I '$D(DATAOUT("high_risk_patient_profile","previous_activity")) S DATAOUT("high_risk_patient_profile","previous_activity",1)=""
I '$D(DATAOUT("high_risk_patient_profile","future_appointments")) S DATAOUT("high_risk_patient_profile","future_appointments",1)=""
; review status
N DSTAT
S PATTYP=$$MHDCDT^YSBWHIG2(DFN) S:PATTYP'="INPT" PATTYP="" ;Will return INPT if still an inpatient.
S DSTAT=$$DONE7^YSBWHIGH(DFN,YSDT,.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES)
S DATAOUT("high_risk_patient_profile","review_status","review_due")=$$GETDUE^YSBWHIGH(HRRVWDT,YSDT)
S DATAOUT("high_risk_patient_profile","review_status","on_track")=$$ONTRK^YSBWHIGH(DFN,"")
S DATAOUT("high_risk_patient_profile","review_status","done_in_7")=DSTAT
S DATAOUT("high_risk_patient_profile","review_status","done_in_7_number")=$$DONENUM(NOW)
S DATAOUT("high_risk_patient_profile","review_status","inpatient")=PATTYP
; safety plan
N TIUFND
S TIUINVDT=0,IDX=0,TIUFND=1
D SAFLST^YSBWHIGH(.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.HFCLIST)
F S DATEFOUND=$$FINDDOC^YSBWHIGH(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,.TIUIDX,TIUFND) Q:'TIUINVDT D
.S IDX=IDX+1
.S DATAOUT("high_risk_patient_profile","safety_plan",IDX,"docID")=TIUIDX
.I $$SAFDECL^YSBWHIGH(DFN,TIUINVDT) S DATAOUT("high_risk_patient_profile","safety_plan",IDX,"date")="Declined" Q
.S DATAOUT("high_risk_patient_profile","safety_plan",IDX,"date")=$$FMTE^XLFDT($P(DATEFOUND,"."),5)
I 'IDX S DATAOUT("high_risk_patient_profile","safety_plan",1,"date")="Not Done"
;CSRE
K HFCLIST
D CSRELST^YSBWHIGH(.CSRENEW,.CSREUPD,.HFCLIST)
S TIUINVDT=0,IDX=0 F S DATEFOUND=$$FINDDOC^YSBWHIGH(DFN,.TIUINVDT,.HFCLIST,.CSREHEAD,.TIUIDX,TIUFND) Q:'TIUINVDT D
.S IDX=IDX+1
.S DATAOUT("high_risk_patient_profile","CSRE",IDX,"date")=$$FMTE^XLFDT($P(DATEFOUND,"."),5)
.S DATAOUT("high_risk_patient_profile","CSRE",IDX,"docID")=TIUIDX
I 'IDX S DATAOUT("high_risk_patient_profile","CSRE",1,"date")="Not Done"
D ENCODE^YSBJSON("DATAOUT","JSONOUT","ERRARY")
K ^TMP($J,"SDAMA301")
K ^TMP("TIULIST",$J)
Q
WEBPROF(ARGS,RESULTS) ; MHA Web call for HRPTPROF
N DFN,JSONOUT
S DFN=$G(ARGS("dfn"))
I DFN="" D SETERROR^YTQRUTL(404,"Patient ID not sent.") QUIT
D HRPTPROF(.JSONOUT,DFN)
D TOTMP^YSBRPC(.JSONOUT)
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
;
DONENUM(TDT) ; Calculate the number of days for Done in 7
N ACTDT,II,LST,RCNT,DIFF
N NMSTR,NMARR,ACTSTR,ACTARR,LSTNM
S NMARR("HIGH RISK FOR SUICIDE")=""
S NMARR("BEHAVIORAL")=""
S NMARR("MISSING PATIENT")=""
S ACTARR("REACTIVATE")=""
S ACTARR("CONTINUE")=""
S ACTARR("NEW ASSIGNMENT")=""
S RCNT=0,LST=0,LSTNM=""
S II=0 F S II=$O(DATAOUT("high_risk_patient_profile","patient_record_flag",II)) Q:II="" D
. S NMSTR=$G(DATAOUT("high_risk_patient_profile","patient_record_flag",II,"flag_name"))
. I NMSTR]"" S LSTNM=NMSTR
. I LSTNM]"" Q:'$D(NMARR(LSTNM)) ;Quit if we are not in a sequence of NEW/REACTIVATE/CONTINUE the Patient Record flags of interest
. S ACTSTR=$G(DATAOUT("high_risk_patient_profile","patient_record_flag",II,"prf_actions"))
. I ACTSTR]"" Q:'$D(ACTARR(ACTSTR))
. S RCNT=$G(DATAOUT("high_risk_patient_profile","patient_record_flag",II,"action_date"))
. S RCNT=$$ETF(RCNT)
. I RCNT>LST S LST=RCNT
S LST=$$FMTH^XLFDT(LST,1),LST=LST+7,LST=$$HTFM^XLFDT(LST,1)
S DIFF=$$FMDIFF^XLFDT(LST,TDT,1)
Q DIFF
ETF(X) ; External to Fileman format
N %DT,Y S X=$G(X),%DT="PST" D ^%DT S X=Y S:+X'>0 X="" Q X
Q
CHKCLIN(NODE) ;
N STOPCODE
S STOPCODE=$P($P(NODE,U,13),";",2)
I STOPCODE=130 Q 1 ;ED clinic
I (STOPCODE>499),(STOPCODE<600) Q 1 ;MH clinic
Q 0 ;not ED or MH clinic
;
GETNOTE(JSONOUT,YSTIUDA) ;
N DATAOUT,YSTEXT
;note text
D TGET^TIUSRVR1(.YSTEXT,YSTIUDA) ;TEXT just contains the string "^TMP("TIUVIEW",TIUDA)"
S IDX=0 F S IDX=$O(@YSTEXT@(IDX)) Q:'IDX S DATAOUT("note_text",IDX,"line")=@YSTEXT@(IDX)
I IDX=0 S DATAOUT("note_text",1)=""
D ENCODE^YSBJSON("DATAOUT","JSONOUT","ERRARY")
Q
WEBNOTE(ARGS,RESULTS) ;MHA Web call for GETNOTE
N YSTIUDA,JSONOUT
S YSTIUDA=$G(ARGS("noteId"))
I YSTIUDA="" D SETERROR^YTQRUTL(404,"Note ID not sent") QUIT
D GETNOTE(.JSONOUT,YSTIUDA)
D TOTMP^YSBRPC(.JSONOUT)
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
;
GETRPRT(JSONOUT,ADMIN) ;
N REPORT,DATAOUT,ERRARY
K ^TMP("YTQRERRS",$J)
D BLDRPT^YTQRRPT(.REPORT,ADMIN)
I $D(REPORT) D
.N IDX
.S IDX=0 F S IDX=$O(REPORT(IDX)) Q:'IDX D
..S DATAOUT("report",IDX,"line")=REPORT(IDX)
I '$D(REPORT) S DATAOUT("report",1,"line")="<no text>"
I $D(^TMP("YTQRERRS",$J,1,"error")) D
.S DATAOUT("report",1,"line")=^TMP("YTQRERRS",$J,1,"error","code")
.S DATAOUT("report",2,"line")=^TMP("YTQRERRS",$J,1,"error","message")
.S DATAOUT("report",3,"line")=^TMP("YTQRERRS",$J,1,"error","errors",1,"message")
D ENCODE^YSBJSON("DATAOUT","JSONOUT","ERRARY")
K ^TMP("YTQRERRS",$J)
Q
WEBRPRT(ARGS,RESULTS) ;
N REPORT,DATAOUT,ERRARY,ADMIN,JSONOUT
S ADMIN=$G(ARGS("adminId"))
I ADMIN="" D SETERROR^YTQRUTL(404,"Admin ID not sent.") QUIT
D GETRPRT(.JSONOUT,ADMIN)
D TOTMP^YSBRPC(.JSONOUT)
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSBDD1 13311 printed Sep 23, 2025@19:49:31 Page 2
YSBDD1 ;SLC/DSB - MHA DASHBOARD Drilldown ; Apr 01, 2021@16:30
+1 ;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
+2 ;
+3 ; Reference to DEM^VADPT in ICR #7109
+4 ; Reference to ^DGPF(26.15,"B") in ICR #5991
+5 ; Reference to SDAPI^SDAMA301 in ICR #4433
+6 ; Reference to GETINF^DGPFAPIH in ICR #4903
+7 ; Reference to TIUSRVL in ICR #2812
+8 QUIT
PATIENT(DFN,DATAOUT) ;
+1 NEW VADM,VAPA
+2 DO DEM^VADPT
+3 DO ADD^VADPT
+4 SET DATAOUT("patient_information","name")=VADM(1)
+5 SET DATAOUT("patient_information","sex")=$PIECE(VADM(5),U,2)
+6 SET DATAOUT("patient_information","dob")=$PIECE(VADM(3),U,2)
+7 SET DATAOUT("patient_information","age")=VADM(4)
+8 SET DATAOUT("patient_information","social")=$PIECE(VADM(2),U,2)
+9 SET DATAOUT("patient_information","address1")=VAPA(1)
+10 SET DATAOUT("patient_information","address2")=VAPA(2)
+11 SET DATAOUT("patient_information","address3")=VAPA(3)
+12 SET DATAOUT("patient_information","city")=VAPA(4)
+13 SET DATAOUT("patient_information","state")=$PIECE(VAPA(5),U,2)
+14 SET DATAOUT("patient_information","zipcode")=VAPA(6)
+15 SET DATAOUT("patient_information","phone_number")=VAPA(8)
+16 SET DATAOUT("patient_information","cell_phone")=$PIECE($GET(^DPT(DFN,.13)),U,4)
+17 QUIT
+18 ;
HRPTPROF(JSONOUT,DFN) ;
+1 NEW PRFNAME,IDX,YSDARRAY,SDCOUNT,NOW,YSDT,SDTIME,HRRVWDT,DHRR,TIUIDX,DATAOUT,ERRARY,PIDX,FIDX,TIUINVDT,DATEFOUND,SAFHEAD,SAFDCL,CSREHEAD
+2 NEW APPTLIST,NODE,OUTPXENC,IEN,PRV,PRVLIST,FTRLIST,DATE,ENCOUNTER,I,YSVISIT,NIDX,STATUS,PREFS,OPCUT
+3 NEW PATTYP
+4 NEW SAFSCNO,SAFSCYES,CSRENEW,CSREUPD,SITES,HFCLIST,SAFREV
+5 SET NOW=$$NOW^XLFDT
+6 SET YSDT=$PIECE(NOW,".",1)
+7 DO HRINIT^YSBRPC(.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.CSREHEAD,.CSRENEW,.CSREUPD,.SITES)
+8 ;D GETLST^XPAR(.SAFHFC,"SYS","YSB SAFETY PLAN HF CATEGORY")
+9 ;D GETLST^XPAR(.SAFHEAD,"SYS","YSB SAFETY PLAN HEADER TEXT")
+10 ;D GETLST^XPAR(.SAFDCL,"SYS","YSB SAFETY PLAN DECLINE")
+11 ;D GETLST^XPAR(.CSREHFC,"SYS","YSB CSRE HF CATEGORY")
+12 ;D GETLST^XPAR(.CSREHEAD,"SYS","YSB CSRE HEADER TEXT")
+13 SET DATAOUT("high_risk_patient_profile","patient_record_flag",1,"flag_name")=""
+14 SET DATAOUT("high_risk_patient_profile","patient_record_flag",1,"review_date")=""
+15 SET DATAOUT("high_risk_patient_profile","patient_record_flag",1,"due/overdue")=""
+16 SET DATAOUT("high_risk_patient_profile","patient_record_flag",1,"prf_actions")=""
+17 SET DATAOUT("high_risk_patient_profile","patient_record_flag",1,"action_date")=""
+18 SET (HRRVWDT,DHRR)=0
+19 SET (PRFNAME,PRFIEN,IDX)=0
FOR
SET PRFNAME=$ORDER(^DGPF(26.15,"B",PRFNAME))
if PRFNAME']""
QUIT
Begin DoDot:1
+20 NEW PRFIEN,RSLT,PRFDATA,HISTIDX,LSTHIST,PRFACT,NXTHIDX,NXTHDT
+21 SET PRFIEN=$ORDER(^DGPF(26.15,"B",PRFNAME,""))
+22 SET RSLT=$$GETINF^DGPFAPIH(DFN,PRFIEN_";DGPF(26.15,","","","PRFDATA")
+23 IF RSLT=0
QUIT
+24 SET LSTHIST=$ORDER(PRFDATA("HIST",""),-1)
+25 SET HISTIDX="A"
FOR
SET HISTIDX=$ORDER(PRFDATA("HIST",HISTIDX),-1)
if 'HISTIDX
QUIT
Begin DoDot:2
+26 SET IDX=IDX+1
+27 SET PRFACT=$PIECE(PRFDATA("HIST",HISTIDX,"ACTION"),U,2)
+28 SET NXTHIDX=$ORDER(PRFDATA("HIST",HISTIDX))
+29 ;I NXTHIDX]"" S NXTHDT=$P($P($G(PRFDATA("HIST",NXTHIDX,"DATETIME")),U,2),"@")
SET NXTHDT="UNK"
+30 SET DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"flag_name")=PRFNAME
+31 IF $PIECE(PRFDATA("REVIEWDT"),U,2)=""
SET $PIECE(PRFDATA("REVIEWDT"),U,2)="N/A"
+32 ;Need to review this later
SET DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"review_date")=$SELECT(HISTIDX=LSTHIST:$PIECE(PRFDATA("REVIEWDT"),U,2),PRFACT="INACTIVATE":"N/A",1:NXTHDT)
+33 ;save the High Risk dates for later use
IF PRFIEN=2
Begin DoDot:3
+34 IF $$FMTH^XLFDT($PIECE(PRFDATA("REVIEWDT"),U,1),1)'>DHRR
QUIT
+35 SET HRRVWDT=$PIECE(PRFDATA("REVIEWDT"),U,1)
SET DHRR=$$FMTH^XLFDT($PIECE(PRFDATA("REVIEWDT"),U,1),1)
End DoDot:3
+36 SET DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"due/overdue")=$SELECT(HISTIDX=LSTHIST:$$GETDUE^YSBWHIGH($PIECE(PRFDATA("REVIEWDT"),U),YSDT),PRFACT="INACTIVATE":"N/A",1:"UNK")
+37 SET DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"prf_actions")=PRFACT
+38 SET DATAOUT("high_risk_patient_profile","patient_record_flag",IDX,"action_date")=$PIECE($PIECE(PRFDATA("HIST",HISTIDX,"DATETIME"),U,2),"@")
End DoDot:2
End DoDot:1
+39 ; scheduled appointments
+40 KILL ^TMP($JOB,"SDAMA301")
+41 NEW FROMTO
+42 ;S FROMTO=91
+43 SET FROMTO=365
+44 SET YSDARRAY(1)=$$FMADD^XLFDT(YSDT,-FROMTO)_";"_$$FMADD^XLFDT(YSDT,FROMTO)
+45 SET YSDARRAY(3)="R;I;NS;NSR;CC;CCR;CP;CPR;NT;"
+46 SET YSDARRAY(4)=DFN
+47 SET YSDARRAY("FLDS")="1;2;12;13;18;22"
+48 SET YSDARRAY("SORT")="P"
+49 SET SDCOUNT=$$SDAPI^SDAMA301(.YSDARRAY)
+50 MERGE APPTLIST=^TMP($JOB,"SDAMA301",DFN)
+51 ;add ^SCE("ADFN" loop to detect Outpatient Encounters with no visit. These will be marked as unscheduled
+52 SET (PIDX,FIDX)=0
+53 SET SDTIME=$$FMADD^XLFDT(YSDT,-FROMTO-1)
SET OPCUT=$$FMADD^XLFDT(YSDT,FROMTO)
+54 FOR
SET SDTIME=$ORDER(^SCE("ADFN",DFN,SDTIME))
if 'SDTIME!(SDTIME>OPCUT)
QUIT
Begin DoDot:1
+55 ;already got this visit, must be scheduled
IF $DATA(APPTLIST(SDTIME))
QUIT
+56 SET OUTPXENC=$ORDER(^SCE("ADFN",DFN,SDTIME,0))
+57 SET NODE=^SCE(OUTPXENC,0)
+58 SET APPTLIST(SDTIME)=SDTIME_U_$PIECE(NODE,U,4)_";"_$$GET1^DIQ(44,$PIECE(NODE,U,4),.01)_"^^^^^^^^^^"_OUTPXENC_U_$PIECE(NODE,U,3)_";"_$$GET1^DIQ(40.7,$PIECE(NODE,U,3),1)_"^^^^^4;UV^^^^;;WALK-IN"
End DoDot:1
+59 ; split appointments into past and previous
+60 ;sort previous appointments by reverse date
+61 SET SDTIME=NOW-.000001
+62 FOR
SET SDTIME=$ORDER(APPTLIST(SDTIME),-1)
if 'SDTIME
QUIT
Begin DoDot:1
+63 ;not ED or MH clinic - delete
IF '$$CHKCLIN(APPTLIST(SDTIME))
KILL APPTLIST(SDTIME)
QUIT
+64 ;in the future, possible for an appt later today
IF $PIECE(APPTLIST(SDTIME),U,22)="11;FUTURE;FUTURE"
QUIT
+65 SET PIDX=PIDX+1
+66 SET PRVLIST(PIDX)=APPTLIST(SDTIME)
+67 KILL APPTLIST(SDTIME)
End DoDot:1
+68 ;sort future appointments - all previous appts are deleted
+69 SET SDTIME=0
FOR
SET SDTIME=$ORDER(APPTLIST(SDTIME))
if 'SDTIME
QUIT
Begin DoDot:1
+70 IF '$$CHKCLIN(APPTLIST(SDTIME))
QUIT
+71 SET FIDX=FIDX+1
+72 SET FTRLIST(FIDX)=APPTLIST(SDTIME)
End DoDot:1
+73 ; handle previous appointments
+74 NEW PSTAT
+75 SET PIDX=0
FOR
SET PIDX=$ORDER(PRVLIST(PIDX))
if 'PIDX
QUIT
Begin DoDot:1
+76 SET NIDX=0
+77 SET NODE=PRVLIST(PIDX)
+78 SET STATUS=$PIECE(NODE,U,22)
SET PSTAT=$PIECE(STATUS,";",3)
+79 ; also removes " & AUTO-REBOOK"
SET STATUS=$PIECE($PIECE($PIECE(NODE,U,22),";",3)," &")
+80 ;No positive state of this encounter.
IF STATUS["NO ACTION TAKEN"
IF (PSTAT'["CHECKED")
QUIT
+81 ;Inpatient No action taken
IF STATUS["NO ACT TAKN"
IF (PSTAT'["CHECKED")
QUIT
+82 ;For Checked In/Checked Out replace NO ACTION TAKEN status
IF PSTAT["CHECKED"
SET STATUS=PSTAT
+83 SET SDTIME=+NODE
+84 SET ENCOUNTER=$PIECE(NODE,U,12)
+85 SET YSVISIT=""
IF ENCOUNTER
SET YSVISIT=$PIECE(^SCE(ENCOUNTER,0),U,5)
+86 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"location")=$PIECE($PIECE(NODE,U,2),";",2)
+87 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"date")=$$FMTE^XLFDT(SDTIME,5)
+88 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"provider")="N/A"
+89 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"status")=$PIECE($PIECE(NODE,U,22),";",3)
+90 IF YSVISIT
Begin DoDot:2
+91 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"status")="COMPLETED"
+92 IF $PIECE(NODE,U,18)="4;UV"
SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"status")="WALK-IN"
+93 ;DBIA 2316
SET (IEN,PRV)=""
FOR
SET IEN=$ORDER(^AUPNVPRV("AD",YSVISIT,IEN))
if 'IEN
QUIT
Begin DoDot:3
+94 SET NODE=^AUPNVPRV(IEN,0)
+95 IF $PIECE(NODE,U,4)="P"
SET PRV=+NODE
+96 QUIT
End DoDot:3
if PRV
QUIT
+97 IF PRV
Begin DoDot:3
+98 SET PRV=$$GET1^DIQ(200,PRV_",",.01)
+99 ;add a space between last and first name so GUI column can wrap
SET $PIECE(PRV,",",2)=" "_$PIECE(PRV,",",2)
+100 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"provider")=PRV
End DoDot:3
+101 KILL ^TMP("TIULIST",$JOB)
+102 DO NOTES^TIUSRVLV("",YSVISIT)
+103 ;loop through ^TMP("TIULIST",$J) and set TIUDA to each value
+104 SET DATE=""
FOR
SET DATE=$ORDER(^TMP("TIULIST",$JOB,DATE))
if 'DATE
QUIT
Begin DoDot:3
+105 SET I=""
FOR
SET I=$ORDER(^TMP("TIULIST",$JOB,DATE,I))
if 'I
QUIT
Begin DoDot:4
+106 ;only completed (signed) notes.
IF $PIECE(^TMP("TIULIST",$JOB,DATE,I),U,7)'="completed"
QUIT
+107 SET NIDX=NIDX+1
+108 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"notes",NIDX,"docID")=+^TMP("TIULIST",$JOB,DATE,I)
+109 SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"notes",NIDX,"docName")=$PIECE(^TMP("TIULIST",$JOB,DATE,I),U,2)
End DoDot:4
End DoDot:3
End DoDot:2
+110 IF 'NIDX
SET DATAOUT("high_risk_patient_profile","previous_activity",PIDX,"notes")=""
End DoDot:1
+111 ; handle future appointments
+112 SET FIDX=0
FOR
SET FIDX=$ORDER(FTRLIST(FIDX))
if 'FIDX
QUIT
Begin DoDot:1
+113 SET NODE=FTRLIST(FIDX)
+114 SET SDTIME=+NODE
+115 SET DATAOUT("high_risk_patient_profile","future_appointments",FIDX,"location")=$PIECE($PIECE(NODE,U,2),";",2)
+116 SET DATAOUT("high_risk_patient_profile","future_appointments",FIDX,"date")=$$FMTE^XLFDT(SDTIME,5)
End DoDot:1
+117 KILL ^TMP($JOB,"SDAMA301")
+118 IF '$DATA(DATAOUT("high_risk_patient_profile","previous_activity"))
SET DATAOUT("high_risk_patient_profile","previous_activity",1)=""
+119 IF '$DATA(DATAOUT("high_risk_patient_profile","future_appointments"))
SET DATAOUT("high_risk_patient_profile","future_appointments",1)=""
+120 ; review status
+121 NEW DSTAT
+122 ;Will return INPT if still an inpatient.
SET PATTYP=$$MHDCDT^YSBWHIG2(DFN)
if PATTYP'="INPT"
SET PATTYP=""
+123 SET DSTAT=$$DONE7^YSBWHIGH(DFN,YSDT,.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES)
+124 SET DATAOUT("high_risk_patient_profile","review_status","review_due")=$$GETDUE^YSBWHIGH(HRRVWDT,YSDT)
+125 SET DATAOUT("high_risk_patient_profile","review_status","on_track")=$$ONTRK^YSBWHIGH(DFN,"")
+126 SET DATAOUT("high_risk_patient_profile","review_status","done_in_7")=DSTAT
+127 SET DATAOUT("high_risk_patient_profile","review_status","done_in_7_number")=$$DONENUM(NOW)
+128 SET DATAOUT("high_risk_patient_profile","review_status","inpatient")=PATTYP
+129 ; safety plan
+130 NEW TIUFND
+131 SET TIUINVDT=0
SET IDX=0
SET TIUFND=1
+132 DO SAFLST^YSBWHIGH(.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.HFCLIST)
+133 FOR
SET DATEFOUND=$$FINDDOC^YSBWHIGH(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,.TIUIDX,TIUFND)
if 'TIUINVDT
QUIT
Begin DoDot:1
+134 SET IDX=IDX+1
+135 SET DATAOUT("high_risk_patient_profile","safety_plan",IDX,"docID")=TIUIDX
+136 IF $$SAFDECL^YSBWHIGH(DFN,TIUINVDT)
SET DATAOUT("high_risk_patient_profile","safety_plan",IDX,"date")="Declined"
QUIT
+137 SET DATAOUT("high_risk_patient_profile","safety_plan",IDX,"date")=$$FMTE^XLFDT($PIECE(DATEFOUND,"."),5)
End DoDot:1
+138 IF 'IDX
SET DATAOUT("high_risk_patient_profile","safety_plan",1,"date")="Not Done"
+139 ;CSRE
+140 KILL HFCLIST
+141 DO CSRELST^YSBWHIGH(.CSRENEW,.CSREUPD,.HFCLIST)
+142 SET TIUINVDT=0
SET IDX=0
FOR
SET DATEFOUND=$$FINDDOC^YSBWHIGH(DFN,.TIUINVDT,.HFCLIST,.CSREHEAD,.TIUIDX,TIUFND)
if 'TIUINVDT
QUIT
Begin DoDot:1
+143 SET IDX=IDX+1
+144 SET DATAOUT("high_risk_patient_profile","CSRE",IDX,"date")=$$FMTE^XLFDT($PIECE(DATEFOUND,"."),5)
+145 SET DATAOUT("high_risk_patient_profile","CSRE",IDX,"docID")=TIUIDX
End DoDot:1
+146 IF 'IDX
SET DATAOUT("high_risk_patient_profile","CSRE",1,"date")="Not Done"
+147 DO ENCODE^YSBJSON("DATAOUT","JSONOUT","ERRARY")
+148 KILL ^TMP($JOB,"SDAMA301")
+149 KILL ^TMP("TIULIST",$JOB)
+150 QUIT
WEBPROF(ARGS,RESULTS) ; MHA Web call for HRPTPROF
+1 NEW DFN,JSONOUT
+2 SET DFN=$GET(ARGS("dfn"))
+3 IF DFN=""
DO SETERROR^YTQRUTL(404,"Patient ID not sent.")
QUIT
+4 DO HRPTPROF(.JSONOUT,DFN)
+5 DO TOTMP^YSBRPC(.JSONOUT)
+6 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+7 QUIT
+8 ;
DONENUM(TDT) ; Calculate the number of days for Done in 7
+1 NEW ACTDT,II,LST,RCNT,DIFF
+2 NEW NMSTR,NMARR,ACTSTR,ACTARR,LSTNM
+3 SET NMARR("HIGH RISK FOR SUICIDE")=""
+4 SET NMARR("BEHAVIORAL")=""
+5 SET NMARR("MISSING PATIENT")=""
+6 SET ACTARR("REACTIVATE")=""
+7 SET ACTARR("CONTINUE")=""
+8 SET ACTARR("NEW ASSIGNMENT")=""
+9 SET RCNT=0
SET LST=0
SET LSTNM=""
+10 SET II=0
FOR
SET II=$ORDER(DATAOUT("high_risk_patient_profile","patient_record_flag",II))
if II=""
QUIT
Begin DoDot:1
+11 SET NMSTR=$GET(DATAOUT("high_risk_patient_profile","patient_record_flag",II,"flag_name"))
+12 IF NMSTR]""
SET LSTNM=NMSTR
+13 ;Quit if we are not in a sequence of NEW/REACTIVATE/CONTINUE the Patient Record flags of interest
IF LSTNM]""
if '$DATA(NMARR(LSTNM))
QUIT
+14 SET ACTSTR=$GET(DATAOUT("high_risk_patient_profile","patient_record_flag",II,"prf_actions"))
+15 IF ACTSTR]""
if '$DATA(ACTARR(ACTSTR))
QUIT
+16 SET RCNT=$GET(DATAOUT("high_risk_patient_profile","patient_record_flag",II,"action_date"))
+17 SET RCNT=$$ETF(RCNT)
+18 IF RCNT>LST
SET LST=RCNT
End DoDot:1
+19 SET LST=$$FMTH^XLFDT(LST,1)
SET LST=LST+7
SET LST=$$HTFM^XLFDT(LST,1)
+20 SET DIFF=$$FMDIFF^XLFDT(LST,TDT,1)
+21 QUIT DIFF
ETF(X) ; External to Fileman format
+1 NEW %DT,Y
SET X=$GET(X)
SET %DT="PST"
DO ^%DT
SET X=Y
if +X'>0
SET X=""
QUIT X
+2 QUIT
CHKCLIN(NODE) ;
+1 NEW STOPCODE
+2 SET STOPCODE=$PIECE($PIECE(NODE,U,13),";",2)
+3 ;ED clinic
IF STOPCODE=130
QUIT 1
+4 ;MH clinic
IF (STOPCODE>499)
IF (STOPCODE<600)
QUIT 1
+5 ;not ED or MH clinic
QUIT 0
+6 ;
GETNOTE(JSONOUT,YSTIUDA) ;
+1 NEW DATAOUT,YSTEXT
+2 ;note text
+3 ;TEXT just contains the string "^TMP("TIUVIEW",TIUDA)"
DO TGET^TIUSRVR1(.YSTEXT,YSTIUDA)
+4 SET IDX=0
FOR
SET IDX=$ORDER(@YSTEXT@(IDX))
if 'IDX
QUIT
SET DATAOUT("note_text",IDX,"line")=@YSTEXT@(IDX)
+5 IF IDX=0
SET DATAOUT("note_text",1)=""
+6 DO ENCODE^YSBJSON("DATAOUT","JSONOUT","ERRARY")
+7 QUIT
WEBNOTE(ARGS,RESULTS) ;MHA Web call for GETNOTE
+1 NEW YSTIUDA,JSONOUT
+2 SET YSTIUDA=$GET(ARGS("noteId"))
+3 IF YSTIUDA=""
DO SETERROR^YTQRUTL(404,"Note ID not sent")
QUIT
+4 DO GETNOTE(.JSONOUT,YSTIUDA)
+5 DO TOTMP^YSBRPC(.JSONOUT)
+6 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+7 QUIT
+8 ;
GETRPRT(JSONOUT,ADMIN) ;
+1 NEW REPORT,DATAOUT,ERRARY
+2 KILL ^TMP("YTQRERRS",$JOB)
+3 DO BLDRPT^YTQRRPT(.REPORT,ADMIN)
+4 IF $DATA(REPORT)
Begin DoDot:1
+5 NEW IDX
+6 SET IDX=0
FOR
SET IDX=$ORDER(REPORT(IDX))
if 'IDX
QUIT
Begin DoDot:2
+7 SET DATAOUT("report",IDX,"line")=REPORT(IDX)
End DoDot:2
End DoDot:1
+8 IF '$DATA(REPORT)
SET DATAOUT("report",1,"line")="<no text>"
+9 IF $DATA(^TMP("YTQRERRS",$JOB,1,"error"))
Begin DoDot:1
+10 SET DATAOUT("report",1,"line")=^TMP("YTQRERRS",$JOB,1,"error","code")
+11 SET DATAOUT("report",2,"line")=^TMP("YTQRERRS",$JOB,1,"error","message")
+12 SET DATAOUT("report",3,"line")=^TMP("YTQRERRS",$JOB,1,"error","errors",1,"message")
End DoDot:1
+13 DO ENCODE^YSBJSON("DATAOUT","JSONOUT","ERRARY")
+14 KILL ^TMP("YTQRERRS",$JOB)
+15 QUIT
WEBRPRT(ARGS,RESULTS) ;
+1 NEW REPORT,DATAOUT,ERRARY,ADMIN,JSONOUT
+2 SET ADMIN=$GET(ARGS("adminId"))
+3 IF ADMIN=""
DO SETERROR^YTQRUTL(404,"Admin ID not sent.")
QUIT
+4 DO GETRPRT(.JSONOUT,ADMIN)
+5 DO TOTMP^YSBRPC(.JSONOUT)
+6 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+7 QUIT
