SDMHAD1 ;MAF/ALB - MENTAL HEALTH AD HOC NO SHOW REPORT(cont.);JULY 14, 2010
;;5.3;Scheduling;**578,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
S (SDXDFN,SDXREM,SDCOUNT)=0
S SDXDIV=""
F S SDXDIV=$O(^TMP(NAMSPC1,$J,SDXDIV)) Q:SDXDIV']""!(SDUP) D
.I SDTL="CLIN" D
..S SDXCLIN=""
..F S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN)) Q:SDXCLIN']""!($G(SDUP)) D
...S SDXNM=""
...F S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM)) Q:SDXNM']""!($G(SDUP)) D
....S SDXSTOP=0
....F S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP)) Q:'SDXSTOP!($G(SDUP)) D
.....S SDATE=0
.....F S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE)) Q:'SDATE!($G(SDUP)) D
......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE)) D PRT
.I SDTL="STOP" N SDXSTOPN D
..S SDXSTOP=0
..F S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP)) Q:SDXSTOP']""!($G(SDUP)) D
...S SDXNM=""
...F S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM)) Q:SDXNM']""!($G(SDUP)) D
....S SDXCLIN=""
....F S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN)) Q:SDXCLIN']""!($G(SDUP)) D
.....S SDATE=0
.....F S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE)) Q:'SDATE!($G(SDUP)) D
......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE)) S SDXSTOPN=$P(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE),"^",6) D PRT
.I SDTL="MEN" D
..S SDXREM=""
..F S SDXREM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM)) Q:SDXREM']""!($G(SDUP)) D
...S SDXCLIN=""
...F S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN)) Q:SDXCLIN']""!($G(SDUP)) D
....S SDXNM=""
....F S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM)) Q:SDXNM']""!($G(SDUP)) D
.....S SDATE=0
.....F S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE)) Q:'SDATE!($G(SDUP)) D
......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE)) S SDXSTOP=$P(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE),"^",6) D PRT
Q:SDUP
I $D(^TMP(NAMSPC1,$J)) S SDTOTPG=1 D HEAD^SDMHAD D TOTAL1^SDMHNS
Q
;
;
PRT ;Print report
;
I '$D(SDXFLG(SDXDIV)) D HEAD^SDMHAD S SDXFLG(SDXDIV)=1 S:SDTL'="STOP" SDXFLG(SDXDIV,SDXCLIN)=1 S:SDTL="STOP" SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
I SDTL="CLIN" I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV,SDXCLIN)) W !! D HEAD1^SDMHAD S SDXFLG(SDXDIV,SDXCLIN)=1
I SDTL="STOP" I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)) W !! D HEAD1^SDMHAD S SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
D COUNT^SDMHNS
N SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDDSS,SDXRLL,SDXZERO,SDPROV
S SDPROV=0
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,SDXSORT1,SDXNM,SDXSORT2,SDATE))
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 SDXDT=$$FMTE^XLFDT(SDXDT,"5") W !!,SDCOUNT,?4,$E($P(^DPT(SDXDFN,0),"^",1),1,20),?25,SDXID,?31,SDXDT,?49,$E(SDXCLIN,1,30)
W !?47,$E("*"_SDXSTAT,1,5) D PROV W ?53,$E(SDPROV,1,26) D RET Q:SDUP I SDCOUNT=$P($G(TOTAL(SDXDIV,SDXCLIN)),"^",1) S SDCOUNT=0
D RET Q:SDUP ;D PROV Q:SDUP
D PATINFO Q:SDUP
D RET Q:SDUP D NOK Q:SDUP
D RET Q:SDUP D EC Q:SDUP
;D RET Q:SDUP D PROV Q:SDUP
D RET Q:SDUP D MHTC Q:SDUP
D RET Q:SDUP D FUT Q:SDUP
D RET Q:SDUP D RESULTS Q:SDUP
Q
;
;
PATINFO ;Patients home, cell and office phones
N SDPHON,VAROOT,VAOA,SDEC6,SDEC5,DFN
S DFN=SDXDFN,VAROOT="SDEC6" D ADD^VADPT
I $D(SDEC6) D
.S SDPHON("HOME")=SDEC6(8)
S DFN=SDXDFN,VAOA("A")=5,VAROOT="SDEC5" D OAD^VADPT
I $D(SDEC5) D
.S SDPHON("WORK")=SDEC5(8)
D GETS^DIQ(2,SDXDFN_",",".134","E","SDPHON")
I $D(SDPHON(2,SDXDFN_",")) D
.S SDPHON("CELL")=$G(SDPHON(2,SDXDFN_",",".134","E"))
I $D(SDPHON("HOME")),SDPHON("HOME")]"" W !,?5,"Home: ",$$HLPHONE^HLFNC(SDPHON("HOME"),,) D RET Q:SDUP
I $D(SDPHON("WORK")),SDPHON("WORK")]"" W !,?5,"Work: ",$$HLPHONE^HLFNC(SDPHON("WORK"),,) D RET Q:SDUP
I $D(SDPHON("CELL")),SDPHON("CELL")]"" W !,?5,"Cell: ",$$HLPHONE^HLFNC(SDPHON("CELL"),,) D RET Q:SDUP
Q
;
;
NOK ; Next of Kin information
N SDNOK,SDNOK2,SDNOKNM,SDNOKNM2,SDNOKR,SDNOKR2,SDNOKPH,SDNOKPH2,SDNOKPO,SDNOKPO2,SDNOKFL,VAOA,VAROOT,SDEC3,SDEC4,SDPHON,DFN
S DFN=SDXDFN,VAROOT="SDEC3" D OAD^VADPT
S DFN=SDXDFN,VAOA("A")=3,VAROOT="SDEC4" D OAD^VADPT
D GETS^DIQ(2,SDXDFN_",",".21011;.211011","E","SDPHON")
I $D(SDPHON(2,SDXDFN_",")) D
.S SDPHON("K-WORK")=$G(SDPHON(2,SDXDFN_",",".21011","E"))
.S SDPHON("K2-WORK")=$G(SDPHON(2,SDXDFN_",",".211011","E"))
I $D(SDEC3) D
.S SDNOKNM=SDEC3(9),SDNOKR=SDEC3(10),SDNOKPH=SDEC3(8),SDNOKPO=SDPHON("K-WORK")
I $D(SDEC4) D
.S SDNOKNM2=SDEC4(9),SDNOKR2=SDEC4(10),SDNOKPH2=SDEC3(8),SDNOKPO2=SDPHON("K2-WORK")
I SDNOKNM]""!(SDNOKNM2]"") D NOKFL D RET Q:SDUP
I SDNOKNM]"" W ?7,"NOK: "_SDNOKNM D RET Q:SDUP
I SDNOKNM2]"" W ?45,"NOK2: "_SDNOKNM2
I SDNOKR]""!(SDNOKR2]"") D D RET Q:SDUP
.I '$D(SDNOKFL) D NOKFL Q
.W !
I SDNOKR]"" W ?7,"Relation: "_SDNOKR D RET Q:SDUP
I SDNOKR2]"" W ?45,"Relation: "_SDNOKR2
I SDNOKPH]""!(SDNOKPH2]"") D D RET Q:SDUP
.I '$D(SDNOKFL) D NOKFL Q
.W !
D RET Q:SDUP
I SDNOKPH]"" W ?7,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH,,)
I SDNOKPH2]"" W ?45,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH2,,)
I SDNOKPO]""!(SDNOKPO2]"") D D RET Q:SDUP
.I '$D(SDNOKFL) D NOKFL Q
.W !
I SDNOKPO]"" W ?7,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO,,)
I SDNOKPO2]"" W ?45,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO2,,)
W ! D RET Q:SDUP
Q
;
;
NOKFL W !!," Next of Kin:",! S SDNOKFL=1
Q
;
;
EC ;display emergency contact information
N SDEC1,SDEC2,SDPHON,VAROOT,VAOA
Q:'$G(SDXDFN)
N DFN
S DFN=SDXDFN
S VAOA("A")=1,VAROOT="SDEC1" D OAD^VADPT ; Get Primary EC
S VAOA("A")=4,VAROOT="SDEC2" D OAD^VADPT ; Get Secondary EC
D GETS^DIQ(2,SDXDFN_",",".33011;.331011","E","SDPHON")
I $D(SDPHON(2,SDXDFN_",")) D
.S SDPHON("E-WORK")=$G(SDPHON(2,SDXDFN_",",".33011","E"))
.S SDPHON("E2-WORK")=$G(SDPHON(2,SDXDFN_",",".331011","E"))
I SDEC1(9)]"" D
. D RET Q:SDUP I $D(SDEC1)!($D(SDEC2)) W !,?5,"Emergency Contact:" D RET Q:SDUP
. ;Contacts name and realtionship
. I SDEC1(9)]"" W !?7,"E-Cont.: ",SDEC1(9)
. I SDEC2(9)]"" I SDEC2(9)]"" W ?45,"E2-Cont.: ",SDEC2(9)
. D RET Q:SDUP I SDEC1(10)]"" W !,?7,"Relation: ",SDEC1(10)
. I SDEC2(10)]"" W ?45,"Relation: ",SDEC2(10)
. ;ECs address lines 1, 2 and 3
. D RET Q:SDUP I SDEC1(1)]"" W !,?9,SDEC1(1)
. I SDEC1(1)']"",SDEC2(1)]"" D RET Q:SDUP W !
. I SDEC2(1)]"" W ?47,SDEC2(1)
. D RET Q:SDUP I SDEC1(2)]"" W !,?9,SDEC1(2)
. I SDEC1(2)']"",SDEC2(2)]"" D RET Q:SDUP W !
. I SDEC2(2)]"" W ?47,SDEC2(2)
. D RET Q:SDUP I SDEC1(3)]"" W !,?9,SDEC1(3)
. I SDEC1(3)']"",SDEC2(3)]"" D RET Q:SDUP W !
. I SDEC2(3)]"" W ?47,SDEC2(3)
. ;Emergency Contact 1 City, State an Zip+4
. I SDEC1(4)]"" D
. . D RET Q:SDUP W !,?9,SDEC1(4)
. . I SDEC1(5)]"" W ", "_$$GET1^DIQ(5,+SDEC1(5),1)
. . W " ",$P(SDEC1(11),"^",2)
. ;Emergency Contact 2 City State and Zip+4
. I SDEC2(4)]"" D
. . D RET Q:SDUP I SDEC1(4)']"" W !
. . W ?47,SDEC2(4)
. . I SDEC2(5)]"" W ", "_$$GET1^DIQ(5,+SDEC2(5),1)
. . W " ",$P(SDEC2(11),"^",2)
. ;Home and work phones
. D RET Q:SDUP I SDEC1(8)]"" W !,?7,"Phone: "_$$HLPHONE^HLFNC(SDEC1(8),,)
. I SDEC2(8)]"" W ?45,"Phone: "_$$HLPHONE^HLFNC(SDEC2(8),,)
. D RET Q:SDUP I SDPHON("E-WORK")]"" W !?7,"Work Phone: "_$$HLPHONE^HLFNC(SDPHON("E-WORK"),,) ;,$S($P(^DPT(DFN,.33),U,11)]"":$P(^DPT(DFN,.33),U,11),1:"UNSPECIFIED")
. I SDPHON("E2-WORK")]"" W ?45,"Work Phone: "_$$HLPHONE^HLFNC(SDPHON("E2-WORK"),,) ;,$S($P(^DPT(DFN,.331),U,11)]"":$P(^DPT(DFN,.331),U,11),1:"UNSPECIFIED")
D KVAR^VADPT
Q
;
;
PROV ;Clinic Default Provider
N SDPNUM,SDPNODE
S SDPNUM=0
F SDPNUM=0:0 S SDPNUM=$O(^SC(SDXCLIEN,"PR",SDPNUM)) Q:'(+SDPNUM) I $D(^SC(SDXCLIEN,"PR",SDPNUM,0)) S SDPNODE=^SC(SDXCLIEN,"PR",SDPNUM,0) I $P(SDPNODE,"^",1)&($P(SDPNODE,"^",2)) D Q:SDUP
. S SDPROV=$E($P(^VA(200,$P(SDPNODE,"^",1),0),"^",1),1,25) ;D RET
;.W !,?5,"Provider: "_$P(^VA(200,$P(SDPNODE,"^",1),0),"^",1) D RET
Q
;
;
MHTC ;Mental Health Treatment Coordinator
;Q:'$T(START^SCMCMHTC)
W !
N SDMHTC,MHTC,SDMHTEAM
S SDMHTC=$$START^SCMCMHTC(SDXDFN) S SDMHTEAM=$P($G(SDMHTC),"^",5),SDMHTC=$P($G(SDMHTC),"^",2)
I SDMHTC]"" W !,?5,"MHTC: "_SDMHTC_" ("_SDMHTEAM_$S(SDMHTEAM["TEAM":"",1:" TEAM")_")" D RET
Q
;
;
FUT ; FUTURE SCHEDULED APPTS.
W !,?5,"Future Scheduled Appointments: "
N SDARRAY,SDCOUNT,SDX,X1,X2,X
S X1=DT,X2=$S($D(SDFUTNUM):SDFUTNUM,1: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 ;,SDFUTCNT
. ;S SDFUTCNT=0 ;List up to 6 future appts. for a patient.
. S SDFA=0 F S SDFA=$O(^TMP($J,"SDAMA301",SDXDFN,SDFA)) Q:SDFA=""!(SDUP) D Q:SDUP
.. S SDFUTDT=$$FMTE^XLFDT(SDFA,"5") S SDFNODE=^TMP($J,"SDAMA301",SDXDFN,SDFA) W !,?7,SDFUTDT,?26,$E($P($P(SDFNODE,"^",2),";",2),1,30) ;S SDFUTCNT=SDFUTCNT+1
..D RET Q:SDUP
.Q
I SDCOUNT'>0 D Q:SDUP
.W "NO APPOINTMENTS SCHEDULED WITHIN "_SDFUTNUM_$S(SDFUTNUM=1:" DAY",1:" DAYS")
K ^TMP($J,"SDAMA301")
Q
;
;
RESULTS ;Reminder information
W !,?5,"Results: "
K ^TMP("PXRHM",$J),^TMP("PXRM",$J)
N SDCR
;S SDCR=$O(^PXD(811.9,"B","VA-MH HIGH RISK NO-SHOW FOLLOW-UP",0))
S SDCR=$O(^PXD(811.9,"B","VA-MH HIGH RISK NO-SHOW ADHOC RPT",0))
; N DEFARR,FIEVAL
; Load the definition into DEFARR.
; D DEF^PXRMLDR(SDCR,.DEFARR)
; D EVAL^PXRM(SDXDFN,.DEFARR,5,0,.FIEVAL,$P(SDXNODE,"^",2))
D MAINDF^PXRM(SDXDFN,SDCR,5,$P(SDXNODE,"^",2))
N SDTXT,SDTXTR,SDRNODE
S (SDTXT,SDTXTR)=0
F SDTXT=0:0 S SDTXT=$O(^TMP("PXRHM",$J,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT)) Q:'SDTXT!(SDTXTR) S SDRNODE=$G(^TMP("PXRHM",$J,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT)) I SDRNODE["Resolution:"!(SDRNODE["Information:") D
.;N SDTNODE
.W !,?5,^TMP("PXRHM",$J,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT) D RET Q:SDUP D
..F SDTXT=SDTXT:0 S SDTXT=$O(^TMP("PXRHM",$J,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT)) Q:'SDTXT I $D(^TMP("PXRHM",$J,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT)) D
...W !,?5,^TMP("PXRHM",$J,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT)
...D RET Q:SDUP Q
..S SDTXTR=1
..;K ^TMP("PXRHM",$J),^TMP("PXRM",$J) Q
D RET Q:SDUP
K ^TMP("PXRHM",$J),^TMP("PXRM",$J)
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^SDMHAD S SDXFLG(SDXDIV)=1,SDXFLG(SDXDIV,SDXCLIN)=1,SDXFLG(SDXDIV,SDXSTOP)=1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDMHAD1 11567 printed Apr 09, 2024@21:42:58 Page 2
SDMHAD1 ;MAF/ALB - MENTAL HEALTH AD HOC NO SHOW REPORT(cont.);JULY 14, 2010
+1 ;;5.3;Scheduling;**578,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
+2 SET (SDXDFN,SDXREM,SDCOUNT)=0
+3 SET SDXDIV=""
+4 FOR
SET SDXDIV=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV))
if SDXDIV']""!(SDUP)
QUIT
Begin DoDot:1
+5 IF SDTL="CLIN"
Begin DoDot:2
+6 SET SDXCLIN=""
+7 FOR
SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN))
if SDXCLIN']""!($GET(SDUP))
QUIT
Begin DoDot:3
+8 SET SDXNM=""
+9 FOR
SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN,SDXNM))
if SDXNM']""!($GET(SDUP))
QUIT
Begin DoDot:4
+10 SET SDXSTOP=0
+11 FOR
SET SDXSTOP=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN,SDXNM,SDXSTOP))
if 'SDXSTOP!($GET(SDUP))
QUIT
Begin DoDot:5
+12 SET SDATE=0
+13 FOR
SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE))
if 'SDATE!($GET(SDUP))
QUIT
Begin DoDot:6
+14 IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE))
DO PRT
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+15 IF SDTL="STOP"
NEW SDXSTOPN
Begin DoDot:2
+16 SET SDXSTOP=0
+17 FOR
SET SDXSTOP=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP))
if SDXSTOP']""!($GET(SDUP))
QUIT
Begin DoDot:3
+18 SET SDXNM=""
+19 FOR
SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM))
if SDXNM']""!($GET(SDUP))
QUIT
Begin DoDot:4
+20 SET SDXCLIN=""
+21 FOR
SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM,SDXCLIN))
if SDXCLIN']""!($GET(SDUP))
QUIT
Begin DoDot:5
+22 SET SDATE=0
+23 FOR
SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE))
if 'SDATE!($GET(SDUP))
QUIT
Begin DoDot:6
+24 IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE))
SET SDXSTOPN=$PIECE(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE),"^",6)
DO PRT
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+25 IF SDTL="MEN"
Begin DoDot:2
+26 SET SDXREM=""
+27 FOR
SET SDXREM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM))
if SDXREM']""!($GET(SDUP))
QUIT
Begin DoDot:3
+28 SET SDXCLIN=""
+29 FOR
SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXCLIN))
if SDXCLIN']""!($GET(SDUP))
QUIT
Begin DoDot:4
+30 SET SDXNM=""
+31 FOR
SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXCLIN,SDXNM))
if SDXNM']""!($GET(SDUP))
QUIT
Begin DoDot:5
+32 SET SDATE=0
+33 FOR
SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE))
if 'SDATE!($GET(SDUP))
QUIT
Begin DoDot:6
+34 IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE))
SET SDXSTOP=$PIECE(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE),"^",6)
DO PRT
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 if SDUP
QUIT
+36 IF $DATA(^TMP(NAMSPC1,$JOB))
SET SDTOTPG=1
DO HEAD^SDMHAD
DO TOTAL1^SDMHNS
+37 QUIT
+38 ;
+39 ;
PRT ;Print report
+1 ;
+2 IF '$DATA(SDXFLG(SDXDIV))
DO HEAD^SDMHAD
SET SDXFLG(SDXDIV)=1
if SDTL'="STOP"
SET SDXFLG(SDXDIV,SDXCLIN)=1
if SDTL="STOP"
SET SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
+3 IF SDTL="CLIN"
IF $DATA(SDXFLG(SDXDIV))
IF '$DATA(SDXFLG(SDXDIV,SDXCLIN))
WRITE !!
DO HEAD1^SDMHAD
SET SDXFLG(SDXDIV,SDXCLIN)=1
+4 IF SDTL="STOP"
IF $DATA(SDXFLG(SDXDIV))
IF '$DATA(SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN))
WRITE !!
DO HEAD1^SDMHAD
SET SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
+5 DO COUNT^SDMHNS
+6 NEW SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDDSS,SDXRLL,SDXZERO,SDPROV
+7 SET SDPROV=0
+8 SET SDXSORT1=$SELECT(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
+9 SET SDXSORT2=$SELECT(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
+10 IF SDTL="MEN"
SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSORT1,SDXSORT2,SDXNM,SDATE))
+11 IF SDTL'="MEN"
SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSORT1,SDXNM,SDXSORT2,SDATE))
+12 SET SDXDFN=$PIECE(SDXNODE,"^",1)
if SDXDFN']""
QUIT
+13 SET SDXID=$EXTRACT($PIECE(SDXNODE,"^",4),1,5)
+14 SET SDXDT=$PIECE(SDXNODE,"^",2)
+15 SET SDXSTAT=$PIECE(SDXNODE,"^",3)
+16 SET SDXCLIEN=$PIECE(SDXNODE,"^",5)
+17 SET SDDSS=$PIECE($GET(^DIC(40.7,+$PIECE(SDXNODE,"^",6),0)),"^",2)
+18 SET SDXDT=$$FMTE^XLFDT(SDXDT,"5")
WRITE !!,SDCOUNT,?4,$EXTRACT($PIECE(^DPT(SDXDFN,0),"^",1),1,20),?25,SDXID,?31,SDXDT,?49,$EXTRACT(SDXCLIN,1,30)
+19 WRITE !?47,$EXTRACT("*"_SDXSTAT,1,5)
DO PROV
WRITE ?53,$EXTRACT(SDPROV,1,26)
DO RET
if SDUP
QUIT
IF SDCOUNT=$PIECE($GET(TOTAL(SDXDIV,SDXCLIN)),"^",1)
SET SDCOUNT=0
+20 ;D PROV Q:SDUP
DO RET
if SDUP
QUIT
+21 DO PATINFO
if SDUP
QUIT
+22 DO RET
if SDUP
QUIT
DO NOK
if SDUP
QUIT
+23 DO RET
if SDUP
QUIT
DO EC
if SDUP
QUIT
+24 ;D RET Q:SDUP D PROV Q:SDUP
+25 DO RET
if SDUP
QUIT
DO MHTC
if SDUP
QUIT
+26 DO RET
if SDUP
QUIT
DO FUT
if SDUP
QUIT
+27 DO RET
if SDUP
QUIT
DO RESULTS
if SDUP
QUIT
+28 QUIT
+29 ;
+30 ;
PATINFO ;Patients home, cell and office phones
+1 NEW SDPHON,VAROOT,VAOA,SDEC6,SDEC5,DFN
+2 SET DFN=SDXDFN
SET VAROOT="SDEC6"
DO ADD^VADPT
+3 IF $DATA(SDEC6)
Begin DoDot:1
+4 SET SDPHON("HOME")=SDEC6(8)
End DoDot:1
+5 SET DFN=SDXDFN
SET VAOA("A")=5
SET VAROOT="SDEC5"
DO OAD^VADPT
+6 IF $DATA(SDEC5)
Begin DoDot:1
+7 SET SDPHON("WORK")=SDEC5(8)
End DoDot:1
+8 DO GETS^DIQ(2,SDXDFN_",",".134","E","SDPHON")
+9 IF $DATA(SDPHON(2,SDXDFN_","))
Begin DoDot:1
+10 SET SDPHON("CELL")=$GET(SDPHON(2,SDXDFN_",",".134","E"))
End DoDot:1
+11 IF $DATA(SDPHON("HOME"))
IF SDPHON("HOME")]""
WRITE !,?5,"Home: ",$$HLPHONE^HLFNC(SDPHON("HOME"),,)
DO RET
if SDUP
QUIT
+12 IF $DATA(SDPHON("WORK"))
IF SDPHON("WORK")]""
WRITE !,?5,"Work: ",$$HLPHONE^HLFNC(SDPHON("WORK"),,)
DO RET
if SDUP
QUIT
+13 IF $DATA(SDPHON("CELL"))
IF SDPHON("CELL")]""
WRITE !,?5,"Cell: ",$$HLPHONE^HLFNC(SDPHON("CELL"),,)
DO RET
if SDUP
QUIT
+14 QUIT
+15 ;
+16 ;
NOK ; Next of Kin information
+1 NEW SDNOK,SDNOK2,SDNOKNM,SDNOKNM2,SDNOKR,SDNOKR2,SDNOKPH,SDNOKPH2,SDNOKPO,SDNOKPO2,SDNOKFL,VAOA,VAROOT,SDEC3,SDEC4,SDPHON,DFN
+2 SET DFN=SDXDFN
SET VAROOT="SDEC3"
DO OAD^VADPT
+3 SET DFN=SDXDFN
SET VAOA("A")=3
SET VAROOT="SDEC4"
DO OAD^VADPT
+4 DO GETS^DIQ(2,SDXDFN_",",".21011;.211011","E","SDPHON")
+5 IF $DATA(SDPHON(2,SDXDFN_","))
Begin DoDot:1
+6 SET SDPHON("K-WORK")=$GET(SDPHON(2,SDXDFN_",",".21011","E"))
+7 SET SDPHON("K2-WORK")=$GET(SDPHON(2,SDXDFN_",",".211011","E"))
End DoDot:1
+8 IF $DATA(SDEC3)
Begin DoDot:1
+9 SET SDNOKNM=SDEC3(9)
SET SDNOKR=SDEC3(10)
SET SDNOKPH=SDEC3(8)
SET SDNOKPO=SDPHON("K-WORK")
End DoDot:1
+10 IF $DATA(SDEC4)
Begin DoDot:1
+11 SET SDNOKNM2=SDEC4(9)
SET SDNOKR2=SDEC4(10)
SET SDNOKPH2=SDEC3(8)
SET SDNOKPO2=SDPHON("K2-WORK")
End DoDot:1
+12 IF SDNOKNM]""!(SDNOKNM2]"")
DO NOKFL
DO RET
if SDUP
QUIT
+13 IF SDNOKNM]""
WRITE ?7,"NOK: "_SDNOKNM
DO RET
if SDUP
QUIT
+14 IF SDNOKNM2]""
WRITE ?45,"NOK2: "_SDNOKNM2
+15 IF SDNOKR]""!(SDNOKR2]"")
Begin DoDot:1
+16 IF '$DATA(SDNOKFL)
DO NOKFL
QUIT
+17 WRITE !
End DoDot:1
DO RET
if SDUP
QUIT
+18 IF SDNOKR]""
WRITE ?7,"Relation: "_SDNOKR
DO RET
if SDUP
QUIT
+19 IF SDNOKR2]""
WRITE ?45,"Relation: "_SDNOKR2
+20 IF SDNOKPH]""!(SDNOKPH2]"")
Begin DoDot:1
+21 IF '$DATA(SDNOKFL)
DO NOKFL
QUIT
+22 WRITE !
End DoDot:1
DO RET
if SDUP
QUIT
+23 DO RET
if SDUP
QUIT
+24 IF SDNOKPH]""
WRITE ?7,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH,,)
+25 IF SDNOKPH2]""
WRITE ?45,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH2,,)
+26 IF SDNOKPO]""!(SDNOKPO2]"")
Begin DoDot:1
+27 IF '$DATA(SDNOKFL)
DO NOKFL
QUIT
+28 WRITE !
End DoDot:1
DO RET
if SDUP
QUIT
+29 IF SDNOKPO]""
WRITE ?7,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO,,)
+30 IF SDNOKPO2]""
WRITE ?45,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO2,,)
+31 WRITE !
DO RET
if SDUP
QUIT
+32 QUIT
+33 ;
+34 ;
NOKFL WRITE !!," Next of Kin:",!
SET SDNOKFL=1
+1 QUIT
+2 ;
+3 ;
EC ;display emergency contact information
+1 NEW SDEC1,SDEC2,SDPHON,VAROOT,VAOA
+2 if '$GET(SDXDFN)
QUIT
+3 NEW DFN
+4 SET DFN=SDXDFN
+5 ; Get Primary EC
SET VAOA("A")=1
SET VAROOT="SDEC1"
DO OAD^VADPT
+6 ; Get Secondary EC
SET VAOA("A")=4
SET VAROOT="SDEC2"
DO OAD^VADPT
+7 DO GETS^DIQ(2,SDXDFN_",",".33011;.331011","E","SDPHON")
+8 IF $DATA(SDPHON(2,SDXDFN_","))
Begin DoDot:1
+9 SET SDPHON("E-WORK")=$GET(SDPHON(2,SDXDFN_",",".33011","E"))
+10 SET SDPHON("E2-WORK")=$GET(SDPHON(2,SDXDFN_",",".331011","E"))
End DoDot:1
+11 IF SDEC1(9)]""
Begin DoDot:1
+12 DO RET
if SDUP
QUIT
IF $DATA(SDEC1)!($DATA(SDEC2))
WRITE !,?5,"Emergency Contact:"
DO RET
if SDUP
QUIT
+13 ;Contacts name and realtionship
+14 IF SDEC1(9)]""
WRITE !?7,"E-Cont.: ",SDEC1(9)
+15 IF SDEC2(9)]""
IF SDEC2(9)]""
WRITE ?45,"E2-Cont.: ",SDEC2(9)
+16 DO RET
if SDUP
QUIT
IF SDEC1(10)]""
WRITE !,?7,"Relation: ",SDEC1(10)
+17 IF SDEC2(10)]""
WRITE ?45,"Relation: ",SDEC2(10)
+18 ;ECs address lines 1, 2 and 3
+19 DO RET
if SDUP
QUIT
IF SDEC1(1)]""
WRITE !,?9,SDEC1(1)
+20 IF SDEC1(1)']""
IF SDEC2(1)]""
DO RET
if SDUP
QUIT
WRITE !
+21 IF SDEC2(1)]""
WRITE ?47,SDEC2(1)
+22 DO RET
if SDUP
QUIT
IF SDEC1(2)]""
WRITE !,?9,SDEC1(2)
+23 IF SDEC1(2)']""
IF SDEC2(2)]""
DO RET
if SDUP
QUIT
WRITE !
+24 IF SDEC2(2)]""
WRITE ?47,SDEC2(2)
+25 DO RET
if SDUP
QUIT
IF SDEC1(3)]""
WRITE !,?9,SDEC1(3)
+26 IF SDEC1(3)']""
IF SDEC2(3)]""
DO RET
if SDUP
QUIT
WRITE !
+27 IF SDEC2(3)]""
WRITE ?47,SDEC2(3)
+28 ;Emergency Contact 1 City, State an Zip+4
+29 IF SDEC1(4)]""
Begin DoDot:2
+30 DO RET
if SDUP
QUIT
WRITE !,?9,SDEC1(4)
+31 IF SDEC1(5)]""
WRITE ", "_$$GET1^DIQ(5,+SDEC1(5),1)
+32 WRITE " ",$PIECE(SDEC1(11),"^",2)
End DoDot:2
+33 ;Emergency Contact 2 City State and Zip+4
+34 IF SDEC2(4)]""
Begin DoDot:2
+35 DO RET
if SDUP
QUIT
IF SDEC1(4)']""
WRITE !
+36 WRITE ?47,SDEC2(4)
+37 IF SDEC2(5)]""
WRITE ", "_$$GET1^DIQ(5,+SDEC2(5),1)
+38 WRITE " ",$PIECE(SDEC2(11),"^",2)
End DoDot:2
+39 ;Home and work phones
+40 DO RET
if SDUP
QUIT
IF SDEC1(8)]""
WRITE !,?7,"Phone: "_$$HLPHONE^HLFNC(SDEC1(8),,)
+41 IF SDEC2(8)]""
WRITE ?45,"Phone: "_$$HLPHONE^HLFNC(SDEC2(8),,)
+42 ;,$S($P(^DPT(DFN,.33),U,11)]"":$P(^DPT(DFN,.33),U,11),1:"UNSPECIFIED")
DO RET
if SDUP
QUIT
IF SDPHON("E-WORK")]""
WRITE !?7,"Work Phone: "_$$HLPHONE^HLFNC(SDPHON("E-WORK"),,)
+43 ;,$S($P(^DPT(DFN,.331),U,11)]"":$P(^DPT(DFN,.331),U,11),1:"UNSPECIFIED")
IF SDPHON("E2-WORK")]""
WRITE ?45,"Work Phone: "_$$HLPHONE^HLFNC(SDPHON("E2-WORK"),,)
End DoDot:1
+44 DO KVAR^VADPT
+45 QUIT
+46 ;
+47 ;
PROV ;Clinic Default Provider
+1 NEW SDPNUM,SDPNODE
+2 SET SDPNUM=0
+3 FOR SDPNUM=0:0
SET SDPNUM=$ORDER(^SC(SDXCLIEN,"PR",SDPNUM))
if '(+SDPNUM)
QUIT
IF $DATA(^SC(SDXCLIEN,"PR",SDPNUM,0))
SET SDPNODE=^SC(SDXCLIEN,"PR",SDPNUM,0)
IF $PIECE(SDPNODE,"^",1)&($PIECE(SDPNODE,"^",2))
Begin DoDot:1
+4 ;D RET
SET SDPROV=$EXTRACT($PIECE(^VA(200,$PIECE(SDPNODE,"^",1),0),"^",1),1,25)
End DoDot:1
if SDUP
QUIT
+5 ;.W !,?5,"Provider: "_$P(^VA(200,$P(SDPNODE,"^",1),0),"^",1) D RET
+6 QUIT
+7 ;
+8 ;
MHTC ;Mental Health Treatment Coordinator
+1 ;Q:'$T(START^SCMCMHTC)
+2 WRITE !
+3 NEW SDMHTC,MHTC,SDMHTEAM
+4 SET SDMHTC=$$START^SCMCMHTC(SDXDFN)
SET SDMHTEAM=$PIECE($GET(SDMHTC),"^",5)
SET SDMHTC=$PIECE($GET(SDMHTC),"^",2)
+5 IF SDMHTC]""
WRITE !,?5,"MHTC: "_SDMHTC_" ("_SDMHTEAM_$SELECT(SDMHTEAM["TEAM":"",1:" TEAM")_")"
DO RET
+6 QUIT
+7 ;
+8 ;
FUT ; FUTURE SCHEDULED APPTS.
+1 WRITE !,?5,"Future Scheduled Appointments: "
+2 NEW SDARRAY,SDCOUNT,SDX,X1,X2,X
+3 SET X1=DT
SET X2=$SELECT($DATA(SDFUTNUM):SDFUTNUM,1: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 ;,SDFUTCNT
NEW SDFA,SDFNODE,SDFUTDT
+13 ;S SDFUTCNT=0 ;List up to 6 future appts. for a patient.
+14 SET SDFA=0
FOR
SET SDFA=$ORDER(^TMP($JOB,"SDAMA301",SDXDFN,SDFA))
if SDFA=""!(SDUP)
QUIT
Begin DoDot:2
+15 ;S SDFUTCNT=SDFUTCNT+1
SET SDFUTDT=$$FMTE^XLFDT(SDFA,"5")
SET SDFNODE=^TMP($JOB,"SDAMA301",SDXDFN,SDFA)
WRITE !,?7,SDFUTDT,?26,$EXTRACT($PIECE($PIECE(SDFNODE,"^",2),";",2),1,30)
+16 DO RET
if SDUP
QUIT
End DoDot:2
if SDUP
QUIT
+17 QUIT
End DoDot:1
if SDUP
QUIT
+18 IF SDCOUNT'>0
Begin DoDot:1
+19 WRITE "NO APPOINTMENTS SCHEDULED WITHIN "_SDFUTNUM_$SELECT(SDFUTNUM=1:" DAY",1:" DAYS")
End DoDot:1
if SDUP
QUIT
+20 KILL ^TMP($JOB,"SDAMA301")
+21 QUIT
+22 ;
+23 ;
RESULTS ;Reminder information
+1 WRITE !,?5,"Results: "
+2 KILL ^TMP("PXRHM",$JOB),^TMP("PXRM",$JOB)
+3 NEW SDCR
+4 ;S SDCR=$O(^PXD(811.9,"B","VA-MH HIGH RISK NO-SHOW FOLLOW-UP",0))
+5 SET SDCR=$ORDER(^PXD(811.9,"B","VA-MH HIGH RISK NO-SHOW ADHOC RPT",0))
+6 ; N DEFARR,FIEVAL
+7 ; Load the definition into DEFARR.
+8 ; D DEF^PXRMLDR(SDCR,.DEFARR)
+9 ; D EVAL^PXRM(SDXDFN,.DEFARR,5,0,.FIEVAL,$P(SDXNODE,"^",2))
+10 DO MAINDF^PXRM(SDXDFN,SDCR,5,$PIECE(SDXNODE,"^",2))
+11 NEW SDTXT,SDTXTR,SDRNODE
+12 SET (SDTXT,SDTXTR)=0
+13 FOR SDTXT=0:0
SET SDTXT=$ORDER(^TMP("PXRHM",$JOB,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT))
if 'SDTXT!(SDTXTR)
QUIT
SET SDRNODE=$GET(^TMP("PXRHM",$JOB,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT))
IF SDRNODE["Resolution:"!(SDRNODE["Information:")
Begin DoDot:1
+14 ;N SDTNODE
+15 WRITE !,?5,^TMP("PXRHM",$JOB,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT)
DO RET
if SDUP
QUIT
Begin DoDot:2
+16 FOR SDTXT=SDTXT:0
SET SDTXT=$ORDER(^TMP("PXRHM",$JOB,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT))
if 'SDTXT
QUIT
IF $DATA(^TMP("PXRHM",$JOB,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT))
Begin DoDot:3
+17 WRITE !,?5,^TMP("PXRHM",$JOB,SDCR,"High Risk MH No-Show Adhoc Rpt","TXT",SDTXT)
+18 DO RET
if SDUP
QUIT
QUIT
End DoDot:3
+19 SET SDTXTR=1
+20 ;K ^TMP("PXRHM",$J),^TMP("PXRM",$J) Q
End DoDot:2
End DoDot:1
+21 DO RET
if SDUP
QUIT
+22 KILL ^TMP("PXRHM",$JOB),^TMP("PXRM",$JOB)
+23 QUIT
+24 ;
+25 ;
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 DO HEAD^SDMHAD
SET SDXFLG(SDXDIV)=1
SET SDXFLG(SDXDIV,SDXCLIN)=1
SET SDXFLG(SDXDIV,SDXSTOP)=1
End DoDot:1
if SDUP
QUIT
