- 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 Feb 18, 2025@23:39:48 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