Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YSBWHIGH

YSBWHIGH.m

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