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

YSBWHIG2.m

Go to the documentation of this file.
  1. YSBWHIG2 ;SLC/DJE - MHA DASHBOARD ; Apr 01, 2021@16:33
  1. ;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
  1. ;
  1. ; Routine retrieves high risk widget data
  1. ;
  1. ; Reference to SDAMA301 in ICR #4433
  1. ; Reference to ^PXRMINDX in ICR #4229
  1. ; Reference to ^DIC(42) in ICR #3790
  1. ; Reference to ^DIC(42,D0,.03) in ICR #31
  1. ; Reference to ^DGPM("ATID1") in ICR #1378
  1. ; Reference to ^DGPM in ICR #2090
  1. ; Reference to ^SC in ICR #1004
  1. ; Reference to ^SC("AST") in ICR #4482
  1. Q
  1. ;
  1. BLDINST(INSTDATA,DFN,INST,YSDT,INSTNM) ;
  1. ;Build a list of instrument results for single score instruments
  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,INST,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
  1. S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,INST,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,INST,ADMDT,ADMIN)) Q:'ADMIN D
  1. ..N RESULT
  1. ..S RESULT=$O(^YTT(601.92,"AC",ADMIN,0)) ;assuming we only have one scale!
  1. ..Q:'RESULT
  1. ..S COUNT=COUNT+1
  1. ..S RESULTS(ADMDT,ADMIN)=$P(^YTT(601.92,RESULT,0),U,4)
  1. I COUNT=0 D Q
  1. .S INSTDATA(INSTNM,1,"count")=1
  1. .S INSTDATA(INSTNM,1,"date")="N/A"
  1. .S INSTDATA(INSTNM,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(INSTNM,COUNT,"count")=COUNT
  1. ..S INSTDATA(INSTNM,COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
  1. ..S INSTDATA(INSTNM,COUNT,"score")=+RESULTS(ADMDT,ADMIN) ;values need to be numeric so we can graph
  1. Q
  1. BLDRSL(INSTDATA,DFN,INST,YSDT,INSTNM,QNUM) ;
  1. ;Build a list of instrument results on a particular question
  1. N ADMDT,CUTOFF,COUNT,RESULTS
  1. N YS,YSDATA,YSIEN,YSANS
  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,INST,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
  1. S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,INST,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,INST,ADMDT,ADMIN)) Q:'ADMIN D
  1. ..S YS("AD")=ADMIN
  1. ..S YS("QN")=QNUM
  1. ..D GETANS^YTQAPI1(.YSDATA,.YS)
  1. ..Q:$G(YSDATA(1))["ERROR"
  1. ..S YSIEN=$G(YSDATA(2)) Q:+YSIEN=0
  1. ..S YSANS=$$GET1^DIQ(601.75,YSIEN_",",4) ;Expects Numerical Legacy Value
  1. ..I INSTNM="phq9_i9",(+YSANS'=0) S YSANS=YSANS-1 ;PHQ9_I9 display/score offset
  1. ..S COUNT=COUNT+1
  1. ..S RESULTS(ADMDT,ADMIN)=YSANS
  1. I COUNT=0 D Q
  1. .S INSTDATA(INSTNM,1,"count")=1
  1. .S INSTDATA(INSTNM,1,"date")="N/A"
  1. .S INSTDATA(INSTNM,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(INSTNM,COUNT,"count")=COUNT
  1. ..S INSTDATA(INSTNM,COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
  1. ..S INSTDATA(INSTNM,COUNT,"score")=+RESULTS(ADMDT,ADMIN) ;values need to be numeric so we can graph
  1. Q
  1. ;
  1. MHLSTVST(DFN,YSDT,FROM) ;Get last MH Visit Date up to one year back.
  1. N YSDARRAY,APPTLIST
  1. N SDCOUNT,PIDX,FIDX,SDTIME,OUTPXENC,NODE,LSTMHDT,STATUS,PSTAT,FLIM,NOW
  1. S NOW=$$NOW^XLFDT()
  1. S FLIM=$G(FROM) S:FLIM="" FLIM=365
  1. S YSDARRAY(1)=$$FMADD^XLFDT(YSDT,-FLIM)_";"_NOW
  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) K ^TMP($J,"SDAMA301")
  1. ;add ^SCE("ADFN" loop to detect Outpatient Encounters with no visit. These will be marked as unscheduled
  1. S (PIDX,FIDX)=0
  1. S SDTIME=$$FMADD^XLFDT(YSDT,-FLIM) ;Start from 1 year back to current
  1. F S SDTIME=$O(^SCE("ADFN",DFN,SDTIME)) Q:'SDTIME D
  1. .I $D(APPTLIST(SDTIME)) Q ;already got this visit, must be scheduled
  1. .S OUTPXENC=$O(^SCE("ADFN",DFN,SDTIME,0))
  1. .S NODE=^SCE(OUTPXENC,0)
  1. .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"
  1. ; split appointments into past and previous
  1. ;sort previous appointments by reverse date
  1. S LSTMHDT=""
  1. S SDTIME=$$FMADD^XLFDT(YSDT,1) F S SDTIME=$O(APPTLIST(SDTIME),-1) Q:'SDTIME!LSTMHDT D
  1. .I '$$CHKCLIN^YSBDD1(APPTLIST(SDTIME)) K APPTLIST(SDTIME) Q ;not ED or MH clinic - delete
  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["NO ACTION TAKEN",(PSTAT'["CHECKED") Q ;No positive state of this encounter.
  1. .I STATUS["NO ACT TAKN",(PSTAT'["CHECKED") Q ;Inpatient No action taken
  1. .I STATUS["CANCELLED" Q ;Cancelled by Clinic or Cancelled by Patient
  1. .I STATUS["NO-SHOW" Q ;No show
  1. .S LSTMHDT=SDTIME
  1. I 'LSTMHDT Q "N/A"
  1. Q $$FMTE^XLFDT($P(LSTMHDT,"."),5)
  1. ;
  1. MHDCDT(DFN) ;Find last mental health discharge date or if mental health inpatient
  1. N CURLOCNM,INVDT,RETURN,DONE,DSCHGDT,TRNSFRDT,TRNSCTN,XMVMT
  1. S RETURN="N/A",DSCHGDT=""
  1. ;check current inpatient ward if it exists
  1. S CURLOCNM=$G(^DPT(DFN,.1)) ;DBIA #10035 (Supported)
  1. I CURLOCNM]"" D
  1. .N LOC,DIC,X,Y
  1. .S DIC="^DIC(42,",DIC(0)="BX",X=CURLOCNM ;DBIA #1848
  1. .D ^DIC
  1. .S LOC=+Y
  1. .Q:'LOC
  1. .I $$GET1^DIQ(42,LOC,.03)="PSYCHIATRY" S RETURN="INPT" ;DBIA #31
  1. I RETURN="INPT" Q RETURN
  1. ;Get last MH admission
  1. S (DONE,INVDT)=0 F S INVDT=$O(^DGPM("ATID1",DFN,INVDT)) Q:(INVDT="") D Q:(DONE=1) ;DBIA #1378
  1. .N MVMT
  1. .S MVMT="" F S MVMT=$O(^DGPM("ATID1",DFN,INVDT,MVMT)) Q:(MVMT="") D Q:(DONE=1) ;DBIA #1378
  1. ..N LOC,DCMVMT
  1. ..S LOC=$$GET1^DIQ(405,MVMT,.06,"I") ;DBIA #1378
  1. ..I LOC="" Q
  1. ..I $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY" Q ;not a psychiatry service ward ;DBIA #31
  1. ..S DCMVMT=$$GET1^DIQ(405,MVMT,.17,"I") ;DBIA #2090
  1. ..S DSCHGDT=$$GET1^DIQ(405,DCMVMT,.01,"I"),DONE=1 Q ;DBIA #1378
  1. ;Check transfers also but only if later than last MH discharge date
  1. S (DONE,INVDT)=0 S:$G(DSCHGDT) INVDT=(9999999-($G(DSCHGDT)-.01))
  1. F S INVDT=$O(^DGPM("ATID2",DFN,INVDT)) Q:(INVDT="") 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
  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 Q ;DBIA #1378
  1. I $G(TRNSFRDT)>$G(DSCHGDT) S DSCHGDT=TRNSFRDT
  1. I DSCHGDT'="" S DSCHGDT=$P(DSCHGDT,".",1),RETURN=DSCHGDT
  1. Q RETURN
  1. ;
  1. GETLOCS(DATAOUT,ID) ;
  1. ; C=Clinics, Z=Other, screened by $$ACTLOC
  1. ; Mental Health Locations Only
  1. ; Similar to MHLOCS but returns an array for JSON
  1. N XPREF,I,CNT,SCIEN,SCNAM
  1. S CNT=0
  1. D GETMHLOC(.XPREF)
  1. F I=1:1:$L(XPREF("MHLOCS"),";") D
  1. . S SCIEN=$P(XPREF("MHLOCS"),";",I)
  1. . S SCNAM=$P(^SC(SCIEN,0),U) ;DBIA 10040
  1. . Q:$E(SCNAM,1,2)="ZZ" ;ZZ* are inactivated
  1. . S CNT=CNT+1
  1. . S DATAOUT("widgets",ID,"locationList",CNT,"id")=SCIEN
  1. . S DATAOUT("widgets",ID,"locationList",CNT,"name")=SCNAM
  1. Q
  1. GETMHLOC(PREFS) ;Get all Hospital Locations that are Mental Health
  1. ; STOP CODE=Mental Health OR Emergency Department
  1. ; TYPE=CLINIC
  1. ; ACTIVE=TRUE
  1. N STP,STOPCODE,LOCSTR,HL,SCNAM
  1. S LOCSTR=""
  1. S STP="" F S STP=$O(^SC("AST",STP)) Q:STP="" D ;DBIA #4482
  1. .;Get the stop code.
  1. .S STOPCODE=$$GET1^DIQ(40.7,STP,1) ;DBIA #557
  1. .I ((STOPCODE>=500)&(STOPCODE<600))!(STOPCODE=130) D
  1. ..S HL=0 F S HL=$O(^SC("AST",STP,HL)) Q:+HL=0 D
  1. ...Q:("C"'[$P($G(^SC(HL,0)),U,3)!('$$ACTLOC(HL)))
  1. ...S SCNAM=$P(^SC(HL,0),U) ;DBIA 10040
  1. ...I $E(SCNAM,1,2)="ZZ" Q ;ZZ* are inactivated locations
  1. ...S LOCSTR=LOCSTR_HL_";"
  1. I LOCSTR]"" S LOCSTR=$E(LOCSTR,1,$L(LOCSTR)-1)
  1. S PREFS("MHLOCS")=LOCSTR
  1. Q
  1. ACTLOC(LOC) ; Function: returns TRUE if active hospital location
  1. ; IA# 10040.
  1. N NOW,YSDT
  1. S NOW=$$NOW^XLFDT()
  1. S YSDT=$P(NOW,".",1)
  1. N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
  1. S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
  1. S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
  1. I YSDT>$P(X,U)&($P(X,U,2)=""!(YSDT<$P(X,U,2))) Q 0 ; chk reactivate date
  1. Q 1 ; must still be active
  1. ;
  1. IDFLT(INSTS,SHOWALL) ;Use default instrument list
  1. ; INSTS = return array of Instruments
  1. ; SHOWALL = flag to control whether all instruments are returned or not
  1. N LOWER,UPPER,INSTSEQ,MBCID,INSTC,INSTID,INSTNAM
  1. N MNGRP,MNSCL
  1. N DFLST,DISP,INAM,TMPI
  1. N YFN,YSIEN,YSARR,INSTYP
  1. S SHOWALL=$G(SHOWALL)
  1. S DFLST=";PHQ9;BAM-R;PCL-5;GAD-7;"
  1. S INSTC=0,LOWER="abcdefghijklmnopqrstuvwxyz",UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  1. S MBCID=$O(^YSD(605.1,"B","MBC","")) Q:MBCID=""
  1. S INSTSEQ=0 F S INSTSEQ=$O(^YSD(605.1,MBCID,3,INSTSEQ)) Q:'INSTSEQ D
  1. .S INSTID=^YSD(605.1,MBCID,3,INSTSEQ,0)
  1. .Q:INSTID="" ;Should not occur.
  1. .Q:'$D(^YTT(601.71,INSTID)) ;If Instrument not installed yet.
  1. .S INSTNAM=$TR($P(^YTT(601.71,INSTID,0),U),LOWER,UPPER)
  1. .S TMPI(INSTNAM)=INSTSEQ_U_INSTID
  1. S YFN=605.13
  1. S INSTNAM="" F S INSTNAM=$O(TMPI(INSTNAM)) Q:INSTNAM="" D
  1. .S INSTSEQ=TMPI(INSTNAM),INSTID=$P(INSTSEQ,U,2),INSTSEQ=$P(INSTSEQ,U)
  1. .S YSIEN=INSTSEQ_","_MBCID_"," K YSARR
  1. .D GETS^DIQ(YFN,YSIEN,"**","","YSARR")
  1. .S INSTYP=$G(YSARR(YFN,YSIEN,3))
  1. .S MNGRP=$G(YSARR(YFN,YSIEN,1))
  1. .S MNSCL=$G(YSARR(YFN,YSIEN,2))
  1. .;Check INSTNAM against list of default instruments here Q if not in list
  1. .I SHOWALL="",(DFLST'[(";"_INSTNAM_";")) Q
  1. .S DISP=(DFLST[(";"_INSTNAM_";"))
  1. .S INSTC=INSTC+1,INSTS(INSTC)=INSTID_U_INSTNAM
  1. .;S WIN1=$G(^YSD(605.1,MBCID,3,INSTSEQ,1)),MNGRP=$P(WIN1,U),MNSCL=$P(WIN1,U,2) ;Main widget display Group and Scale if subscale inst
  1. .S INSTS(INSTC,"MNGRP")=MNGRP
  1. .S INSTS(INSTC,"MNSCL")=MNSCL
  1. .S INSTS(INSTC,"DISPLAY")=$S(DISP:"true",1:"false")
  1. .S INSTS(INSTC,"TYPE")=INSTYP
  1. Q