SDMHPRO1 ;MAF/ALB,JAS - MENTAL HEALTH PROACTIVE HIGH RISK REPORT (BGJ CONT.) ; MAR 29, 2024@14:00
;;5.3;Scheduling;**588,877**;Aug 13,1993;Build 14
;;Per VHA Directive 6402, this routine should not be modified
DATA ; Set up the data for the patient
; piece 1 = dfn
; piece 2 = Appointment Date and time
; piece 3 = status N(Noshow) or NA (Noshow with auto rebook)
; piece 4 = PID last 4 of SSN
; piece 5 = clinic ien ^SC(
; piece 6 = stop code ien ^DIC(40.7
;
;
EN ;PRINT OF THE ^TMP
N SDXDIV,SDXCLIN,SDXDFN,SDXSTOP,SDXREM,SDXNM,SDCOUNT,SDATE
S (SDXDFN,SDXREM,SDCOUNT)=0
K SDPAT
I $D(^TMP(NAMSPC1,$J)) D TOTAL^SDMHPRO
S SDXDIV=""
F S SDXDIV=$O(^TMP(NAMSPC1,$J,SDXDIV)) Q:SDXDIV']""!(SDUP) D
.S SDCOUNT=0
.I SDTL="CLIN" D N SDX S SDX=$$SETSTR(" ",X,1,79) D SET1(SDX)
..S SDXNM=""
..F S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM)) Q:SDXNM']""!(SDUP) D
...S SDATE=0
...F S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE)) Q:'SDATE!(SDUP) D
....S SDXCLIN=""
....F S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN)) Q:SDXCLIN']""!(SDUP) D
.....S SDXSTOP=0
.....F S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP)) Q:'SDXSTOP!(SDUP) D
......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP)) Q:$D(SDPAT(SDXDIV,$O(^DPT("B",$E(SDXNM,1,30),0)))) D PRT
.N SDX S SDX=$$SETSTR(" ",X,1,81) D SET1(SDX)
Q
;
;
PRT ;Print report
N SDX,SDXX
D COUNT^SDMHPRO
I '$D(SDXFLG(SDXDIV)) D HEAD^SDMHPRO S SDXFLG(SDXDIV)=1,SDXFLG(SDXDIV,SDXCLIN)=1
I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV)) S SDX=$$SETSTR("",X,1,80) D SET1(SDX) D HEAD1^SDMHPRO S SDXFLG(SDXDIV)=1
N SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDX,SDDSS
S SDXSORT1=$S(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
S SDXSORT2=$S(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
S SDXNODE=$G(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
S SDXDFN=$P(SDXNODE,"^",1) Q:SDXDFN']""
S SDXID=$E($P(SDXNODE,"^",4),1,5)
S SDXDT=$P(SDXNODE,"^",2)
S SDXSTAT=$P(SDXNODE,"^",3)
S SDXCLIEN=$P(SDXNODE,"^",5)
S SDDSS=$P($G(^DIC(40.7,+$P(SDXNODE,"^",6),0)),"^",2)
S SDPAT(SDXDIV,SDXDFN)=""
I '$D(SDXFLG(SDXDIV)) D HEAD1^SDMHPRO S SDXFLG(SDXDIV)=1
S SDXDT=$$FMTE^XLFDT(SDXDT,"5")
D SET
S SDXX=$$SETSTR(SDCOUNT,X,1,2)_$$SETSTR($P(^DPT(SDXDFN,0),"^",1),X,3,20)_$$SETSTR(SDXID,X,2,5) I SDCOUNT=$P($G(TOTAL(SDXDIV)),"^",1) S SDCOUNT=0
D FUT
Q
;
;
SETSTR(W,X,Y,Z) ;SET UP THE STRING
;W= String
;X= Variable to set it into
;Y= column to set it into
;Z= length of the string
S X=$$SETSTR^SDUL1(W,X,Y,Z)
Q X
SET1(X) ;Sets the XMTEXT global
S SDLN=SDLN+1,^TMP("SDMHP",$J,SDLN,0)=X Q
SET ;
S X="" S SDLN=SDLN+1,^TMP("SDPRO1",$J,SDLN,0)=X
Q
;
;
FUT ; FUTURE SCHEDULED APPTS.
N SDARRAY,SDCOUNT,SDX,X1,X2,X,SDPRODAY
S SDPRODAY=$$GET^XPAR("SYS^PKG.SCHEDULING","SDMH PROACTIVE DAYS",1,"Q")
S SDPRODAY=$S(SDPRODAY]"":SDPRODAY,1:30)
;Find Scheduled apointments for SDPRODAY days using scheduling API
S X1=DT,X2=SDPRODAY D C^%DTC S SDX=X
S SDARRAY(1)=DT_";"_SDX
S SDARRAY("SORT")="P"
S SDARRAY(3)="NT;R"
S SDARRAY(4)=SDXDFN
S SDARRAY("FLDS")="1;2;3;4;10;13"
S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
I SDCOUNT>0 D Q:SDUP
.;Get info on future scheduled appointments and display it
. S SDX="",X=""
. N SDFA,SDFNODE,SDFUTDT
. S SDFA=0 F S SDFA=$O(^TMP($J,"SDAMA301",SDXDFN,SDFA)) Q:SDFA="" D ;!($P($G(SDFA),".",1))'=$P(SDBEG,".",1) D
..S (SDX,X)=""
..S SDFUTDT=$$FMTE^XLFDT(SDFA,"5") S SDFNODE=^TMP($J,"SDAMA301",SDXDFN,SDFA)
..N SDCLCD S SDCLCD=$P($P($G(SDFNODE),"^",2),";",1) I SDCLCD]"" S SDCLCD=$P($G(^SC(SDCLCD,0)),"^",15) Q:SDXDIV'=$P($G(^DG(40.8,SDCLCD,0)),"^",1)
..I '$D(SDXX) S SDX=$$SETSTR(SDFUTDT,X,32,16)_$$SETSTR($P($P(SDFNODE,"^",2),";",2),X,2,30)
..I $D(SDXX) S SDX=SDXX_$$SETSTR(SDFUTDT,X,2,16)_$$SETSTR($P($P(SDFNODE,"^",2),";",2),X,2,30) K SDXX
..D SET1(SDX)
.N SDX S SDX=$$SETSTR(" ",X,1,81) D SET1(SDX)
.Q
I SDCOUNT'>0 D
.S (SDX,X)=""
.S SDX=" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN "_SDPRODAY_$S(SDPRODAY=1:" DAY",1:" DAYS")
.S SDX=$$SETSTR(SDX,X,1,80) D SET1(SDX)
;.S SDX=$$SETSTR(" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN 30 DAYS",X,1,80) D SET1(SDX)
K ^TMP($J,"SDAMA301")
Q
;
;
PID(DFN) ; Return PID
; INPUT - DFN
; OUTPUT - PID or 'UNKNOWN'
N VA
D PID^VADPT6
Q $S(VA("BID")]"":VA("BID"),1:"UNKNOWN")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDMHPRO1 4480 printed Nov 22, 2024@18:08:34 Page 2
SDMHPRO1 ;MAF/ALB,JAS - MENTAL HEALTH PROACTIVE HIGH RISK REPORT (BGJ CONT.) ; MAR 29, 2024@14:00
+1 ;;5.3;Scheduling;**588,877**;Aug 13,1993;Build 14
+2 ;;Per VHA Directive 6402, this routine should not be modified
DATA ; Set up the data for the patient
+1 ; piece 1 = dfn
+2 ; piece 2 = Appointment Date and time
+3 ; piece 3 = status N(Noshow) or NA (Noshow with auto rebook)
+4 ; piece 4 = PID last 4 of SSN
+5 ; piece 5 = clinic ien ^SC(
+6 ; piece 6 = stop code ien ^DIC(40.7
+7 ;
+8 ;
EN ;PRINT OF THE ^TMP
+1 NEW SDXDIV,SDXCLIN,SDXDFN,SDXSTOP,SDXREM,SDXNM,SDCOUNT,SDATE
+2 SET (SDXDFN,SDXREM,SDCOUNT)=0
+3 KILL SDPAT
+4 IF $DATA(^TMP(NAMSPC1,$JOB))
DO TOTAL^SDMHPRO
+5 SET SDXDIV=""
+6 FOR
SET SDXDIV=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV))
if SDXDIV']""!(SDUP)
QUIT
Begin DoDot:1
+7 SET SDCOUNT=0
+8 IF SDTL="CLIN"
Begin DoDot:2
+9 SET SDXNM=""
+10 FOR
SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM))
if SDXNM']""!(SDUP)
QUIT
Begin DoDot:3
+11 SET SDATE=0
+12 FOR
SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE))
if 'SDATE!(SDUP)
QUIT
Begin DoDot:4
+13 SET SDXCLIN=""
+14 FOR
SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN))
if SDXCLIN']""!(SDUP)
QUIT
Begin DoDot:5
+15 SET SDXSTOP=0
+16 FOR
SET SDXSTOP=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
if 'SDXSTOP!(SDUP)
QUIT
Begin DoDot:6
+17 IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
if $DATA(SDPAT(SDXDIV,$ORDER(^DPT("B",$EXTRACT(SDXNM,1,30),0))))
QUIT
DO PRT
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
NEW SDX
SET SDX=$$SETSTR(" ",X,1,79)
DO SET1(SDX)
+18 NEW SDX
SET SDX=$$SETSTR(" ",X,1,81)
DO SET1(SDX)
End DoDot:1
+19 QUIT
+20 ;
+21 ;
PRT ;Print report
+1 NEW SDX,SDXX
+2 DO COUNT^SDMHPRO
+3 IF '$DATA(SDXFLG(SDXDIV))
DO HEAD^SDMHPRO
SET SDXFLG(SDXDIV)=1
SET SDXFLG(SDXDIV,SDXCLIN)=1
+4 IF $DATA(SDXFLG(SDXDIV))
IF '$DATA(SDXFLG(SDXDIV))
SET SDX=$$SETSTR("",X,1,80)
DO SET1(SDX)
DO HEAD1^SDMHPRO
SET SDXFLG(SDXDIV)=1
+5 NEW SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDX,SDDSS
+6 SET SDXSORT1=$SELECT(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
+7 SET SDXSORT2=$SELECT(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
+8 SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
+9 SET SDXDFN=$PIECE(SDXNODE,"^",1)
if SDXDFN']""
QUIT
+10 SET SDXID=$EXTRACT($PIECE(SDXNODE,"^",4),1,5)
+11 SET SDXDT=$PIECE(SDXNODE,"^",2)
+12 SET SDXSTAT=$PIECE(SDXNODE,"^",3)
+13 SET SDXCLIEN=$PIECE(SDXNODE,"^",5)
+14 SET SDDSS=$PIECE($GET(^DIC(40.7,+$PIECE(SDXNODE,"^",6),0)),"^",2)
+15 SET SDPAT(SDXDIV,SDXDFN)=""
+16 IF '$DATA(SDXFLG(SDXDIV))
DO HEAD1^SDMHPRO
SET SDXFLG(SDXDIV)=1
+17 SET SDXDT=$$FMTE^XLFDT(SDXDT,"5")
+18 DO SET
+19 SET SDXX=$$SETSTR(SDCOUNT,X,1,2)_$$SETSTR($PIECE(^DPT(SDXDFN,0),"^",1),X,3,20)_$$SETSTR(SDXID,X,2,5)
IF SDCOUNT=$PIECE($GET(TOTAL(SDXDIV)),"^",1)
SET SDCOUNT=0
+20 DO FUT
+21 QUIT
+22 ;
+23 ;
SETSTR(W,X,Y,Z) ;SET UP THE STRING
+1 ;W= String
+2 ;X= Variable to set it into
+3 ;Y= column to set it into
+4 ;Z= length of the string
+5 SET X=$$SETSTR^SDUL1(W,X,Y,Z)
+6 QUIT X
SET1(X) ;Sets the XMTEXT global
+1 SET SDLN=SDLN+1
SET ^TMP("SDMHP",$JOB,SDLN,0)=X
QUIT
SET ;
+1 SET X=""
SET SDLN=SDLN+1
SET ^TMP("SDPRO1",$JOB,SDLN,0)=X
+2 QUIT
+3 ;
+4 ;
FUT ; FUTURE SCHEDULED APPTS.
+1 NEW SDARRAY,SDCOUNT,SDX,X1,X2,X,SDPRODAY
+2 SET SDPRODAY=$$GET^XPAR("SYS^PKG.SCHEDULING","SDMH PROACTIVE DAYS",1,"Q")
+3 SET SDPRODAY=$SELECT(SDPRODAY]"":SDPRODAY,1:30)
+4 ;Find Scheduled apointments for SDPRODAY days using scheduling API
+5 SET X1=DT
SET X2=SDPRODAY
DO C^%DTC
SET SDX=X
+6 SET SDARRAY(1)=DT_";"_SDX
+7 SET SDARRAY("SORT")="P"
+8 SET SDARRAY(3)="NT;R"
+9 SET SDARRAY(4)=SDXDFN
+10 SET SDARRAY("FLDS")="1;2;3;4;10;13"
+11 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
+12 IF SDCOUNT>0
Begin DoDot:1
+13 ;Get info on future scheduled appointments and display it
+14 SET SDX=""
SET X=""
+15 NEW SDFA,SDFNODE,SDFUTDT
+16 ;!($P($G(SDFA),".",1))'=$P(SDBEG,".",1) D
SET SDFA=0
FOR
SET SDFA=$ORDER(^TMP($JOB,"SDAMA301",SDXDFN,SDFA))
if SDFA=""
QUIT
Begin DoDot:2
+17 SET (SDX,X)=""
+18 SET SDFUTDT=$$FMTE^XLFDT(SDFA,"5")
SET SDFNODE=^TMP($JOB,"SDAMA301",SDXDFN,SDFA)
+19 NEW SDCLCD
SET SDCLCD=$PIECE($PIECE($GET(SDFNODE),"^",2),";",1)
IF SDCLCD]""
SET SDCLCD=$PIECE($GET(^SC(SDCLCD,0)),"^",15)
if SDXDIV'=$PIECE($GET(^DG(40.8,SDCLCD,0)),"^",1)
QUIT
+20 IF '$DATA(SDXX)
SET SDX=$$SETSTR(SDFUTDT,X,32,16)_$$SETSTR($PIECE($PIECE(SDFNODE,"^",2),";",2),X,2,30)
+21 IF $DATA(SDXX)
SET SDX=SDXX_$$SETSTR(SDFUTDT,X,2,16)_$$SETSTR($PIECE($PIECE(SDFNODE,"^",2),";",2),X,2,30)
KILL SDXX
+22 DO SET1(SDX)
End DoDot:2
+23 NEW SDX
SET SDX=$$SETSTR(" ",X,1,81)
DO SET1(SDX)
+24 QUIT
End DoDot:1
if SDUP
QUIT
+25 IF SDCOUNT'>0
Begin DoDot:1
+26 SET (SDX,X)=""
+27 SET SDX=" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN "_SDPRODAY_$SELECT(SDPRODAY=1:" DAY",1:" DAYS")
+28 SET SDX=$$SETSTR(SDX,X,1,80)
DO SET1(SDX)
End DoDot:1
+29 ;.S SDX=$$SETSTR(" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN 30 DAYS",X,1,80) D SET1(SDX)
+30 KILL ^TMP($JOB,"SDAMA301")
+31 QUIT
+32 ;
+33 ;
PID(DFN) ; Return PID
+1 ; INPUT - DFN
+2 ; OUTPUT - PID or 'UNKNOWN'
+3 NEW VA
+4 DO PID^VADPT6
+5 QUIT $SELECT(VA("BID")]"":VA("BID"),1:"UNKNOWN")
+6 ;
