SDMHAD1 ;MAF/ALB - MENTAL HEALTH AD HOC NO SHOW REPORT (CONT.; JULY 14, 2010
;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
;
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
B 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
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=$P(SDXNODE,"^",4)
S SDXDT=$P(SDXNODE,"^",2)
S SDXSTAT=$P(SDXNODE,"^",3)
;S SDXZERO=^DPT(SDXDFN,"S",SDXDT,0)
;S SDXSTAT=$$STATUS^SDAM1(SDXDFN,SDXDT,SDXCLIEN,SDXZERO,"")
S SDXCLIEN=$P(SDXNODE,"^",5)
S SDDSS=$P($G(^DIC(40.7,+$P(SDXNODE,"^",6),0)),"^",2)
S SDXDT=$$FMTE^XLFDT(SDXDT,"5P") W !!,SDCOUNT,?3,$P(^DPT(SDXDFN,0),"^",1),?23,SDXID,?33,SDXDT,?53,$E(SDXCLIN,1,15),?73,$E("*"_SDXSTAT,1,10),! D RET Q:SDUP I SDCOUNT=$P($G(TOTAL(SDXDIV,SDXCLIN)),"^",1) S SDCOUNT=0
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"))
;.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
.W !,?5,"Provider: "_$P(^VA(200,$P(SDPNODE,"^",1),0),"^",1) D RET
Q
;
;
MHTC ;Mental Health Treatment Coordinator
W !,?5,"MHTC: " 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,"5P") S SDFNODE=^TMP($J,"SDAMA301",SDXDFN,SDFA) W !,?7,SDFUTDT,?33,$E($P($P(SDFNODE,"^",2),";",2),1,20) ;S SDFUTCNT=SDFUTCNT+1
..D RET Q:SDUP
.Q
I SDCOUNT'>0 D Q:SDUP
.W "NO APPOINTMENTS SCHEDULED WITHIN "_SDFUTNUM_" DAYS"
K ^TMP($J,"SDAMA301")
Q
;
;
RESULTS ;Reminder information
W !,?5,"Results: "
D RET Q:SDUP
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
SDMHAD1 ;MAF/ALB - MENTAL HEALTH AD HOC NO SHOW REPORT (CONT.; JULY 14, 2010
+1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
+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
B IF SDTL="STOP"
IF $DATA(SDXFLG(SDXDIV))
IF '$DATA(SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN))
WRITE !!
DO HEAD1^SDMHAD
SET SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
+1 DO COUNT^SDMHNS
+2 NEW SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDDSS,SDXRLL,SDXZERO
+3 SET SDXSORT1=$SELECT(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
+4 SET SDXSORT2=$SELECT(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
+5 IF SDTL="MEN"
SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSORT1,SDXSORT2,SDXNM,SDATE))
+6 IF SDTL'="MEN"
SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSORT1,SDXNM,SDXSORT2,SDATE))
+7 SET SDXDFN=$PIECE(SDXNODE,"^",1)
IF SDXDFN']""
QUIT
+8 SET SDXID=$PIECE(SDXNODE,"^",4)
+9 SET SDXDT=$PIECE(SDXNODE,"^",2)
+10 SET SDXSTAT=$PIECE(SDXNODE,"^",3)
+11 ;S SDXZERO=^DPT(SDXDFN,"S",SDXDT,0)
+12 ;S SDXSTAT=$$STATUS^SDAM1(SDXDFN,SDXDT,SDXCLIEN,SDXZERO,"")
+13 SET SDXCLIEN=$PIECE(SDXNODE,"^",5)
+14 SET SDDSS=$PIECE($GET(^DIC(40.7,+$PIECE(SDXNODE,"^",6),0)),"^",2)
+15 SET SDXDT=$$FMTE^XLFDT(SDXDT,"5P")
WRITE !!,SDCOUNT,?3,$PIECE(^DPT(SDXDFN,0),"^",1),?23,SDXID,?33,SDXDT,?53,$EXTRACT(SDXCLIN,1,15),?73,$EXTRACT("*"_SDXSTAT,1,10),!
DO RET
IF SDUP
QUIT
IF SDCOUNT=$PIECE($GET(TOTAL(SDXDIV,SDXCLIN)),"^",1)
SET SDCOUNT=0
+16 DO PATINFO
IF SDUP
QUIT
+17 DO RET
IF SDUP
QUIT
DO NOK
IF SDUP
QUIT
+18 DO RET
IF SDUP
QUIT
DO EC
IF SDUP
QUIT
+19 DO RET
IF SDUP
QUIT
DO PROV
IF SDUP
QUIT
+20 DO RET
IF SDUP
QUIT
DO MHTC
IF SDUP
QUIT
+21 DO RET
IF SDUP
QUIT
DO FUT
IF SDUP
QUIT
+22 DO RET
IF SDUP
QUIT
DO RESULTS
IF SDUP
QUIT
+23 QUIT
+24 ;
+25 ;
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 ;.S SDPHON("K2-WORK")=$G(SDPHON(2,SDXDFN_",",".211011","E"))
+9 IF $DATA(SDEC3)
Begin DoDot:1
+10 SET SDNOKNM=SDEC3(9)
SET SDNOKR=SDEC3(10)
SET SDNOKPH=SDEC3(8)
SET SDNOKPO=SDPHON("K-WORK")
End DoDot:1
+11 IF $DATA(SDEC4)
Begin DoDot:1
+12 SET SDNOKNM2=SDEC4(9)
SET SDNOKR2=SDEC4(10)
SET SDNOKPH2=SDEC3(8)
SET SDNOKPO2=SDPHON("K2-WORK")
End DoDot:1
+13 IF SDNOKNM]""!(SDNOKNM2]"")
DO NOKFL
DO RET
IF SDUP
QUIT
+14 IF SDNOKNM]""
WRITE ?7,"NOK: "_SDNOKNM
DO RET
IF SDUP
QUIT
+15 IF SDNOKNM2]""
WRITE ?45,"NOK2: "_SDNOKNM2
+16 IF SDNOKR]""!(SDNOKR2]"")
Begin DoDot:1
+17 IF '$DATA(SDNOKFL)
DO NOKFL
QUIT
+18 WRITE !
End DoDot:1
DO RET
IF SDUP
QUIT
+19 IF SDNOKR]""
WRITE ?7,"Relation: "_SDNOKR
DO RET
IF SDUP
QUIT
+20 IF SDNOKR2]""
WRITE ?45,"Relation: "_SDNOKR2
+21 IF SDNOKPH]""!(SDNOKPH2]"")
Begin DoDot:1
+22 IF '$DATA(SDNOKFL)
DO NOKFL
QUIT
+23 WRITE !
End DoDot:1
DO RET
IF SDUP
QUIT
+24 DO RET
IF SDUP
QUIT
+25 IF SDNOKPH]""
WRITE ?7,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH,,)
+26 IF SDNOKPH2]""
WRITE ?45,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH2,,)
+27 IF SDNOKPO]""!(SDNOKPO2]"")
Begin DoDot:1
+28 IF '$DATA(SDNOKFL)
DO NOKFL
QUIT
+29 WRITE !
End DoDot:1
DO RET
IF SDUP
QUIT
+30 IF SDNOKPO]""
WRITE ?7,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO,,)
+31 IF SDNOKPO2]""
WRITE ?45,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO2,,)
+32 WRITE !
DO RET
IF SDUP
QUIT
+33 QUIT
+34 ;
+35 ;
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 WRITE !,?5,"Provider: "_$PIECE(^VA(200,$PIECE(SDPNODE,"^",1),0),"^",1)
DO RET
End DoDot:1
IF SDUP
QUIT
+5 QUIT
+6 ;
+7 ;
MHTC ;Mental Health Treatment Coordinator
+1 WRITE !,?5,"MHTC: "
DO RET
+2 QUIT
+3 ;
+4 ;
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,"5P")
SET SDFNODE=^TMP($JOB,"SDAMA301",SDXDFN,SDFA)
WRITE !,?7,SDFUTDT,?33,$EXTRACT($PIECE($PIECE(SDFNODE,"^",2),";",2),1,20)
+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_" DAYS"
End DoDot:1
IF SDUP
QUIT
+20 KILL ^TMP($JOB,"SDAMA301")
+21 QUIT
+22 ;
+23 ;
RESULTS ;Reminder information
+1 WRITE !,?5,"Results: "
+2 DO RET
IF SDUP
QUIT
+3 QUIT
+4 ;
+5 ;
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
