YSBWHIG2 ;SLC/DJE - MHA DASHBOARD ; Apr 01, 2021@16:33
;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
;
; Routine retrieves high risk widget data
;
; Reference to SDAMA301 in ICR #4433
; Reference to ^PXRMINDX in ICR #4229
; Reference to ^DIC(42) in ICR #3790
; Reference to ^DIC(42,D0,.03) in ICR #31
; Reference to ^DGPM("ATID1") in ICR #1378
; Reference to ^DGPM in ICR #2090
; Reference to ^SC in ICR #1004
; Reference to ^SC("AST") in ICR #4482
Q
;
BLDINST(INSTDATA,DFN,INST,YSDT,INSTNM) ;
;Build a list of instrument results for single score instruments
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,INST,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,INST,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,INST,ADMDT,ADMIN)) Q:'ADMIN D
..N RESULT
..S RESULT=$O(^YTT(601.92,"AC",ADMIN,0)) ;assuming we only have one scale!
..Q:'RESULT
..S COUNT=COUNT+1
..S RESULTS(ADMDT,ADMIN)=$P(^YTT(601.92,RESULT,0),U,4)
I COUNT=0 D Q
.S INSTDATA(INSTNM,1,"count")=1
.S INSTDATA(INSTNM,1,"date")="N/A"
.S INSTDATA(INSTNM,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(INSTNM,COUNT,"count")=COUNT
..S INSTDATA(INSTNM,COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
..S INSTDATA(INSTNM,COUNT,"score")=+RESULTS(ADMDT,ADMIN) ;values need to be numeric so we can graph
Q
BLDRSL(INSTDATA,DFN,INST,YSDT,INSTNM,QNUM) ;
;Build a list of instrument results on a particular question
N ADMDT,CUTOFF,COUNT,RESULTS
N YS,YSDATA,YSIEN,YSANS
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,INST,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,INST,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,INST,ADMDT,ADMIN)) Q:'ADMIN D
..S YS("AD")=ADMIN
..S YS("QN")=QNUM
..D GETANS^YTQAPI1(.YSDATA,.YS)
..Q:$G(YSDATA(1))["ERROR"
..S YSIEN=$G(YSDATA(2)) Q:+YSIEN=0
..S YSANS=$$GET1^DIQ(601.75,YSIEN_",",4) ;Expects Numerical Legacy Value
..I INSTNM="phq9_i9",(+YSANS'=0) S YSANS=YSANS-1 ;PHQ9_I9 display/score offset
..S COUNT=COUNT+1
..S RESULTS(ADMDT,ADMIN)=YSANS
I COUNT=0 D Q
.S INSTDATA(INSTNM,1,"count")=1
.S INSTDATA(INSTNM,1,"date")="N/A"
.S INSTDATA(INSTNM,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(INSTNM,COUNT,"count")=COUNT
..S INSTDATA(INSTNM,COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
..S INSTDATA(INSTNM,COUNT,"score")=+RESULTS(ADMDT,ADMIN) ;values need to be numeric so we can graph
Q
;
MHLSTVST(DFN,YSDT,FROM) ;Get last MH Visit Date up to one year back.
N YSDARRAY,APPTLIST
N SDCOUNT,PIDX,FIDX,SDTIME,OUTPXENC,NODE,LSTMHDT,STATUS,PSTAT,FLIM,NOW
S NOW=$$NOW^XLFDT()
S FLIM=$G(FROM) S:FLIM="" FLIM=365
S YSDARRAY(1)=$$FMADD^XLFDT(YSDT,-FLIM)_";"_NOW
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")
;add ^SCE("ADFN" loop to detect Outpatient Encounters with no visit. These will be marked as unscheduled
S (PIDX,FIDX)=0
S SDTIME=$$FMADD^XLFDT(YSDT,-FLIM) ;Start from 1 year back to current
F S SDTIME=$O(^SCE("ADFN",DFN,SDTIME)) Q:'SDTIME D
.I $D(APPTLIST(SDTIME)) Q ;already got this visit, must be scheduled
.S OUTPXENC=$O(^SCE("ADFN",DFN,SDTIME,0))
.S NODE=^SCE(OUTPXENC,0)
.S APPTLIST(SDTIME)=SDTIME_U_$P(NODE,U,4)_";"_$$GET1^DIQ(44,$P(NODE,U,4),.01)_"^^^^^^^^^^"_OUTPXENC_U_$P(NODE,U,3)_";"_$$GET1^DIQ(40.7,$P(NODE,U,3),1)_"^^^^^4;UV^^^^;;WALK-IN"
; split appointments into past and previous
;sort previous appointments by reverse date
S LSTMHDT=""
S SDTIME=$$FMADD^XLFDT(YSDT,1) F S SDTIME=$O(APPTLIST(SDTIME),-1) Q:'SDTIME!LSTMHDT D
.I '$$CHKCLIN^YSBDD1(APPTLIST(SDTIME)) K APPTLIST(SDTIME) Q ;not ED or MH clinic - delete
.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["NO ACTION TAKEN",(PSTAT'["CHECKED") Q ;No positive state of this encounter.
.I STATUS["NO ACT TAKN",(PSTAT'["CHECKED") Q ;Inpatient No action taken
.I STATUS["CANCELLED" Q ;Cancelled by Clinic or Cancelled by Patient
.I STATUS["NO-SHOW" Q ;No show
.S LSTMHDT=SDTIME
I 'LSTMHDT Q "N/A"
Q $$FMTE^XLFDT($P(LSTMHDT,"."),5)
;
MHDCDT(DFN) ;Find last mental health discharge date or if mental health inpatient
N CURLOCNM,INVDT,RETURN,DONE,DSCHGDT,TRNSFRDT,TRNSCTN,XMVMT
S RETURN="N/A",DSCHGDT=""
;check current inpatient ward if it exists
S CURLOCNM=$G(^DPT(DFN,.1)) ;DBIA #10035 (Supported)
I CURLOCNM]"" D
.N LOC,DIC,X,Y
.S DIC="^DIC(42,",DIC(0)="BX",X=CURLOCNM ;DBIA #1848
.D ^DIC
.S LOC=+Y
.Q:'LOC
.I $$GET1^DIQ(42,LOC,.03)="PSYCHIATRY" S RETURN="INPT" ;DBIA #31
I RETURN="INPT" Q RETURN
;Get last MH admission
S (DONE,INVDT)=0 F S INVDT=$O(^DGPM("ATID1",DFN,INVDT)) Q:(INVDT="") D Q:(DONE=1) ;DBIA #1378
.N MVMT
.S MVMT="" F S MVMT=$O(^DGPM("ATID1",DFN,INVDT,MVMT)) Q:(MVMT="") D Q:(DONE=1) ;DBIA #1378
..N LOC,DCMVMT
..S LOC=$$GET1^DIQ(405,MVMT,.06,"I") ;DBIA #1378
..I LOC="" Q
..I $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY" Q ;not a psychiatry service ward ;DBIA #31
..S DCMVMT=$$GET1^DIQ(405,MVMT,.17,"I") ;DBIA #2090
..S DSCHGDT=$$GET1^DIQ(405,DCMVMT,.01,"I"),DONE=1 Q ;DBIA #1378
;Check transfers also but only if later than last MH discharge date
S (DONE,INVDT)=0 S:$G(DSCHGDT) INVDT=(9999999-($G(DSCHGDT)-.01))
F S INVDT=$O(^DGPM("ATID2",DFN,INVDT)) Q:(INVDT="") 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
..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 Q ;DBIA #1378
I $G(TRNSFRDT)>$G(DSCHGDT) S DSCHGDT=TRNSFRDT
I DSCHGDT'="" S DSCHGDT=$P(DSCHGDT,".",1),RETURN=DSCHGDT
Q RETURN
;
GETLOCS(DATAOUT,ID) ;
; C=Clinics, Z=Other, screened by $$ACTLOC
; Mental Health Locations Only
; Similar to MHLOCS but returns an array for JSON
N XPREF,I,CNT,SCIEN,SCNAM
S CNT=0
D GETMHLOC(.XPREF)
F I=1:1:$L(XPREF("MHLOCS"),";") D
. S SCIEN=$P(XPREF("MHLOCS"),";",I)
. S SCNAM=$P(^SC(SCIEN,0),U) ;DBIA 10040
. Q:$E(SCNAM,1,2)="ZZ" ;ZZ* are inactivated
. S CNT=CNT+1
. S DATAOUT("widgets",ID,"locationList",CNT,"id")=SCIEN
. S DATAOUT("widgets",ID,"locationList",CNT,"name")=SCNAM
Q
GETMHLOC(PREFS) ;Get all Hospital Locations that are Mental Health
; STOP CODE=Mental Health OR Emergency Department
; TYPE=CLINIC
; ACTIVE=TRUE
N STP,STOPCODE,LOCSTR,HL,SCNAM
S LOCSTR=""
S STP="" F S STP=$O(^SC("AST",STP)) Q:STP="" D ;DBIA #4482
.;Get the stop code.
.S STOPCODE=$$GET1^DIQ(40.7,STP,1) ;DBIA #557
.I ((STOPCODE>=500)&(STOPCODE<600))!(STOPCODE=130) D
..S HL=0 F S HL=$O(^SC("AST",STP,HL)) Q:+HL=0 D
...Q:("C"'[$P($G(^SC(HL,0)),U,3)!('$$ACTLOC(HL)))
...S SCNAM=$P(^SC(HL,0),U) ;DBIA 10040
...I $E(SCNAM,1,2)="ZZ" Q ;ZZ* are inactivated locations
...S LOCSTR=LOCSTR_HL_";"
I LOCSTR]"" S LOCSTR=$E(LOCSTR,1,$L(LOCSTR)-1)
S PREFS("MHLOCS")=LOCSTR
Q
ACTLOC(LOC) ; Function: returns TRUE if active hospital location
; IA# 10040.
N NOW,YSDT
S NOW=$$NOW^XLFDT()
S YSDT=$P(NOW,".",1)
N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
I YSDT>$P(X,U)&($P(X,U,2)=""!(YSDT<$P(X,U,2))) Q 0 ; chk reactivate date
Q 1 ; must still be active
;
IDFLT(INSTS,SHOWALL) ;Use default instrument list
; INSTS = return array of Instruments
; SHOWALL = flag to control whether all instruments are returned or not
N LOWER,UPPER,INSTSEQ,MBCID,INSTC,INSTID,INSTNAM
N MNGRP,MNSCL
N DFLST,DISP,INAM,TMPI
N YFN,YSIEN,YSARR,INSTYP
S SHOWALL=$G(SHOWALL)
S DFLST=";PHQ9;BAM-R;PCL-5;GAD-7;"
S INSTC=0,LOWER="abcdefghijklmnopqrstuvwxyz",UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
S MBCID=$O(^YSD(605.1,"B","MBC","")) Q:MBCID=""
S INSTSEQ=0 F S INSTSEQ=$O(^YSD(605.1,MBCID,3,INSTSEQ)) Q:'INSTSEQ D
.S INSTID=^YSD(605.1,MBCID,3,INSTSEQ,0)
.Q:INSTID="" ;Should not occur.
.Q:'$D(^YTT(601.71,INSTID)) ;If Instrument not installed yet.
.S INSTNAM=$TR($P(^YTT(601.71,INSTID,0),U),LOWER,UPPER)
.S TMPI(INSTNAM)=INSTSEQ_U_INSTID
S YFN=605.13
S INSTNAM="" F S INSTNAM=$O(TMPI(INSTNAM)) Q:INSTNAM="" D
.S INSTSEQ=TMPI(INSTNAM),INSTID=$P(INSTSEQ,U,2),INSTSEQ=$P(INSTSEQ,U)
.S YSIEN=INSTSEQ_","_MBCID_"," K YSARR
.D GETS^DIQ(YFN,YSIEN,"**","","YSARR")
.S INSTYP=$G(YSARR(YFN,YSIEN,3))
.S MNGRP=$G(YSARR(YFN,YSIEN,1))
.S MNSCL=$G(YSARR(YFN,YSIEN,2))
.;Check INSTNAM against list of default instruments here Q if not in list
.I SHOWALL="",(DFLST'[(";"_INSTNAM_";")) Q
.S DISP=(DFLST[(";"_INSTNAM_";"))
.S INSTC=INSTC+1,INSTS(INSTC)=INSTID_U_INSTNAM
.;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
.S INSTS(INSTC,"MNGRP")=MNGRP
.S INSTS(INSTC,"MNSCL")=MNSCL
.S INSTS(INSTC,"DISPLAY")=$S(DISP:"true",1:"false")
.S INSTS(INSTC,"TYPE")=INSTYP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSBWHIG2 10790 printed Dec 13, 2024@02:13:29 Page 2
YSBWHIG2 ;SLC/DJE - MHA DASHBOARD ; Apr 01, 2021@16:33
+1 ;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
+2 ;
+3 ; Routine retrieves high risk widget data
+4 ;
+5 ; Reference to SDAMA301 in ICR #4433
+6 ; Reference to ^PXRMINDX in ICR #4229
+7 ; Reference to ^DIC(42) in ICR #3790
+8 ; Reference to ^DIC(42,D0,.03) in ICR #31
+9 ; Reference to ^DGPM("ATID1") in ICR #1378
+10 ; Reference to ^DGPM in ICR #2090
+11 ; Reference to ^SC in ICR #1004
+12 ; Reference to ^SC("AST") in ICR #4482
+13 QUIT
+14 ;
BLDINST(INSTDATA,DFN,INST,YSDT,INSTNM) ;
+1 ;Build a list of instrument results for single score instruments
+2 NEW ADMDT,CUTOFF,COUNT,RESULTS
+3 SET CUTOFF=$$FMADD^XLFDT(YSDT,-90)
SET COUNT=0
+4 ;Get the latest ten results from the last 90 days
+5 ;Need to loop from latest to last
+6 ;S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,INST,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
+7 ;Remove 90 day cutoff
SET ADMDT=""
FOR
SET ADMDT=$ORDER(^PXRMINDX(601.84,"PI",DFN,INST,ADMDT),-1)
if 'ADMDT
QUIT
if COUNT=10
QUIT
Begin DoDot:1
+8 NEW ADMIN
+9 SET ADMIN=0
FOR
SET ADMIN=$ORDER(^PXRMINDX(601.84,"PI",DFN,INST,ADMDT,ADMIN))
if 'ADMIN
QUIT
Begin DoDot:2
+10 NEW RESULT
+11 ;assuming we only have one scale!
SET RESULT=$ORDER(^YTT(601.92,"AC",ADMIN,0))
+12 if 'RESULT
QUIT
+13 SET COUNT=COUNT+1
+14 SET RESULTS(ADMDT,ADMIN)=$PIECE(^YTT(601.92,RESULT,0),U,4)
End DoDot:2
End DoDot:1
+15 IF COUNT=0
Begin DoDot:1
+16 SET INSTDATA(INSTNM,1,"count")=1
+17 SET INSTDATA(INSTNM,1,"date")="N/A"
+18 SET INSTDATA(INSTNM,1,"score")="N/A"
End DoDot:1
QUIT
+19 ;Now need to loop from last to latest
+20 ;reuse count to index the JSON global
SET COUNT=0
+21 SET ADMDT=""
FOR
SET ADMDT=$ORDER(RESULTS(ADMDT))
if 'ADMDT
QUIT
Begin DoDot:1
+22 SET ADMIN=0
FOR
SET ADMIN=$ORDER(RESULTS(ADMDT,ADMIN))
if 'ADMIN
QUIT
Begin DoDot:2
+23 SET COUNT=COUNT+1
+24 SET INSTDATA(INSTNM,COUNT,"count")=COUNT
+25 SET INSTDATA(INSTNM,COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
+26 ;values need to be numeric so we can graph
SET INSTDATA(INSTNM,COUNT,"score")=+RESULTS(ADMDT,ADMIN)
End DoDot:2
End DoDot:1
+27 QUIT
BLDRSL(INSTDATA,DFN,INST,YSDT,INSTNM,QNUM) ;
+1 ;Build a list of instrument results on a particular question
+2 NEW ADMDT,CUTOFF,COUNT,RESULTS
+3 NEW YS,YSDATA,YSIEN,YSANS
+4 SET CUTOFF=$$FMADD^XLFDT(YSDT,-90)
SET COUNT=0
+5 ;Get the latest ten results from the last 90 days
+6 ;Need to loop from latest to last
+7 ;S ADMDT="" F S ADMDT=$O(^PXRMINDX(601.84,"PI",DFN,INST,ADMDT),-1) Q:'ADMDT Q:(ADMDT<CUTOFF) Q:COUNT=10 D
+8 ;Remove 90 day cutoff
SET ADMDT=""
FOR
SET ADMDT=$ORDER(^PXRMINDX(601.84,"PI",DFN,INST,ADMDT),-1)
if 'ADMDT
QUIT
if COUNT=10
QUIT
Begin DoDot:1
+9 NEW ADMIN
+10 SET ADMIN=0
FOR
SET ADMIN=$ORDER(^PXRMINDX(601.84,"PI",DFN,INST,ADMDT,ADMIN))
if 'ADMIN
QUIT
Begin DoDot:2
+11 SET YS("AD")=ADMIN
+12 SET YS("QN")=QNUM
+13 DO GETANS^YTQAPI1(.YSDATA,.YS)
+14 if $GET(YSDATA(1))["ERROR"
QUIT
+15 SET YSIEN=$GET(YSDATA(2))
if +YSIEN=0
QUIT
+16 ;Expects Numerical Legacy Value
SET YSANS=$$GET1^DIQ(601.75,YSIEN_",",4)
+17 ;PHQ9_I9 display/score offset
IF INSTNM="phq9_i9"
IF (+YSANS'=0)
SET YSANS=YSANS-1
+18 SET COUNT=COUNT+1
+19 SET RESULTS(ADMDT,ADMIN)=YSANS
End DoDot:2
End DoDot:1
+20 IF COUNT=0
Begin DoDot:1
+21 SET INSTDATA(INSTNM,1,"count")=1
+22 SET INSTDATA(INSTNM,1,"date")="N/A"
+23 SET INSTDATA(INSTNM,1,"score")="N/A"
End DoDot:1
QUIT
+24 ;Now need to loop from last to latest
+25 ;reuse count to index the JSON global
SET COUNT=0
+26 SET ADMDT=""
FOR
SET ADMDT=$ORDER(RESULTS(ADMDT))
if 'ADMDT
QUIT
Begin DoDot:1
+27 SET ADMIN=0
FOR
SET ADMIN=$ORDER(RESULTS(ADMDT,ADMIN))
if 'ADMIN
QUIT
Begin DoDot:2
+28 SET COUNT=COUNT+1
+29 SET INSTDATA(INSTNM,COUNT,"count")=COUNT
+30 SET INSTDATA(INSTNM,COUNT,"date")=$$FMTE^XLFDT(ADMDT,5)
+31 ;values need to be numeric so we can graph
SET INSTDATA(INSTNM,COUNT,"score")=+RESULTS(ADMDT,ADMIN)
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
MHLSTVST(DFN,YSDT,FROM) ;Get last MH Visit Date up to one year back.
+1 NEW YSDARRAY,APPTLIST
+2 NEW SDCOUNT,PIDX,FIDX,SDTIME,OUTPXENC,NODE,LSTMHDT,STATUS,PSTAT,FLIM,NOW
+3 SET NOW=$$NOW^XLFDT()
+4 SET FLIM=$GET(FROM)
if FLIM=""
SET FLIM=365
+5 SET YSDARRAY(1)=$$FMADD^XLFDT(YSDT,-FLIM)_";"_NOW
+6 SET YSDARRAY(3)="R;I;NS;NSR;CC;CCR;CP;CPR;NT;"
+7 SET YSDARRAY(4)=DFN
+8 SET YSDARRAY("FLDS")="1;2;12;13;18;22"
+9 SET YSDARRAY("SORT")="P"
+10 SET SDCOUNT=$$SDAPI^SDAMA301(.YSDARRAY)
+11 MERGE APPTLIST=^TMP($JOB,"SDAMA301",DFN)
KILL ^TMP($JOB,"SDAMA301")
+12 ;add ^SCE("ADFN" loop to detect Outpatient Encounters with no visit. These will be marked as unscheduled
+13 SET (PIDX,FIDX)=0
+14 ;Start from 1 year back to current
SET SDTIME=$$FMADD^XLFDT(YSDT,-FLIM)
+15 FOR
SET SDTIME=$ORDER(^SCE("ADFN",DFN,SDTIME))
if 'SDTIME
QUIT
Begin DoDot:1
+16 ;already got this visit, must be scheduled
IF $DATA(APPTLIST(SDTIME))
QUIT
+17 SET OUTPXENC=$ORDER(^SCE("ADFN",DFN,SDTIME,0))
+18 SET NODE=^SCE(OUTPXENC,0)
+19 SET APPTLIST(SDTIME)=SDTIME_U_$PIECE(NODE,U,4)_";"_$$GET1^DIQ(44,$PIECE(NODE,U,4),.01)_"^^^^^^^^^^"_OUTPXENC_U_$PIECE(NODE,U,3)_";"_$$GET1^DIQ(40.7,$PIECE(NODE,U,3),1)_"^^^^^4;UV^^^^;;WALK-IN"
End DoDot:1
+20 ; split appointments into past and previous
+21 ;sort previous appointments by reverse date
+22 SET LSTMHDT=""
+23 SET SDTIME=$$FMADD^XLFDT(YSDT,1)
FOR
SET SDTIME=$ORDER(APPTLIST(SDTIME),-1)
if 'SDTIME!LSTMHDT
QUIT
Begin DoDot:1
+24 ;not ED or MH clinic - delete
IF '$$CHKCLIN^YSBDD1(APPTLIST(SDTIME))
KILL APPTLIST(SDTIME)
QUIT
+25 SET NODE=APPTLIST(SDTIME)
+26 SET STATUS=$PIECE(NODE,U,22)
SET PSTAT=$PIECE(STATUS,";",3)
+27 ; also removes " & AUTO-REBOOK"
SET STATUS=$PIECE($PIECE($PIECE(NODE,U,22),";",3)," &")
+28 ;in the future, possible for an appt later today
IF STATUS="11;FUTURE;FUTURE"
QUIT
+29 ;No positive state of this encounter.
IF STATUS["NO ACTION TAKEN"
IF (PSTAT'["CHECKED")
QUIT
+30 ;Inpatient No action taken
IF STATUS["NO ACT TAKN"
IF (PSTAT'["CHECKED")
QUIT
+31 ;Cancelled by Clinic or Cancelled by Patient
IF STATUS["CANCELLED"
QUIT
+32 ;No show
IF STATUS["NO-SHOW"
QUIT
+33 SET LSTMHDT=SDTIME
End DoDot:1
+34 IF 'LSTMHDT
QUIT "N/A"
+35 QUIT $$FMTE^XLFDT($PIECE(LSTMHDT,"."),5)
+36 ;
MHDCDT(DFN) ;Find last mental health discharge date or if mental health inpatient
+1 NEW CURLOCNM,INVDT,RETURN,DONE,DSCHGDT,TRNSFRDT,TRNSCTN,XMVMT
+2 SET RETURN="N/A"
SET DSCHGDT=""
+3 ;check current inpatient ward if it exists
+4 ;DBIA #10035 (Supported)
SET CURLOCNM=$GET(^DPT(DFN,.1))
+5 IF CURLOCNM]""
Begin DoDot:1
+6 NEW LOC,DIC,X,Y
+7 ;DBIA #1848
SET DIC="^DIC(42,"
SET DIC(0)="BX"
SET X=CURLOCNM
+8 DO ^DIC
+9 SET LOC=+Y
+10 if 'LOC
QUIT
+11 ;DBIA #31
IF $$GET1^DIQ(42,LOC,.03)="PSYCHIATRY"
SET RETURN="INPT"
End DoDot:1
+12 IF RETURN="INPT"
QUIT RETURN
+13 ;Get last MH admission
+14 ;DBIA #1378
SET (DONE,INVDT)=0
FOR
SET INVDT=$ORDER(^DGPM("ATID1",DFN,INVDT))
if (INVDT="")
QUIT
Begin DoDot:1
+15 NEW MVMT
+16 ;DBIA #1378
SET MVMT=""
FOR
SET MVMT=$ORDER(^DGPM("ATID1",DFN,INVDT,MVMT))
if (MVMT="")
QUIT
Begin DoDot:2
+17 NEW LOC,DCMVMT
+18 ;DBIA #1378
SET LOC=$$GET1^DIQ(405,MVMT,.06,"I")
+19 IF LOC=""
QUIT
+20 ;not a psychiatry service ward ;DBIA #31
IF $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY"
QUIT
+21 ;DBIA #2090
SET DCMVMT=$$GET1^DIQ(405,MVMT,.17,"I")
+22 ;DBIA #1378
SET DSCHGDT=$$GET1^DIQ(405,DCMVMT,.01,"I")
SET DONE=1
QUIT
End DoDot:2
if (DONE=1)
QUIT
End DoDot:1
if (DONE=1)
QUIT
+23 ;Check transfers also but only if later than last MH discharge date
+24 SET (DONE,INVDT)=0
if $GET(DSCHGDT)
SET INVDT=(9999999-($GET(DSCHGDT)-.01))
+25 ;DBIA #1378
FOR
SET INVDT=$ORDER(^DGPM("ATID2",DFN,INVDT))
if (INVDT="")
QUIT
Begin DoDot:1
+26 NEW MVMT
+27 ;DBIA #1378
SET MVMT=""
FOR
SET MVMT=$ORDER(^DGPM("ATID2",DFN,INVDT,MVMT))
if (MVMT="")
QUIT
Begin DoDot:2
+28 NEW LOC,ADMMVMT,DCMVMT
+29 ;DBIA #1378
SET LOC=$$GET1^DIQ(405,MVMT,.06,"I")
+30 ;find the transaction type, 2=TRANSFER ;DBIA #1378
SET TRNSCTN=$$GET1^DIQ(405,MVMT,.02,"I")
+31 ;not a psychiatry service ward and not a TRANSFER ;DBIA #31
IF $$GET1^DIQ(42,LOC,.03)'="PSYCHIATRY"
IF TRNSCTN'=2
QUIT
+32 ;find admission to find discharge ;DBIA #1378
SET ADMMVMT=$$GET1^DIQ(405,MVMT,.14,"I")
+33 ;DBIA #2090
SET DCMVMT=$$GET1^DIQ(405,ADMMVMT,.17,"I")
+34 SET XMVMT=DCMVMT
+35 ;Don't let a null DCMVMT set the TRNSFRDT
if DCMVMT=""&(TRNSCTN'=2)
QUIT
+36 ;If this is a TRANFER, set the Transfer date
if TRNSCTN=2
SET XMVMT=MVMT
+37 ;DBIA #1378
SET TRNSFRDT=$$GET1^DIQ(405,XMVMT,.01,"I")
SET DONE=1
QUIT
End DoDot:2
if (DONE=1)
QUIT
End DoDot:1
if (DONE=1)
QUIT
+38 IF $GET(TRNSFRDT)>$GET(DSCHGDT)
SET DSCHGDT=TRNSFRDT
+39 IF DSCHGDT'=""
SET DSCHGDT=$PIECE(DSCHGDT,".",1)
SET RETURN=DSCHGDT
+40 QUIT RETURN
+41 ;
GETLOCS(DATAOUT,ID) ;
+1 ; C=Clinics, Z=Other, screened by $$ACTLOC
+2 ; Mental Health Locations Only
+3 ; Similar to MHLOCS but returns an array for JSON
+4 NEW XPREF,I,CNT,SCIEN,SCNAM
+5 SET CNT=0
+6 DO GETMHLOC(.XPREF)
+7 FOR I=1:1:$LENGTH(XPREF("MHLOCS"),";")
Begin DoDot:1
+8 SET SCIEN=$PIECE(XPREF("MHLOCS"),";",I)
+9 ;DBIA 10040
SET SCNAM=$PIECE(^SC(SCIEN,0),U)
+10 ;ZZ* are inactivated
if $EXTRACT(SCNAM,1,2)="ZZ"
QUIT
+11 SET CNT=CNT+1
+12 SET DATAOUT("widgets",ID,"locationList",CNT,"id")=SCIEN
+13 SET DATAOUT("widgets",ID,"locationList",CNT,"name")=SCNAM
End DoDot:1
+14 QUIT
GETMHLOC(PREFS) ;Get all Hospital Locations that are Mental Health
+1 ; STOP CODE=Mental Health OR Emergency Department
+2 ; TYPE=CLINIC
+3 ; ACTIVE=TRUE
+4 NEW STP,STOPCODE,LOCSTR,HL,SCNAM
+5 SET LOCSTR=""
+6 ;DBIA #4482
SET STP=""
FOR
SET STP=$ORDER(^SC("AST",STP))
if STP=""
QUIT
Begin DoDot:1
+7 ;Get the stop code.
+8 ;DBIA #557
SET STOPCODE=$$GET1^DIQ(40.7,STP,1)
+9 IF ((STOPCODE>=500)&(STOPCODE<600))!(STOPCODE=130)
Begin DoDot:2
+10 SET HL=0
FOR
SET HL=$ORDER(^SC("AST",STP,HL))
if +HL=0
QUIT
Begin DoDot:3
+11 if ("C"'[$PIECE($GET(^SC(HL,0)),U,3)!('$$ACTLOC(HL)))
QUIT
+12 ;DBIA 10040
SET SCNAM=$PIECE(^SC(HL,0),U)
+13 ;ZZ* are inactivated locations
IF $EXTRACT(SCNAM,1,2)="ZZ"
QUIT
+14 SET LOCSTR=LOCSTR_HL_";"
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF LOCSTR]""
SET LOCSTR=$EXTRACT(LOCSTR,1,$LENGTH(LOCSTR)-1)
+16 SET PREFS("MHLOCS")=LOCSTR
+17 QUIT
ACTLOC(LOC) ; Function: returns TRUE if active hospital location
+1 ; IA# 10040.
+2 NEW NOW,YSDT
+3 SET NOW=$$NOW^XLFDT()
+4 SET YSDT=$PIECE(NOW,".",1)
+5 ; screen out OOS entry
NEW D0,X
IF +$GET(^SC(LOC,"OOS"))
QUIT 0
+6 ; chk out of svc wards
SET D0=+$GET(^SC(LOC,42))
IF D0
DO WIN^DGPMDDCF
QUIT 'X
+7 ; no inactivate date
SET X=$GET(^SC(LOC,"I"))
IF +X=0
QUIT 1
+8 ; chk reactivate date
IF YSDT>$PIECE(X,U)&($PIECE(X,U,2)=""!(YSDT<$PIECE(X,U,2)))
QUIT 0
+9 ; must still be active
QUIT 1
+10 ;
IDFLT(INSTS,SHOWALL) ;Use default instrument list
+1 ; INSTS = return array of Instruments
+2 ; SHOWALL = flag to control whether all instruments are returned or not
+3 NEW LOWER,UPPER,INSTSEQ,MBCID,INSTC,INSTID,INSTNAM
+4 NEW MNGRP,MNSCL
+5 NEW DFLST,DISP,INAM,TMPI
+6 NEW YFN,YSIEN,YSARR,INSTYP
+7 SET SHOWALL=$GET(SHOWALL)
+8 SET DFLST=";PHQ9;BAM-R;PCL-5;GAD-7;"
+9 SET INSTC=0
SET LOWER="abcdefghijklmnopqrstuvwxyz"
SET UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+10 SET MBCID=$ORDER(^YSD(605.1,"B","MBC",""))
if MBCID=""
QUIT
+11 SET INSTSEQ=0
FOR
SET INSTSEQ=$ORDER(^YSD(605.1,MBCID,3,INSTSEQ))
if 'INSTSEQ
QUIT
Begin DoDot:1
+12 SET INSTID=^YSD(605.1,MBCID,3,INSTSEQ,0)
+13 ;Should not occur.
if INSTID=""
QUIT
+14 ;If Instrument not installed yet.
if '$DATA(^YTT(601.71,INSTID))
QUIT
+15 SET INSTNAM=$TRANSLATE($PIECE(^YTT(601.71,INSTID,0),U),LOWER,UPPER)
+16 SET TMPI(INSTNAM)=INSTSEQ_U_INSTID
End DoDot:1
+17 SET YFN=605.13
+18 SET INSTNAM=""
FOR
SET INSTNAM=$ORDER(TMPI(INSTNAM))
if INSTNAM=""
QUIT
Begin DoDot:1
+19 SET INSTSEQ=TMPI(INSTNAM)
SET INSTID=$PIECE(INSTSEQ,U,2)
SET INSTSEQ=$PIECE(INSTSEQ,U)
+20 SET YSIEN=INSTSEQ_","_MBCID_","
KILL YSARR
+21 DO GETS^DIQ(YFN,YSIEN,"**","","YSARR")
+22 SET INSTYP=$GET(YSARR(YFN,YSIEN,3))
+23 SET MNGRP=$GET(YSARR(YFN,YSIEN,1))
+24 SET MNSCL=$GET(YSARR(YFN,YSIEN,2))
+25 ;Check INSTNAM against list of default instruments here Q if not in list
+26 IF SHOWALL=""
IF (DFLST'[(";"_INSTNAM_";"))
QUIT
+27 SET DISP=(DFLST[(";"_INSTNAM_";"))
+28 SET INSTC=INSTC+1
SET INSTS(INSTC)=INSTID_U_INSTNAM
+29 ;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
+30 SET INSTS(INSTC,"MNGRP")=MNGRP
+31 SET INSTS(INSTC,"MNSCL")=MNSCL
+32 SET INSTS(INSTC,"DISPLAY")=$SELECT(DISP:"true",1:"false")
+33 SET INSTS(INSTC,"TYPE")=INSTYP
End DoDot:1
+34 QUIT
