SDMHAP1 ;MAF/ALB - MENTAL HEALTH AD HOC PROACTIVE HIGH RISK REPORT (CONT.;JULY 14, 2010
;;5.3;Scheduling;**588**;Aug 13,1993;Build 53
;
SET ; 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,SDTOTPG,Y
S (SDXDFN,SDXREM,SDCOUNT)=0
N SDPAT
S SDXDIV=""
F S SDXDIV=$O(^TMP(NAMSPC1,$J,SDXDIV)) Q:SDXDIV']""!(SDUP) D
.I SDTL="CLIN" D
..S SDCOUNT=0
..S SDXNM=""
..F S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM)) Q:SDXNM']""!($G(SDUP)) D
...S SDATE=0
...F S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE)) Q:'SDATE!($G(SDUP)) D
....S SDXCLIN=""
....F S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN)) Q:SDXCLIN']""!($G(SDUP)) D
.....S SDXSTOP=0
.....F S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP)) Q:'SDXSTOP!($G(SDUP)) D
......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP)) D PRT
Q:SDUP
I $D(^TMP(NAMSPC1,$J)) S SDTOTPG=1 D HEAD^SDMHAP D TOTAL1^SDMHPRO
Q
;
;
PRT ;Print report
;
I '$D(SDXFLG(SDXDIV)) D HEAD^SDMHAP S SDXFLG(SDXDIV)=1 S:SDTL'="STOP" SDXFLG(SDXDIV,SDXCLIN)=1
;I SDTL="STOP" I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)) W !! D HEAD1^SDMHAP S SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
N SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDDSS,SDXRLL,SDXZERO
S SDXSORT1=$S(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
S SDXSORT2=$S(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
I SDTL="MEN" S SDXNODE=$G(^TMP(NAMSPC1,$J,SDXDIV,SDXSORT1,SDXSORT2,SDXNM,SDATE))
I SDTL'="MEN" S SDXNODE=$G(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXSORT1,SDXSORT2))
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)
I '$D(SDXFLG(SDXDIV)) D HEAD^SDMHAP S SDXFLG(SDXDIV)=1
S SDXDT=$$FMTE^XLFDT(SDXDT,"5")
I '$D(SDPAT(SDXDIV,SDXDFN)) D COUNT^SDMHPRO W !,SDCOUNT,?4,$E($P(^DPT(SDXDFN,0),"^",1),1,20),?25,SDXID,?32,SDXDT,?49,$E(SDXCLIN,1,30),! D RET Q:SDUP I SDCOUNT=$P($G(TOTAL(SDXDIV)),"^",5) S SDCOUNT=0
I $D(SDPAT(SDXDIV,SDXDFN)) W ?32,SDXDT,?49,$E(SDXCLIN,1,30),! D RET Q:SDUP I SDCOUNT=$P($G(TOTAL(SDXDIV)),"^",5) S SDCOUNT=0
S SDPAT(SDXDIV,SDXDFN)=""
Q
;
;
FUT ; FUTURE SCHEDULED APPTS.
;W !,?5,"Future Scheduled Appointments: "
N SDARRAY,SDCOUNT,SDX,X1,X2,X
S X1=DT,X2=30 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
. N SDFA,SDFNODE,SDFUTDT
. S SDFA=0 F S SDFA=$O(^TMP($J,"SDAMA301",SDXDFN,SDFA)) Q:SDFA=""!(SDUP)!($P($G(SDFA),".",1)<$P(SDBEG,".",1))!($P($G(SDFA),".",1)>$P(SDEND,".",1)) D Q:SDUP
.. S SDFUTDT=$$FMTE^XLFDT(SDFA,"5P") S SDFNODE=^TMP($J,"SDAMA301",SDXDFN,SDFA) W !,?7,SDFUTDT,?33,$E($P($P(SDFNODE,"^",2),";",2),1,20)
..D RET Q:SDUP
.Q
I SDCOUNT'>0 D Q:SDUP
.W "NO APPOINTMENTS SCHEDULED WITHIN 30 DAYS"
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")
;
;
RET ;
I $E(IOST,1,2)="C-",($Y+6)>IOSL D Q:SDUP
. S DIR(0)="E"
. D ^DIR K DIR
. I 'Y S SDUP=1 Q
. K SDXFLG(SDXDIV)
. D HEAD^SDMHAP S SDXFLG(SDXDIV)=1 ;,SDXFLG(SDXDIV,SDXCLIN)=1,SDXFLG(SDXDIV,SDXSTOP)=1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDMHAP1 3777 printed Sep 23, 2025@20:35:28 Page 2
SDMHAP1 ;MAF/ALB - MENTAL HEALTH AD HOC PROACTIVE HIGH RISK REPORT (CONT.;JULY 14, 2010
+1 ;;5.3;Scheduling;**588**;Aug 13,1993;Build 53
+2 ;
SET ; 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,SDTOTPG,Y
+2 SET (SDXDFN,SDXREM,SDCOUNT)=0
+3 NEW SDPAT
+4 SET SDXDIV=""
+5 FOR
SET SDXDIV=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV))
if SDXDIV']""!(SDUP)
QUIT
Begin DoDot:1
+6 IF SDTL="CLIN"
Begin DoDot:2
+7 SET SDCOUNT=0
+8 SET SDXNM=""
+9 FOR
SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM))
if SDXNM']""!($GET(SDUP))
QUIT
Begin DoDot:3
+10 SET SDATE=0
+11 FOR
SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE))
if 'SDATE!($GET(SDUP))
QUIT
Begin DoDot:4
+12 SET SDXCLIN=""
+13 FOR
SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN))
if SDXCLIN']""!($GET(SDUP))
QUIT
Begin DoDot:5
+14 SET SDXSTOP=0
+15 FOR
SET SDXSTOP=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
if 'SDXSTOP!($GET(SDUP))
QUIT
Begin DoDot:6
+16 IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
DO PRT
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 if SDUP
QUIT
+18 IF $DATA(^TMP(NAMSPC1,$JOB))
SET SDTOTPG=1
DO HEAD^SDMHAP
DO TOTAL1^SDMHPRO
+19 QUIT
+20 ;
+21 ;
PRT ;Print report
+1 ;
+2 IF '$DATA(SDXFLG(SDXDIV))
DO HEAD^SDMHAP
SET SDXFLG(SDXDIV)=1
if SDTL'="STOP"
SET SDXFLG(SDXDIV,SDXCLIN)=1
+3 ;I SDTL="STOP" I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)) W !! D HEAD1^SDMHAP S SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
+4 NEW SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDDSS,SDXRLL,SDXZERO
+5 SET SDXSORT1=$SELECT(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
+6 SET SDXSORT2=$SELECT(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
+7 IF SDTL="MEN"
SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSORT1,SDXSORT2,SDXNM,SDATE))
+8 IF SDTL'="MEN"
SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXSORT1,SDXSORT2))
+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 IF '$DATA(SDXFLG(SDXDIV))
DO HEAD^SDMHAP
SET SDXFLG(SDXDIV)=1
+16 SET SDXDT=$$FMTE^XLFDT(SDXDT,"5")
+17 IF '$DATA(SDPAT(SDXDIV,SDXDFN))
DO COUNT^SDMHPRO
WRITE !,SDCOUNT,?4,$EXTRACT($PIECE(^DPT(SDXDFN,0),"^",1),1,20),?25,SDXID,?32,SDXDT,?49,$EXTRACT(SDXCLIN,1,30),!
DO RET
if SDUP
QUIT
IF SDCOUNT=$PIECE($GET(TOTAL(SDXDIV)),"^",5)
SET SDCOUNT=0
+18 IF $DATA(SDPAT(SDXDIV,SDXDFN))
WRITE ?32,SDXDT,?49,$EXTRACT(SDXCLIN,1,30),!
DO RET
if SDUP
QUIT
IF SDCOUNT=$PIECE($GET(TOTAL(SDXDIV)),"^",5)
SET SDCOUNT=0
+19 SET SDPAT(SDXDIV,SDXDFN)=""
+20 QUIT
+21 ;
+22 ;
FUT ; FUTURE SCHEDULED APPTS.
+1 ;W !,?5,"Future Scheduled Appointments: "
+2 NEW SDARRAY,SDCOUNT,SDX,X1,X2,X
+3 SET X1=DT
SET X2=30
DO C^%DTC
SET SDX=X
+4 SET SDARRAY(1)=DT_";"_SDX
+5 SET SDARRAY("SORT")="P"
+6 SET SDARRAY(3)="NT;R"
+7 SET SDARRAY(4)=SDXDFN
+8 SET SDARRAY("FLDS")="1;2;3;4;10;13"
+9 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
+10 IF SDCOUNT>0
Begin DoDot:1
+11 ;Get info on future scheduled appointments and display it
+12 NEW SDFA,SDFNODE,SDFUTDT
+13 SET SDFA=0
FOR
SET SDFA=$ORDER(^TMP($JOB,"SDAMA301",SDXDFN,SDFA))
if SDFA=""!(SDUP)!($PIECE($GET(SDFA),".",1)<$PIECE(SDBEG,".",1))!($PIECE($GET(SDFA),".",1)>$PIECE(SDEND,".",1))
QUIT
Begin DoDot:2
+14 SET SDFUTDT=$$FMTE^XLFDT(SDFA,"5P")
SET SDFNODE=^TMP($JOB,"SDAMA301",SDXDFN,SDFA)
WRITE !,?7,SDFUTDT,?33,$EXTRACT($PIECE($PIECE(SDFNODE,"^",2),";",2),1,20)
+15 DO RET
if SDUP
QUIT
End DoDot:2
if SDUP
QUIT
+16 QUIT
End DoDot:1
if SDUP
QUIT
+17 IF SDCOUNT'>0
Begin DoDot:1
+18 WRITE "NO APPOINTMENTS SCHEDULED WITHIN 30 DAYS"
End DoDot:1
if SDUP
QUIT
+19 KILL ^TMP($JOB,"SDAMA301")
+20 QUIT
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 ;
+7 ;
RET ;
+1 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y+6)>IOSL
Begin DoDot:1
+2 SET DIR(0)="E"
+3 DO ^DIR
KILL DIR
+4 IF 'Y
SET SDUP=1
QUIT
+5 KILL SDXFLG(SDXDIV)
+6 ;,SDXFLG(SDXDIV,SDXCLIN)=1,SDXFLG(SDXDIV,SDXSTOP)=1
DO HEAD^SDMHAP
SET SDXFLG(SDXDIV)=1
End DoDot:1
if SDUP
QUIT
