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