YSBWHIGH ;SLC/DJE - MHA DASHBOARD ; Apr 01, 2021@16:33
;;5.01;MENTAL HEALTH;**202,208,221**;Dec 30, 1994;Build 11
;
; Routine retrieves high risk widget data
;
; Reference to ^AUPNVHF in ICR #3084
; Reference to ^AUTTHF in ICR #4295
; Reference to ^DGPM("ATID1") in ICR #1378
; Reference to ^DGPM in ICR #2090
; Reference to ^PXRMINDX in ICR #4229
; Reference to SDAMA301 in ICR #4433
; Reference to DGPFAPIH in ICR #4903
; Reference to DGPFAPI in ICR #3860
Q
HIGHRISK(DATAOUT) ;
N HRPATS,HRCOUNT,HRIDX,DFN,PRFFOUND,CRITERIA,YSDT,DONE7,NOW,DCDT,INSTDATA,PRFDATA,PATDATA
N SAFHEAD,SAFDCL,SAFREV,SAFSCNO,SAFSCYES,CSREHEAD,CSRENEW,CSREUPD,SITES
N HRFND
N LSTSAF,DONE7,LSTCSRE,SUBS,CSRETITL,CSRENEW,CSREUPD
N $ES,$ET S $ET="D ERRHND^YSBWHIGH" ; quit from ERRHND if error
S NOW=$$NOW^XLFDT()
S YSDT=$P(NOW,".",1)
D HRINIT^YSBRPC(.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.CSREHEAD,.CSRENEW,.CSREUPD,.SITES)
S HRCOUNT=$$GETLST^DGPFAPIH("2;DGPF(26.15,","","","HRPATS")
I 'HRCOUNT Q
S HRIDX=+$O(DATAOUT("data",""),-1)
S HRFND=0
S SUBS="YSB-DASH-"_YSDT
S DFN=0 F S DFN=$O(HRPATS(DFN)) Q:'DFN D
.S DCDT=""
.K PRFDATA,PATDATA,INSTDATA
.S PRFFOUND=$$PRFDATA(DFN,.SITES,.PRFDATA)
.Q:'PRFFOUND ;no PRFDATA found
.S HRFND=1
.S HRIDX=HRIDX+1
.S DATAOUT("data",HRIDX,"widget")="HIGH RISK"
.S DATAOUT("data",HRIDX,"dfn")=DFN
.S DCDT=$$MHDCDT^YSBWHIG2(DFN)
.S DATAOUT("data",HRIDX,"patient_name")=$P(HRPATS(DFN,0),U)
.S DATAOUT("data",HRIDX,"patient_prf")="YES" ;All HIGH RISK PRFs
.S DATAOUT("data",HRIDX,"division")=$P(PRFDATA("OWNER"),U,2) ;all HIGH RISK PRFs
.S DATAOUT("data",HRIDX,"prf_review")=$$FMTE^XLFDT(+PRFDATA("REVIEWDT"),5)
.S DATAOUT("data",HRIDX,"due_overdue")=$$GETDUE(+PRFDATA("REVIEWDT"),YSDT)
.S DATAOUT("data",HRIDX,"last_discharge_date")=$S(+DCDT:$$FMTE^XLFDT(DCDT,5),1:DCDT)
.S DATAOUT("data",HRIDX,"last_mh_visit")=$$MHLSTVST^YSBWHIG2(DFN,NOW)
.S DATAOUT("data",HRIDX,"next_mh_appt_date")=$$MHNXTAPP(DFN,YSDT)
.S DATAOUT("data",HRIDX,"on_track")=$$ONTRK(DFN,DCDT,YSDT)
.S LSTSAF=$$MHLSTSAF(DFN,.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES)
.S DONE7=$$DONE7(DFN,YSDT,.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES)
.S LSTCSRE=$$LASTCSRE(DFN,.CSRENEW,.CSREUPD,.CSREHEAD)
.S DATAOUT("data",HRIDX,"last_mh_safety_plan")=LSTSAF
.S DATAOUT("data",HRIDX,"done_in_7")=DONE7
.S DATAOUT("data",HRIDX,"last_csra")=LSTCSRE
.D BLDINST^YSBWHIG2(.INSTDATA,DFN,42,YSDT,"phq9") ;PHQ9
.D BLDRSL^YSBWHIG2(.INSTDATA,DFN,42,YSDT,"phq9_i9",3382) ;PHQ9 q9
.D CSSRS(.INSTDATA,DFN,YSDT) ;C-SSRS
.M DATAOUT("data",HRIDX)=INSTDATA
.;send px information in loaddb call
.D PATIENT^YSBDD1(DFN,.PATDATA)
.M DATAOUT("data",HRIDX)=PATDATA
Q
;
ERRHND ; Handle errors & clear stack
N ERROR S ERROR=$$EC^%ZOSV ; get error
I ERROR["ZTER" D UNWIND^%ZTER ; ignore errors clearing stack
N $ET S $ET="D ^%ZTER,UNWIND^%ZTER" ; avoid loop on add'l error
D ^%ZTER ; rec fail in error trap
S DATAOUT("data",1)="" ; set to null for JSON
D UNWIND^%ZTER ; clear stack
Q
PRFDATA(DFN,SITES,PRFDATA) ;
N PRFFULL,I,DONE,PRFSTAT
S PRFSTAT=$$GETACT^DGPFAPI(DFN,"PRFFULL")
S DONE=0
S I=0 F S I=$O(PRFFULL(I)) Q:'I D Q:DONE
.Q:$P(PRFFULL(I,"FLAG"),U)'="2;DGPF(26.15,"
.;Q:'$D(SITES(+PRFFULL(I,"OWNER"))) ;only high risk flags from user's site
.S DONE=1
.M PRFDATA=PRFFULL(I)
Q DONE
;
GETDUE(RVDT,YSDT) ;calculate if review is due
I 'RVDT Q "N/A"
Q $$FMDIFF^XLFDT(RVDT,YSDT)
;
MHNXTAPP(DFN,YSDT) ;Get next MH APPT up to a year from today.
N YSDARRAY,APPTLIST,APPTDT,SDCOUNT,SDTIME,DONE,NOW,NODE,PSTAT,STATUS
S NOW=$$NOW^XLFDT()
K ^TMP($J,"SDAMA301")
S YSDARRAY(1)=NOW_";"_$$FMADD^XLFDT(YSDT,365)
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)
K ^TMP($J,"SDAMA301",DFN)
S DONE=0,APPTDT=""
S SDTIME=0 F S SDTIME=$O(APPTLIST(SDTIME)) Q:'SDTIME!DONE D
.I '$$CHKCLIN^YSBDD1(APPTLIST(SDTIME)) Q
.S NODE=APPTLIST(SDTIME)
.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="11;FUTURE;FUTURE" Q ;in the future, possible for an appt later today
.I STATUS["CANCELLED" Q ;Cancelled by Clinic or Cancelled by Patient
.I STATUS["NO-SHOW" Q ;No show
.S DONE=1,APPTDT=SDTIME
I 'APPTDT Q "Not Scheduled"
Q $$FMTE^XLFDT($P(APPTDT,"."),5)
;
MHLSTSAF(DFN,SAFHEAD,SAFDCL,SAFREV,SAFSCNO,SAFSCYES) ;get mh last safety plan date
N DATEFOUND,DECLINE,TIUINVDT,TIUFND
N HFCLIST
S TIUINVDT=0,TIUFND=3 ;=3 means look through the TIU DOCUMENTS to check STATUS but don't get the contents
D SAFLST(.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.HFCLIST)
S DATEFOUND=$$FINDDOC(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,"",TIUFND)
I DATEFOUND="" Q "NOT DONE"
I $$SAFDECL(DFN,TIUINVDT,.SAFDCL) Q "DECLINED" ;12/5/19 added "D"
I DATEFOUND Q $$FMTE^XLFDT($P(DATEFOUND,"."),5)
Q "ERROR"
;
FINDDOC(DFN,TIUINVDT,HFCLIST,HDRLIST,TIURET,TIUFND) ;TIUINVDT is updated and returned by reference to permit recursion or use in V HF indexes
N IDX,DATEFOUND,YSCLASS,HEADTXT,VSTFOUND,YSTIUDAT,TIU,HF,HFCNT
N LOWER,UPPER,DSCR,DOCFND
S LOWER="abcdefghijklmnopqrstuvwxyz"
S UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
S TIUFND=$G(TIUFND)
;Set up Document Class to find TIU Note below
S DSCR="I $P(^(0),U,4)=""CL""" ;Screen on CLASS type TIU DOCUMENT DEFs
S YSCLASS=$$FIND1^DIC(8925.1,"","B","CLINICAL DOCUMENTS",,,.DSCR)
; the note that created the HFs might not be signed and we'll need to search again
F D Q:TIURET Q:'DATEFOUND
.;DBIA #4295 loop through HFs of HF categories
.S (VSTFOUND,TIURET)=""
.S DATEFOUND=9999999,DOCFND=0
. S IDX=0 F S IDX=$O(HFCLIST(IDX)) Q:IDX="" D
..S HFCNT="" F S HFCNT=$O(HFCLIST(IDX,HFCNT)) Q:'HFCNT D
...S HF=HFCLIST(IDX,HFCNT)
...N HFDT
...S HFDT=$O(^AUPNVHF("AA",DFN,HF,TIUINVDT)) ;find last date since input date ;DBIA #3084
...I HFDT="" Q
...I HFDT<DATEFOUND S DATEFOUND=HFDT,VSTFOUND=$O(^AUPNVHF("AA",DFN,HF,HFDT,""))
.I DATEFOUND=9999999 S (DATEFOUND,TIUINVDT)="" Q ;nothing found
.S YSTIUDAT=DATEFOUND ;outpatient visits are like this
.;inpatient visits are like this
.S VSTFOUND=$P(^AUPNVHF(VSTFOUND,0),U,3) ;go from v health factors file to visit file DBIA 2316
.N VSTDTM S VSTDTM=$P(^AUPNVSIT(VSTFOUND,0),U) ;Save Visit Date/Time for TIU Match
.S VSTFOUND=$P(^AUPNVSIT(VSTFOUND,0),U,12) ;does the visit have a parent visit? The TIU will be filed against that date. DBIA 2028
.I VSTFOUND S YSTIUDAT=9999999-$P((+^AUPNVSIT(VSTFOUND,0)),".") ;get the visit date
.;return inversed date in reference variable, function return is regular date
.S TIUINVDT=DATEFOUND,DATEFOUND=9999999-DATEFOUND
.I TIUFND=0 S TIURET=999999999 Q ;Don't find TIU DOCUMENT
.K ^TMP("TIU",$J) ;Now find TIU note
.D VISIT^TIULAPIC(DFN,YSCLASS,YSTIUDAT-0.1,YSTIUDAT,"",1) ;DBIA #3519
.N REFDT,TVDT
.S TIU="" F S TIU=$O(^TMP("TIU",$J,YSTIUDAT,TIU),-1) Q:'TIU D Q:$G(TIURET)
..I ^TMP("TIU",$J,YSTIUDAT,TIU,.05,"I")'=7 Q ;Quit if not a completed (signed) note
..;I TIUFND=3 S DOCFND=1,TIURET=999999999 Q ;For TIUFND=3, just need to know if signed TIU DOC;Keep flag for now but still have to find exact note
..S REFDT=$P($G(^TMP("TIU",$J,YSTIUDAT,TIU,1301,"I")),".")
..S TVDT=$P($G(^TMP("TIU",$J,YSTIUDAT,TIU,.07,"I")),".")
..Q:(REFDT'=$P(VSTDTM,"."))&(TVDT'=$P(VSTDTM,"."))
..N HEADER
..S HEADER=$G(^TMP("TIU",$J,YSTIUDAT,TIU,"TEXT",1,0))_$G(^TMP("TIU",$J,YSTIUDAT,TIU,"TEXT",2,0))_$G(^TMP("TIU",$J,YSTIUDAT,TIU,"TEXT",3,0))
..F IDX=1:1:HDRLIST S HEADTXT=$P(HDRLIST(IDX),U,2) D Q:$G(TIURET)
...I (HEADER[HEADTXT)!($TR(HEADER,LOWER,UPPER)[HEADTXT) S TIURET=TIU I TIUFND=3 S DOCFND=1,TIURET=999999999
I TIUFND=3 I DOCFND=0 S DATEFOUND="" ;Did not find Signed TIU DOC
I TIURET=999999999 K TIURET ;Document not needed
K ^TMP("TIU",$J)
Q DATEFOUND
;
SAFDECL(DFN,TIUINVDT,SAFDCL) ;was safety plan declined?
N DCLHF
I '$D(SAFDCL) Q 0 ;Must get the SAFDCL Parameter first.
I '$G(DFN) Q 0
I '$G(TIUINVDT) Q 0
S DCLHF=$P($G(SAFDCL(1)),U,2) I +DCLHF=0 Q 0
Q $D(^AUPNVHF("AA",DFN,DCLHF,TIUINVDT))
;
HRACTIVE(DFN) ;get activation details of high risk flag
N IDX,STOP,PRFDATA
I '$$GETINF^DGPFAPIH(DFN,"2;DGPF(26.15,","","","PRFDATA") Q "N/A" ;Get high risk data, if none quit
S IDX="",STOP=0 F S IDX=$O(PRFDATA("HIST",IDX),-1) Q:'IDX D Q:STOP
.I "1,3,4"[(+PRFDATA("HIST",IDX,"ACTION")) S STOP=1 ;if new assignment, reactivated, or inactivated then stop
I 'STOP Q "N/A" ;catch all
I (+PRFDATA("HIST",IDX,"ACTION"))=3 Q "N/A" ;inactive flag
Q +PRFDATA("HIST",IDX,"DATETIME") ;assigned or reactivated
;
DONE7(DFN,YSDT,SAFHEAD,SAFDCL,SAFREV,SAFSCNO,SAFSCYES) ;calculate done in 7
N DATEFOUND,DECLINE,TIUIDX,ACTIVATION,TIUINVDT,LASTDATE,FIRSTDATE,ADMISSION,DSCHGDT,INPT
N MVMT,DONE,TIUFND,INVDT
N ENDADMISS,DSCHGM,TRNSFRDT
N HFCLIST
S ACTIVATION=$$HRACTIVE(DFN),INPT=0
I ACTIVATION="N/A" Q "N/A"
S ACTIVATION=$P(ACTIVATION,".")
S LASTDATE=$$FMADD^XLFDT(ACTIVATION,8)
S FIRSTDATE=$$FMADD^XLFDT(ACTIVATION,-7)
;check to see if patient was inpatient at some point during 7 day period
S ADMISSION=9999999-LASTDATE
S ENDADMISS=9999999-FIRSTDATE
S DONE=0,MVMT="",DSCHGDT=""
F S ADMISSION=$O(^DGPM("ATID1",DFN,ADMISSION)) Q:ADMISSION=""!DONE!(ADMISSION>ENDADMISS) D
. S MVMT="" F S MVMT=$O(^DGPM("ATID1",DFN,ADMISSION,MVMT)) Q:MVMT="" D Q:DONE ;Find the last MH Admission
.. I $$ISMHMV(MVMT)=1 S DONE=1
I MVMT'="" D
. S DSCHGM=$P($G(^DGPM(MVMT,0)),U,17) ;make it the DC movement
. I DSCHGM="" S INPT=$$GET1^DIQ(405,MVMT,.01,"I") Q ;S INPT=1 Q ;Still an inpatient admitted before the 7 day cutoff
. S DSCHGDT=+^DGPM(DSCHGM,0) I DSCHGDT>LASTDATE S LASTDATE=$P(DSCHGDT,".") ;update lastdate to dc date if later
. I $P(DSCHGDT,".")=YSDT S INPT=DSCHGDT ;Allow Safety Plan to still be completed today
;Check transfers also but only if later than last MH discharge date
S (DONE,INVDT)=0,INVDT=(9999999-($G(LASTDATE)-.01))
F S INVDT=$O(^DGPM("ATID2",DFN,INVDT)) Q:(INVDT="")!(INVDT>ENDADMISS) D Q:(DONE=1) ;DBIA #1378
.N MVMT
.S MVMT="" F S MVMT=$O(^DGPM("ATID2",DFN,INVDT,MVMT)) Q:(MVMT="") D Q:(DONE=1) ;DBIA #1378
..N LOC,ADMMVMT,DCMVMT,XMVMT,TRNSCTN
..S LOC=$$GET1^DIQ(405,MVMT,.06,"I") ;DBIA #1378
..S TRNSCTN=$$GET1^DIQ(405,MVMT,.02,"I") ;find the transaction type, 2=TRANSFER ;DBIA #1378
..I $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY",TRNSCTN'=2 Q ;not a psychiatry service ward and not a TRANSFER ;DBIA #31
..S ADMMVMT=$$GET1^DIQ(405,MVMT,.14,"I") ;find admission to find discharge ;DBIA #1378
..S DCMVMT=$$GET1^DIQ(405,ADMMVMT,.17,"I") ;DBIA #2090
.. S XMVMT=DCMVMT
.. Q:DCMVMT=""&(TRNSCTN'=2) ;Don't let a null DCMVMT set the TRNSFRDT
.. S:TRNSCTN=2 XMVMT=MVMT ;If this is a TRANFER, set the Transfer date
..S TRNSFRDT=$$GET1^DIQ(405,XMVMT,.01,"I"),DONE=1 ;DBIA #1378
..I $$ISMHMV^YSBWHIGH(XMVMT)=1 D ;The Transfer was to an MH Location, need to Evaluate dates
... N XDSCHGM,XINPT,XDSCHGDT
... S XDSCHGM=$P($G(^DGPM(XMVMT,0)),U,17) ;See if there was a discharge
... I XDSCHGM="" S XINPT=$$GET1^DIQ(405,XMVMT,.01,"I") I XINPT>INPT S INPT=XINPT Q ;No Discharge, is this XFER later than any ADMISSIONS?
... S XDSCHGDT=$$GET1^DIQ(405,XDSCHGM,.01,"I") I XDSCHGDT>TRNSFRDT S TRNSFRDT=$P(XDSCHGDT,".") ;If the Discharge movement is after Transfer then update
I ($G(TRNSFRDT)>$G(DSCHGDT)),($G(TRNSFRDT)>INPT) S DSCHGDT=TRNSFRDT,INPT=0
I (DSCHGDT'=""),(DSCHGDT>LASTDATE) S DSCHGDT=$P(DSCHGDT,".",1),LASTDATE=$P(DSCHGDT,".")
;invert last date and search for safety plan
S DECLINE=""
I INPT'=0 S LASTDATE=YSDT ;If still an inpatient, look for all current Safety Plans
S TIUINVDT=9999999-LASTDATE,TIUINVDT=$P(TIUINVDT,".")-1,TIUINVDT=TIUINVDT_.9999999 ;Updated to be inclusive of Last Date.
K HFCLIST S TIUFND=3
D SAFLST(.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.HFCLIST)
S DATEFOUND=$$FINDDOC(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,.TIUIDX,TIUFND) ; find safety plan seven days from assignment
I DATEFOUND>=FIRSTDATE,$$SAFDECL(DFN,TIUINVDT,.SAFDCL) Q "DECLINED" ; Declined Safety plan in 7; 12/5/19 added "D"
I (DATEFOUND>=FIRSTDATE),(DATEFOUND<=INPT) Q "COMPLETED" ; Completed Safety plan in 7 for Inpatients
I DSCHGDT'="" I (DATEFOUND>=FIRSTDATE),(DATEFOUND<=DSCHGDT) Q "COMPLETED" ;Was an Inpatient but discharged
I (DATEFOUND>=FIRSTDATE),(DATEFOUND<LASTDATE) Q "COMPLETED" ; Completed Safety plan in 7
I INPT Q "PENDING" ; Still an inpatient, have until discharge
I YSDT<LASTDATE Q "PENDING" ; Still time to complete
S TIUINVDT=0,DATEFOUND=0
S DATEFOUND=$$FINDDOC(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,"",TIUFND) ; find any safety plan
I DATEFOUND<FIRSTDATE S DATEFOUND=0
I DATEFOUND'=0 I $$SAFDECL(DFN,TIUINVDT,.SAFDCL) Q "DECLINED" ; Declined Safety plan
I DATEFOUND>=LASTDATE Q "DONE LATE"
Q "OVERDUE"
ISMHMV(MVMT) ;
N LOC,ADMMVMT,DCMVMT,ISMH
I MVMT="" Q 0
S ISMH=1
S LOC=$$GET1^DIQ(405,MVMT,.06,"I") ;DBIA #1378
S TRNSCTN=$$GET1^DIQ(405,MVMT,.02,"I") ;find the transaction type, 2=TRANSFER ;DBIA #1378
I $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY" S ISMH=0 ;,TRNSCTN'=2 Q ;not a psychiatry service ward and not a TRANSFER ;DBIA #31
Q ISMH
;
ONTRK(DFN,DCDT,YSDT) ;
N ONTRK,BEGDT,ENDDT,I,LOCATIONS,APPTCNT,LIST,IDX,STS
I 'DCDT S DCDT=$$MHDCDT^YSBWHIG2(DFN)
I 'DCDT Q "N/A"
I '$G(YSDT) S YSDT=$P($$NOW^XLFDT,".")
S ONTRK="NO",BEGDT=DCDT,ENDDT=$$FMADD^XLFDT(BEGDT,30),APPTCNT=0
D VST^ORWCV(.LIST,DFN,BEGDT,ENDDT_".2359",1)
I '$D(LIST(4)) Q "NO" ;not enough results
S (APPTCNT,IDX)=0 F S IDX=$O(LIST(IDX)) Q:('IDX)!(APPTCNT>=4) D
.N APPTDT
.I '$$CHKCLIN^YSBRPC($P($P(LIST(IDX),U),";",3)) Q
.;if appointment in the past, then only count if we have outpx encounter
.S APPTDT=$P($P(LIST(IDX),U),";",2)
.I ($P($P(LIST(IDX),U),";",1)="A"),(APPTDT<YSDT) Q:'$P($G(^DPT(DFN,"S",APPTDT,0)),U,20)
.S STS=$P(LIST(IDX),U,4) Q:STS["CANCEL"
.S APPTCNT=APPTCNT+1
I APPTCNT>=4 Q "YES"
Q "NO"
;
LASTCSRE(DFN,CSRENEW,CSREUPD,CSREHEAD) ;
N DATEFOUND,HFCLIST,TIUFND
S TIUFND=3
D CSRELST(.CSRENEW,.CSREUPD,.HFCLIST)
S DATEFOUND=$$FINDDOC(DFN,0,.HFCLIST,.CSREHEAD,"",TIUFND)
I DATEFOUND="" Q "NOT DONE"
Q $$FMTE^XLFDT(DATEFOUND,5)
;
CSSRS(INSTDATA,DFN,YSDT) ;
N ADMDT,CUTOFF,COUNT,RESULTS
S CUTOFF=$$FMADD^XLFDT(YSDT,-90),COUNT=0
;Get the latest ten results from the last 90 days
;Need to loop from latest to last
;S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,228,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,228,ADMDT),-1) Q:'ADMDT Q:COUNT=10 D ;Remove 90 day cutoff
.N ADMIN
.S ADMIN=0 F S ADMIN=$O(^PXRMINDX(601.84,"PI",DFN,228,ADMDT,ADMIN)) Q:'ADMIN D
..N RESULT,STOP,SCORE
..S SCORE="Negative"
..S (STOP,RESULT)=0 F S RESULT=$O(^YTT(601.92,"AC",ADMIN,RESULT)) Q:'RESULT Q:STOP D
...N N0
...S N0=^YTT(601.92,RESULT,0)
...I ("Ques3,Ques4,Ques5,Ques8"[$P(N0,U,3)),($P(N0,U,4)=1) S SCORE="Positive",STOP=1 ;if questions 3,4,5 or 8 are 1 then positive.
..S COUNT=COUNT+1
..S RESULTS(ADMDT,ADMIN)=SCORE
I COUNT=0 D Q
.S INSTDATA("c_ssrs",1,"count")=1
.S INSTDATA("c_ssrs",1,"date")="N/A"
.S INSTDATA("c_ssrs",1,"score")="N/A"
;Now need to loop from last to latest
S COUNT=0 ;reuse count to index the JSON global
S ADMDT="" F S ADMDT=$O(RESULTS(ADMDT)) Q:'ADMDT D
.S ADMIN=0 F S ADMIN=$O(RESULTS(ADMDT,ADMIN)) Q:'ADMIN D
..S COUNT=COUNT+1
..S INSTDATA("c_ssrs",COUNT,"count")=COUNT
..S INSTDATA("c_ssrs",COUNT,"admid")=+ADMIN
..S INSTDATA("c_ssrs",COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
..S INSTDATA("c_ssrs",COUNT,"score")=RESULTS(ADMDT,ADMIN)
Q
;
SAFLST(SAFDCL,SAFREV,SAFSCNO,SAFSCYES,HFCLIST) ;Take individual healthfactors and create HFCLIST
N HF,CNT
S CNT=0,HFCLIST=1
S HF=$P($G(SAFDCL(1)),U,2) I HF S CNT=CNT+1,HFCLIST(1,CNT)=HF ;Use reduced list of Health Factors for Safety Plan
S HF=$P($G(SAFREV(1)),U,2) I HF S CNT=CNT+1,HFCLIST(1,CNT)=HF
S HF=$P($G(SAFSCNO(1)),U,2) I HF S CNT=CNT+1,HFCLIST(1,CNT)=HF
S HF=$P($G(SAFSCYES(1)),U,2) I HF S CNT=CNT+1,HFCLIST(1,CNT)=HF
Q
CSRELST(CSRENEW,CSREUPD,HFCLIST) ;Take individual health factors and create HFCLIST
N HF,CNT
S HFCLIST=1,CNT=0
S HF=$P($G(CSRENEW(1)),U,2) I HF S CNT=CNT+1,HFCLIST(1,CNT)=HF ;Use reduced list of Health Factors for CSRE
S HF=$P($G(CSREUPD(1)),U,2) I HF S CNT=CNT+1,HFCLIST(1,CNT)=HF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSBWHIGH 16736 printed Apr 09, 2024@21:21:05 Page 2
YSBWHIGH ;SLC/DJE - MHA DASHBOARD ; Apr 01, 2021@16:33
+1 ;;5.01;MENTAL HEALTH;**202,208,221**;Dec 30, 1994;Build 11
+2 ;
+3 ; Routine retrieves high risk widget data
+4 ;
+5 ; Reference to ^AUPNVHF in ICR #3084
+6 ; Reference to ^AUTTHF in ICR #4295
+7 ; Reference to ^DGPM("ATID1") in ICR #1378
+8 ; Reference to ^DGPM in ICR #2090
+9 ; Reference to ^PXRMINDX in ICR #4229
+10 ; Reference to SDAMA301 in ICR #4433
+11 ; Reference to DGPFAPIH in ICR #4903
+12 ; Reference to DGPFAPI in ICR #3860
+13 QUIT
HIGHRISK(DATAOUT) ;
+1 NEW HRPATS,HRCOUNT,HRIDX,DFN,PRFFOUND,CRITERIA,YSDT,DONE7,NOW,DCDT,INSTDATA,PRFDATA,PATDATA
+2 NEW SAFHEAD,SAFDCL,SAFREV,SAFSCNO,SAFSCYES,CSREHEAD,CSRENEW,CSREUPD,SITES
+3 NEW HRFND
+4 NEW LSTSAF,DONE7,LSTCSRE,SUBS,CSRETITL,CSRENEW,CSREUPD
+5 ; quit from ERRHND if error
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERRHND^YSBWHIGH"
+6 SET NOW=$$NOW^XLFDT()
+7 SET YSDT=$PIECE(NOW,".",1)
+8 DO HRINIT^YSBRPC(.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.CSREHEAD,.CSRENEW,.CSREUPD,.SITES)
+9 SET HRCOUNT=$$GETLST^DGPFAPIH("2;DGPF(26.15,","","","HRPATS")
+10 IF 'HRCOUNT
QUIT
+11 SET HRIDX=+$ORDER(DATAOUT("data",""),-1)
+12 SET HRFND=0
+13 SET SUBS="YSB-DASH-"_YSDT
+14 SET DFN=0
FOR
SET DFN=$ORDER(HRPATS(DFN))
if 'DFN
QUIT
Begin DoDot:1
+15 SET DCDT=""
+16 KILL PRFDATA,PATDATA,INSTDATA
+17 SET PRFFOUND=$$PRFDATA(DFN,.SITES,.PRFDATA)
+18 ;no PRFDATA found
if 'PRFFOUND
QUIT
+19 SET HRFND=1
+20 SET HRIDX=HRIDX+1
+21 SET DATAOUT("data",HRIDX,"widget")="HIGH RISK"
+22 SET DATAOUT("data",HRIDX,"dfn")=DFN
+23 SET DCDT=$$MHDCDT^YSBWHIG2(DFN)
+24 SET DATAOUT("data",HRIDX,"patient_name")=$PIECE(HRPATS(DFN,0),U)
+25 ;All HIGH RISK PRFs
SET DATAOUT("data",HRIDX,"patient_prf")="YES"
+26 ;all HIGH RISK PRFs
SET DATAOUT("data",HRIDX,"division")=$PIECE(PRFDATA("OWNER"),U,2)
+27 SET DATAOUT("data",HRIDX,"prf_review")=$$FMTE^XLFDT(+PRFDATA("REVIEWDT"),5)
+28 SET DATAOUT("data",HRIDX,"due_overdue")=$$GETDUE(+PRFDATA("REVIEWDT"),YSDT)
+29 SET DATAOUT("data",HRIDX,"last_discharge_date")=$SELECT(+DCDT:$$FMTE^XLFDT(DCDT,5),1:DCDT)
+30 SET DATAOUT("data",HRIDX,"last_mh_visit")=$$MHLSTVST^YSBWHIG2(DFN,NOW)
+31 SET DATAOUT("data",HRIDX,"next_mh_appt_date")=$$MHNXTAPP(DFN,YSDT)
+32 SET DATAOUT("data",HRIDX,"on_track")=$$ONTRK(DFN,DCDT,YSDT)
+33 SET LSTSAF=$$MHLSTSAF(DFN,.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES)
+34 SET DONE7=$$DONE7(DFN,YSDT,.SAFHEAD,.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES)
+35 SET LSTCSRE=$$LASTCSRE(DFN,.CSRENEW,.CSREUPD,.CSREHEAD)
+36 SET DATAOUT("data",HRIDX,"last_mh_safety_plan")=LSTSAF
+37 SET DATAOUT("data",HRIDX,"done_in_7")=DONE7
+38 SET DATAOUT("data",HRIDX,"last_csra")=LSTCSRE
+39 ;PHQ9
DO BLDINST^YSBWHIG2(.INSTDATA,DFN,42,YSDT,"phq9")
+40 ;PHQ9 q9
DO BLDRSL^YSBWHIG2(.INSTDATA,DFN,42,YSDT,"phq9_i9",3382)
+41 ;C-SSRS
DO CSSRS(.INSTDATA,DFN,YSDT)
+42 MERGE DATAOUT("data",HRIDX)=INSTDATA
+43 ;send px information in loaddb call
+44 DO PATIENT^YSBDD1(DFN,.PATDATA)
+45 MERGE DATAOUT("data",HRIDX)=PATDATA
End DoDot:1
+46 QUIT
+47 ;
ERRHND ; Handle errors & clear stack
+1 ; get error
NEW ERROR
SET ERROR=$$EC^%ZOSV
+2 ; ignore errors clearing stack
IF ERROR["ZTER"
DO UNWIND^%ZTER
+3 ; avoid loop on add'l error
NEW $ETRAP
SET $ETRAP="D ^%ZTER,UNWIND^%ZTER"
+4 ; rec fail in error trap
DO ^%ZTER
+5 ; set to null for JSON
SET DATAOUT("data",1)=""
+6 ; clear stack
DO UNWIND^%ZTER
+7 QUIT
PRFDATA(DFN,SITES,PRFDATA) ;
+1 NEW PRFFULL,I,DONE,PRFSTAT
+2 SET PRFSTAT=$$GETACT^DGPFAPI(DFN,"PRFFULL")
+3 SET DONE=0
+4 SET I=0
FOR
SET I=$ORDER(PRFFULL(I))
if 'I
QUIT
Begin DoDot:1
+5 if $PIECE(PRFFULL(I,"FLAG"),U)'="2;DGPF(26.15,"
QUIT
+6 ;Q:'$D(SITES(+PRFFULL(I,"OWNER"))) ;only high risk flags from user's site
+7 SET DONE=1
+8 MERGE PRFDATA=PRFFULL(I)
End DoDot:1
if DONE
QUIT
+9 QUIT DONE
+10 ;
GETDUE(RVDT,YSDT) ;calculate if review is due
+1 IF 'RVDT
QUIT "N/A"
+2 QUIT $$FMDIFF^XLFDT(RVDT,YSDT)
+3 ;
MHNXTAPP(DFN,YSDT) ;Get next MH APPT up to a year from today.
+1 NEW YSDARRAY,APPTLIST,APPTDT,SDCOUNT,SDTIME,DONE,NOW,NODE,PSTAT,STATUS
+2 SET NOW=$$NOW^XLFDT()
+3 KILL ^TMP($JOB,"SDAMA301")
+4 SET YSDARRAY(1)=NOW_";"_$$FMADD^XLFDT(YSDT,365)
+5 SET YSDARRAY(3)="R;I;NS;NSR;CC;CCR;CP;CPR;NT;"
+6 SET YSDARRAY(4)=DFN
+7 SET YSDARRAY("FLDS")="1;2;12;13;18;22"
+8 SET YSDARRAY("SORT")="P"
+9 SET SDCOUNT=$$SDAPI^SDAMA301(.YSDARRAY)
+10 MERGE APPTLIST=^TMP($JOB,"SDAMA301",DFN)
+11 KILL ^TMP($JOB,"SDAMA301",DFN)
+12 SET DONE=0
SET APPTDT=""
+13 SET SDTIME=0
FOR
SET SDTIME=$ORDER(APPTLIST(SDTIME))
if 'SDTIME!DONE
QUIT
Begin DoDot:1
+14 IF '$$CHKCLIN^YSBDD1(APPTLIST(SDTIME))
QUIT
+15 SET NODE=APPTLIST(SDTIME)
+16 SET STATUS=$PIECE(NODE,U,22)
SET PSTAT=$PIECE(STATUS,";",3)
+17 ; also removes " & AUTO-REBOOK"
SET STATUS=$PIECE($PIECE($PIECE(NODE,U,22),";",3)," &")
+18 ;in the future, possible for an appt later today
IF STATUS="11;FUTURE;FUTURE"
QUIT
+19 ;Cancelled by Clinic or Cancelled by Patient
IF STATUS["CANCELLED"
QUIT
+20 ;No show
IF STATUS["NO-SHOW"
QUIT
+21 SET DONE=1
SET APPTDT=SDTIME
End DoDot:1
+22 IF 'APPTDT
QUIT "Not Scheduled"
+23 QUIT $$FMTE^XLFDT($PIECE(APPTDT,"."),5)
+24 ;
MHLSTSAF(DFN,SAFHEAD,SAFDCL,SAFREV,SAFSCNO,SAFSCYES) ;get mh last safety plan date
+1 NEW DATEFOUND,DECLINE,TIUINVDT,TIUFND
+2 NEW HFCLIST
+3 ;=3 means look through the TIU DOCUMENTS to check STATUS but don't get the contents
SET TIUINVDT=0
SET TIUFND=3
+4 DO SAFLST(.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.HFCLIST)
+5 SET DATEFOUND=$$FINDDOC(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,"",TIUFND)
+6 IF DATEFOUND=""
QUIT "NOT DONE"
+7 ;12/5/19 added "D"
IF $$SAFDECL(DFN,TIUINVDT,.SAFDCL)
QUIT "DECLINED"
+8 IF DATEFOUND
QUIT $$FMTE^XLFDT($PIECE(DATEFOUND,"."),5)
+9 QUIT "ERROR"
+10 ;
FINDDOC(DFN,TIUINVDT,HFCLIST,HDRLIST,TIURET,TIUFND) ;TIUINVDT is updated and returned by reference to permit recursion or use in V HF indexes
+1 NEW IDX,DATEFOUND,YSCLASS,HEADTXT,VSTFOUND,YSTIUDAT,TIU,HF,HFCNT
+2 NEW LOWER,UPPER,DSCR,DOCFND
+3 SET LOWER="abcdefghijklmnopqrstuvwxyz"
+4 SET UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+5 SET TIUFND=$GET(TIUFND)
+6 ;Set up Document Class to find TIU Note below
+7 ;Screen on CLASS type TIU DOCUMENT DEFs
SET DSCR="I $P(^(0),U,4)=""CL"""
+8 SET YSCLASS=$$FIND1^DIC(8925.1,"","B","CLINICAL DOCUMENTS",,,.DSCR)
+9 ; the note that created the HFs might not be signed and we'll need to search again
+10 FOR
Begin DoDot:1
+11 ;DBIA #4295 loop through HFs of HF categories
+12 SET (VSTFOUND,TIURET)=""
+13 SET DATEFOUND=9999999
SET DOCFND=0
+14 SET IDX=0
FOR
SET IDX=$ORDER(HFCLIST(IDX))
if IDX=""
QUIT
Begin DoDot:2
+15 SET HFCNT=""
FOR
SET HFCNT=$ORDER(HFCLIST(IDX,HFCNT))
if 'HFCNT
QUIT
Begin DoDot:3
+16 SET HF=HFCLIST(IDX,HFCNT)
+17 NEW HFDT
+18 ;find last date since input date ;DBIA #3084
SET HFDT=$ORDER(^AUPNVHF("AA",DFN,HF,TIUINVDT))
+19 IF HFDT=""
QUIT
+20 IF HFDT<DATEFOUND
SET DATEFOUND=HFDT
SET VSTFOUND=$ORDER(^AUPNVHF("AA",DFN,HF,HFDT,""))
End DoDot:3
End DoDot:2
+21 ;nothing found
IF DATEFOUND=9999999
SET (DATEFOUND,TIUINVDT)=""
QUIT
+22 ;outpatient visits are like this
SET YSTIUDAT=DATEFOUND
+23 ;inpatient visits are like this
+24 ;go from v health factors file to visit file DBIA 2316
SET VSTFOUND=$PIECE(^AUPNVHF(VSTFOUND,0),U,3)
+25 ;Save Visit Date/Time for TIU Match
NEW VSTDTM
SET VSTDTM=$PIECE(^AUPNVSIT(VSTFOUND,0),U)
+26 ;does the visit have a parent visit? The TIU will be filed against that date. DBIA 2028
SET VSTFOUND=$PIECE(^AUPNVSIT(VSTFOUND,0),U,12)
+27 ;get the visit date
IF VSTFOUND
SET YSTIUDAT=9999999-$PIECE((+^AUPNVSIT(VSTFOUND,0)),".")
+28 ;return inversed date in reference variable, function return is regular date
+29 SET TIUINVDT=DATEFOUND
SET DATEFOUND=9999999-DATEFOUND
+30 ;Don't find TIU DOCUMENT
IF TIUFND=0
SET TIURET=999999999
QUIT
+31 ;Now find TIU note
KILL ^TMP("TIU",$JOB)
+32 ;DBIA #3519
DO VISIT^TIULAPIC(DFN,YSCLASS,YSTIUDAT-0.1,YSTIUDAT,"",1)
+33 NEW REFDT,TVDT
+34 SET TIU=""
FOR
SET TIU=$ORDER(^TMP("TIU",$JOB,YSTIUDAT,TIU),-1)
if 'TIU
QUIT
Begin DoDot:2
+35 ;Quit if not a completed (signed) note
IF ^TMP("TIU",$JOB,YSTIUDAT,TIU,.05,"I")'=7
QUIT
+36 ;I TIUFND=3 S DOCFND=1,TIURET=999999999 Q ;For TIUFND=3, just need to know if signed TIU DOC;Keep flag for now but still have to find exact note
+37 SET REFDT=$PIECE($GET(^TMP("TIU",$JOB,YSTIUDAT,TIU,1301,"I")),".")
+38 SET TVDT=$PIECE($GET(^TMP("TIU",$JOB,YSTIUDAT,TIU,.07,"I")),".")
+39 if (REFDT'=$PIECE(VSTDTM,"."))&(TVDT'=$PIECE(VSTDTM,"."))
QUIT
+40 NEW HEADER
+41 SET HEADER=$GET(^TMP("TIU",$JOB,YSTIUDAT,TIU,"TEXT",1,0))_$GET(^TMP("TIU",$JOB,YSTIUDAT,TIU,"TEXT",2,0))_$GET(^TMP("TIU",$JOB,YSTIUDAT,TIU,"TEXT",3,0))
+42 FOR IDX=1:1:HDRLIST
SET HEADTXT=$PIECE(HDRLIST(IDX),U,2)
Begin DoDot:3
+43 IF (HEADER[HEADTXT)!($TRANSLATE(HEADER,LOWER,UPPER)[HEADTXT)
SET TIURET=TIU
IF TIUFND=3
SET DOCFND=1
SET TIURET=999999999
End DoDot:3
if $GET(TIURET)
QUIT
End DoDot:2
if $GET(TIURET)
QUIT
End DoDot:1
if TIURET
QUIT
if 'DATEFOUND
QUIT
+44 ;Did not find Signed TIU DOC
IF TIUFND=3
IF DOCFND=0
SET DATEFOUND=""
+45 ;Document not needed
IF TIURET=999999999
KILL TIURET
+46 KILL ^TMP("TIU",$JOB)
+47 QUIT DATEFOUND
+48 ;
SAFDECL(DFN,TIUINVDT,SAFDCL) ;was safety plan declined?
+1 NEW DCLHF
+2 ;Must get the SAFDCL Parameter first.
IF '$DATA(SAFDCL)
QUIT 0
+3 IF '$GET(DFN)
QUIT 0
+4 IF '$GET(TIUINVDT)
QUIT 0
+5 SET DCLHF=$PIECE($GET(SAFDCL(1)),U,2)
IF +DCLHF=0
QUIT 0
+6 QUIT $DATA(^AUPNVHF("AA",DFN,DCLHF,TIUINVDT))
+7 ;
HRACTIVE(DFN) ;get activation details of high risk flag
+1 NEW IDX,STOP,PRFDATA
+2 ;Get high risk data, if none quit
IF '$$GETINF^DGPFAPIH(DFN,"2;DGPF(26.15,","","","PRFDATA")
QUIT "N/A"
+3 SET IDX=""
SET STOP=0
FOR
SET IDX=$ORDER(PRFDATA("HIST",IDX),-1)
if 'IDX
QUIT
Begin DoDot:1
+4 ;if new assignment, reactivated, or inactivated then stop
IF "1,3,4"[(+PRFDATA("HIST",IDX,"ACTION"))
SET STOP=1
End DoDot:1
if STOP
QUIT
+5 ;catch all
IF 'STOP
QUIT "N/A"
+6 ;inactive flag
IF (+PRFDATA("HIST",IDX,"ACTION"))=3
QUIT "N/A"
+7 ;assigned or reactivated
QUIT +PRFDATA("HIST",IDX,"DATETIME")
+8 ;
DONE7(DFN,YSDT,SAFHEAD,SAFDCL,SAFREV,SAFSCNO,SAFSCYES) ;calculate done in 7
+1 NEW DATEFOUND,DECLINE,TIUIDX,ACTIVATION,TIUINVDT,LASTDATE,FIRSTDATE,ADMISSION,DSCHGDT,INPT
+2 NEW MVMT,DONE,TIUFND,INVDT
+3 NEW ENDADMISS,DSCHGM,TRNSFRDT
+4 NEW HFCLIST
+5 SET ACTIVATION=$$HRACTIVE(DFN)
SET INPT=0
+6 IF ACTIVATION="N/A"
QUIT "N/A"
+7 SET ACTIVATION=$PIECE(ACTIVATION,".")
+8 SET LASTDATE=$$FMADD^XLFDT(ACTIVATION,8)
+9 SET FIRSTDATE=$$FMADD^XLFDT(ACTIVATION,-7)
+10 ;check to see if patient was inpatient at some point during 7 day period
+11 SET ADMISSION=9999999-LASTDATE
+12 SET ENDADMISS=9999999-FIRSTDATE
+13 SET DONE=0
SET MVMT=""
SET DSCHGDT=""
+14 FOR
SET ADMISSION=$ORDER(^DGPM("ATID1",DFN,ADMISSION))
if ADMISSION=""!DONE!(ADMISSION>ENDADMISS)
QUIT
Begin DoDot:1
+15 ;Find the last MH Admission
SET MVMT=""
FOR
SET MVMT=$ORDER(^DGPM("ATID1",DFN,ADMISSION,MVMT))
if MVMT=""
QUIT
Begin DoDot:2
+16 IF $$ISMHMV(MVMT)=1
SET DONE=1
End DoDot:2
if DONE
QUIT
End DoDot:1
+17 IF MVMT'=""
Begin DoDot:1
+18 ;make it the DC movement
SET DSCHGM=$PIECE($GET(^DGPM(MVMT,0)),U,17)
+19 ;S INPT=1 Q ;Still an inpatient admitted before the 7 day cutoff
IF DSCHGM=""
SET INPT=$$GET1^DIQ(405,MVMT,.01,"I")
QUIT
+20 ;update lastdate to dc date if later
SET DSCHGDT=+^DGPM(DSCHGM,0)
IF DSCHGDT>LASTDATE
SET LASTDATE=$PIECE(DSCHGDT,".")
+21 ;Allow Safety Plan to still be completed today
IF $PIECE(DSCHGDT,".")=YSDT
SET INPT=DSCHGDT
End DoDot:1
+22 ;Check transfers also but only if later than last MH discharge date
+23 SET (DONE,INVDT)=0
SET INVDT=(9999999-($GET(LASTDATE)-.01))
+24 ;DBIA #1378
FOR
SET INVDT=$ORDER(^DGPM("ATID2",DFN,INVDT))
if (INVDT="")!(INVDT>ENDADMISS)
QUIT
Begin DoDot:1
+25 NEW MVMT
+26 ;DBIA #1378
SET MVMT=""
FOR
SET MVMT=$ORDER(^DGPM("ATID2",DFN,INVDT,MVMT))
if (MVMT="")
QUIT
Begin DoDot:2
+27 NEW LOC,ADMMVMT,DCMVMT,XMVMT,TRNSCTN
+28 ;DBIA #1378
SET LOC=$$GET1^DIQ(405,MVMT,.06,"I")
+29 ;find the transaction type, 2=TRANSFER ;DBIA #1378
SET TRNSCTN=$$GET1^DIQ(405,MVMT,.02,"I")
+30 ;not a psychiatry service ward and not a TRANSFER ;DBIA #31
IF $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY"
IF TRNSCTN'=2
QUIT
+31 ;find admission to find discharge ;DBIA #1378
SET ADMMVMT=$$GET1^DIQ(405,MVMT,.14,"I")
+32 ;DBIA #2090
SET DCMVMT=$$GET1^DIQ(405,ADMMVMT,.17,"I")
+33 SET XMVMT=DCMVMT
+34 ;Don't let a null DCMVMT set the TRNSFRDT
if DCMVMT=""&(TRNSCTN'=2)
QUIT
+35 ;If this is a TRANFER, set the Transfer date
if TRNSCTN=2
SET XMVMT=MVMT
+36 ;DBIA #1378
SET TRNSFRDT=$$GET1^DIQ(405,XMVMT,.01,"I")
SET DONE=1
+37 ;The Transfer was to an MH Location, need to Evaluate dates
IF $$ISMHMV^YSBWHIGH(XMVMT)=1
Begin DoDot:3
+38 NEW XDSCHGM,XINPT,XDSCHGDT
+39 ;See if there was a discharge
SET XDSCHGM=$PIECE($GET(^DGPM(XMVMT,0)),U,17)
+40 ;No Discharge, is this XFER later than any ADMISSIONS?
IF XDSCHGM=""
SET XINPT=$$GET1^DIQ(405,XMVMT,.01,"I")
IF XINPT>INPT
SET INPT=XINPT
QUIT
+41 ;If the Discharge movement is after Transfer then update
SET XDSCHGDT=$$GET1^DIQ(405,XDSCHGM,.01,"I")
IF XDSCHGDT>TRNSFRDT
SET TRNSFRDT=$PIECE(XDSCHGDT,".")
End DoDot:3
End DoDot:2
if (DONE=1)
QUIT
End DoDot:1
if (DONE=1)
QUIT
+42 IF ($GET(TRNSFRDT)>$GET(DSCHGDT))
IF ($GET(TRNSFRDT)>INPT)
SET DSCHGDT=TRNSFRDT
SET INPT=0
+43 IF (DSCHGDT'="")
IF (DSCHGDT>LASTDATE)
SET DSCHGDT=$PIECE(DSCHGDT,".",1)
SET LASTDATE=$PIECE(DSCHGDT,".")
+44 ;invert last date and search for safety plan
+45 SET DECLINE=""
+46 ;If still an inpatient, look for all current Safety Plans
IF INPT'=0
SET LASTDATE=YSDT
+47 ;Updated to be inclusive of Last Date.
SET TIUINVDT=9999999-LASTDATE
SET TIUINVDT=$PIECE(TIUINVDT,".")-1
SET TIUINVDT=TIUINVDT_.9999999
+48 KILL HFCLIST
SET TIUFND=3
+49 DO SAFLST(.SAFDCL,.SAFREV,.SAFSCNO,.SAFSCYES,.HFCLIST)
+50 ; find safety plan seven days from assignment
SET DATEFOUND=$$FINDDOC(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,.TIUIDX,TIUFND)
+51 ; Declined Safety plan in 7; 12/5/19 added "D"
IF DATEFOUND>=FIRSTDATE
IF $$SAFDECL(DFN,TIUINVDT,.SAFDCL)
QUIT "DECLINED"
+52 ; Completed Safety plan in 7 for Inpatients
IF (DATEFOUND>=FIRSTDATE)
IF (DATEFOUND<=INPT)
QUIT "COMPLETED"
+53 ;Was an Inpatient but discharged
IF DSCHGDT'=""
IF (DATEFOUND>=FIRSTDATE)
IF (DATEFOUND<=DSCHGDT)
QUIT "COMPLETED"
+54 ; Completed Safety plan in 7
IF (DATEFOUND>=FIRSTDATE)
IF (DATEFOUND<LASTDATE)
QUIT "COMPLETED"
+55 ; Still an inpatient, have until discharge
IF INPT
QUIT "PENDING"
+56 ; Still time to complete
IF YSDT<LASTDATE
QUIT "PENDING"
+57 SET TIUINVDT=0
SET DATEFOUND=0
+58 ; find any safety plan
SET DATEFOUND=$$FINDDOC(DFN,.TIUINVDT,.HFCLIST,.SAFHEAD,"",TIUFND)
+59 IF DATEFOUND<FIRSTDATE
SET DATEFOUND=0
+60 ; Declined Safety plan
IF DATEFOUND'=0
IF $$SAFDECL(DFN,TIUINVDT,.SAFDCL)
QUIT "DECLINED"
+61 IF DATEFOUND>=LASTDATE
QUIT "DONE LATE"
+62 QUIT "OVERDUE"
ISMHMV(MVMT) ;
+1 NEW LOC,ADMMVMT,DCMVMT,ISMH
+2 IF MVMT=""
QUIT 0
+3 SET ISMH=1
+4 ;DBIA #1378
SET LOC=$$GET1^DIQ(405,MVMT,.06,"I")
+5 ;find the transaction type, 2=TRANSFER ;DBIA #1378
SET TRNSCTN=$$GET1^DIQ(405,MVMT,.02,"I")
+6 ;,TRNSCTN'=2 Q ;not a psychiatry service ward and not a TRANSFER ;DBIA #31
IF $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY"
SET ISMH=0
+7 QUIT ISMH
+8 ;
ONTRK(DFN,DCDT,YSDT) ;
+1 NEW ONTRK,BEGDT,ENDDT,I,LOCATIONS,APPTCNT,LIST,IDX,STS
+2 IF 'DCDT
SET DCDT=$$MHDCDT^YSBWHIG2(DFN)
+3 IF 'DCDT
QUIT "N/A"
+4 IF '$GET(YSDT)
SET YSDT=$PIECE($$NOW^XLFDT,".")
+5 SET ONTRK="NO"
SET BEGDT=DCDT
SET ENDDT=$$FMADD^XLFDT(BEGDT,30)
SET APPTCNT=0
+6 DO VST^ORWCV(.LIST,DFN,BEGDT,ENDDT_".2359",1)
+7 ;not enough results
IF '$DATA(LIST(4))
QUIT "NO"
+8 SET (APPTCNT,IDX)=0
FOR
SET IDX=$ORDER(LIST(IDX))
if ('IDX)!(APPTCNT>=4)
QUIT
Begin DoDot:1
+9 NEW APPTDT
+10 IF '$$CHKCLIN^YSBRPC($PIECE($PIECE(LIST(IDX),U),";",3))
QUIT
+11 ;if appointment in the past, then only count if we have outpx encounter
+12 SET APPTDT=$PIECE($PIECE(LIST(IDX),U),";",2)
+13 IF ($PIECE($PIECE(LIST(IDX),U),";",1)="A")
IF (APPTDT<YSDT)
if '$PIECE($GET(^DPT(DFN,"S",APPTDT,0)),U,20)
QUIT
+14 SET STS=$PIECE(LIST(IDX),U,4)
if STS["CANCEL"
QUIT
+15 SET APPTCNT=APPTCNT+1
End DoDot:1
+16 IF APPTCNT>=4
QUIT "YES"
+17 QUIT "NO"
+18 ;
LASTCSRE(DFN,CSRENEW,CSREUPD,CSREHEAD) ;
+1 NEW DATEFOUND,HFCLIST,TIUFND
+2 SET TIUFND=3
+3 DO CSRELST(.CSRENEW,.CSREUPD,.HFCLIST)
+4 SET DATEFOUND=$$FINDDOC(DFN,0,.HFCLIST,.CSREHEAD,"",TIUFND)
+5 IF DATEFOUND=""
QUIT "NOT DONE"
+6 QUIT $$FMTE^XLFDT(DATEFOUND,5)
+7 ;
CSSRS(INSTDATA,DFN,YSDT) ;
+1 NEW ADMDT,CUTOFF,COUNT,RESULTS
+2 SET CUTOFF=$$FMADD^XLFDT(YSDT,-90)
SET COUNT=0
+3 ;Get the latest ten results from the last 90 days
+4 ;Need to loop from latest to last
+5 ;S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,228,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
+6 ;Remove 90 day cutoff
SET ADMDT=""
FOR
SET ADMDT=$ORDER(^PXRMINDX(601.84,"PI",DFN,228,ADMDT),-1)
if 'ADMDT
QUIT
if COUNT=10
QUIT
Begin DoDot:1
+7 NEW ADMIN
+8 SET ADMIN=0
FOR
SET ADMIN=$ORDER(^PXRMINDX(601.84,"PI",DFN,228,ADMDT,ADMIN))
if 'ADMIN
QUIT
Begin DoDot:2
+9 NEW RESULT,STOP,SCORE
+10 SET SCORE="Negative"
+11 SET (STOP,RESULT)=0
FOR
SET RESULT=$ORDER(^YTT(601.92,"AC",ADMIN,RESULT))
if 'RESULT
QUIT
if STOP
QUIT
Begin DoDot:3
+12 NEW N0
+13 SET N0=^YTT(601.92,RESULT,0)
+14 ;if questions 3,4,5 or 8 are 1 then positive.
IF ("Ques3,Ques4,Ques5,Ques8"[$PIECE(N0,U,3))
IF ($PIECE(N0,U,4)=1)
SET SCORE="Positive"
SET STOP=1
End DoDot:3
+15 SET COUNT=COUNT+1
+16 SET RESULTS(ADMDT,ADMIN)=SCORE
End DoDot:2
End DoDot:1
+17 IF COUNT=0
Begin DoDot:1
+18 SET INSTDATA("c_ssrs",1,"count")=1
+19 SET INSTDATA("c_ssrs",1,"date")="N/A"
+20 SET INSTDATA("c_ssrs",1,"score")="N/A"
End DoDot:1
QUIT
+21 ;Now need to loop from last to latest
+22 ;reuse count to index the JSON global
SET COUNT=0
+23 SET ADMDT=""
FOR
SET ADMDT=$ORDER(RESULTS(ADMDT))
if 'ADMDT
QUIT
Begin DoDot:1
+24 SET ADMIN=0
FOR
SET ADMIN=$ORDER(RESULTS(ADMDT,ADMIN))
if 'ADMIN
QUIT
Begin DoDot:2
+25 SET COUNT=COUNT+1
+26 SET INSTDATA("c_ssrs",COUNT,"count")=COUNT
+27 SET INSTDATA("c_ssrs",COUNT,"admid")=+ADMIN
+28 SET INSTDATA("c_ssrs",COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
+29 SET INSTDATA("c_ssrs",COUNT,"score")=RESULTS(ADMDT,ADMIN)
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
SAFLST(SAFDCL,SAFREV,SAFSCNO,SAFSCYES,HFCLIST) ;Take individual healthfactors and create HFCLIST
+1 NEW HF,CNT
+2 SET CNT=0
SET HFCLIST=1
+3 ;Use reduced list of Health Factors for Safety Plan
SET HF=$PIECE($GET(SAFDCL(1)),U,2)
IF HF
SET CNT=CNT+1
SET HFCLIST(1,CNT)=HF
+4 SET HF=$PIECE($GET(SAFREV(1)),U,2)
IF HF
SET CNT=CNT+1
SET HFCLIST(1,CNT)=HF
+5 SET HF=$PIECE($GET(SAFSCNO(1)),U,2)
IF HF
SET CNT=CNT+1
SET HFCLIST(1,CNT)=HF
+6 SET HF=$PIECE($GET(SAFSCYES(1)),U,2)
IF HF
SET CNT=CNT+1
SET HFCLIST(1,CNT)=HF
+7 QUIT
CSRELST(CSRENEW,CSREUPD,HFCLIST) ;Take individual health factors and create HFCLIST
+1 NEW HF,CNT
+2 SET HFCLIST=1
SET CNT=0
+3 ;Use reduced list of Health Factors for CSRE
SET HF=$PIECE($GET(CSRENEW(1)),U,2)
IF HF
SET CNT=CNT+1
SET HFCLIST(1,CNT)=HF
+4 SET HF=$PIECE($GET(CSREUPD(1)),U,2)
IF HF
SET CNT=CNT+1
SET HFCLIST(1,CNT)=HF
+5 QUIT
