Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDMHAD1

SDMHAD1.m

Go to the documentation of this file. 
  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
  1.  ;
  1. SET ; Set up the data for the patient
  1.  ;       piece 1 = dfn
  1.  ;       piece 2 = Appointment Date and time
  1.  ;       piece 3 = status N(Noshow) or NA (Noshow with auto rebook)
  1.  ;       piece 4 = PID last 4 of SSN
  1.  ;       piece 5 = clinic ien   ^SC(
  1.  ;       piece 6 = stop code ien ^DIC(40.7
  1.  ;   
  1.  ;
  1. EN ;PRINT OF THE ^TMP 
  1.  N SDXDIV,SDXCLIN,SDXDFN,SDXSTOP,SDXREM,SDXNM,SDCOUNT,SDATE,SDTOTPG
  1.  S (SDXDFN,SDXREM,SDCOUNT)=0
  1.  S SDXDIV=""
  1.  F  S SDXDIV=$O(^TMP(NAMSPC1,$J,SDXDIV)) Q:SDXDIV']""!(SDUP)  D
  1.  .I SDTL="CLIN" D
  1.  ..S SDXCLIN=""
  1.  ..F  S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN)) Q:SDXCLIN']""!($G(SDUP))  D
  1.  ...S SDXNM=""
  1.  ...F  S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM)) Q:SDXNM']""!($G(SDUP))  D
  1.  ....S SDXSTOP=0
  1.  ....F  S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP)) Q:'SDXSTOP!($G(SDUP))  D
  1.  .....S SDATE=0
  1.  .....F  S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE)) Q:'SDATE!($G(SDUP))  D
  1.  ......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE)) D PRT
  1.  .I SDTL="STOP" N SDXSTOPN D
  1.  ..S SDXSTOP=0
  1.  ..F  S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP)) Q:SDXSTOP']""!($G(SDUP))  D
  1.  ...S SDXNM=""
  1.  ...F  S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM)) Q:SDXNM']""!($G(SDUP))  D
  1.  ....S SDXCLIN=""
  1.  ....F  S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN)) Q:SDXCLIN']""!($G(SDUP))  D
  1.  .....S SDATE=0
  1.  .....F  S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE)) Q:'SDATE!($G(SDUP))  D
  1.  ......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE)) S SDXSTOPN=$P(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE),"^",6) D PRT
  1.  .I SDTL="MEN" D
  1.  ..S SDXREM=""
  1.  ..F  S SDXREM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM)) Q:SDXREM']""!($G(SDUP))  D
  1.  ...S SDXCLIN=""
  1.  ...F  S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN)) Q:SDXCLIN']""!($G(SDUP))  D
  1.  ....S SDXNM=""
  1.  ....F  S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM)) Q:SDXNM']""!($G(SDUP))  D
  1.  .....S SDATE=0
  1.  .....F  S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE)) Q:'SDATE!($G(SDUP))  D
  1.  ......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE)) S SDXSTOP=$P(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXCLIN,SDXNM,SDATE),"^",6) D PRT
  1.  Q:SDUP
  1.  I $D(^TMP(NAMSPC1,$J)) S SDTOTPG=1 D HEAD^SDMHAD D TOTAL1^SDMHNS
  1.  Q
  1.  ;
  1.  ;
  1. PRT ;Print  report
  1.  ;
  1.  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
  1.  I SDTL="CLIN" I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV,SDXCLIN)) W !! D HEAD1^SDMHAD S SDXFLG(SDXDIV,SDXCLIN)=1
  1. B I SDTL="STOP" I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)) W !! D HEAD1^SDMHAD S SDXFLG(SDXDIV,SDXSTOP,SDXSTOPN)=1
  1.  D COUNT^SDMHNS
  1.  N SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDDSS,SDXRLL,SDXZERO
  1.  S SDXSORT1=$S(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
  1.  S SDXSORT2=$S(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
  1.  I SDTL="MEN" S SDXNODE=$G(^TMP(NAMSPC1,$J,SDXDIV,SDXSORT1,SDXSORT2,SDXNM,SDATE))
  1.  I SDTL'="MEN" S SDXNODE=$G(^TMP(NAMSPC1,$J,SDXDIV,SDXSORT1,SDXNM,SDXSORT2,SDATE))
  1.  S SDXDFN=$P(SDXNODE,"^",1) Q:SDXDFN']""
  1.  S SDXID=$P(SDXNODE,"^",4)
  1.  S SDXDT=$P(SDXNODE,"^",2)
  1.  S SDXSTAT=$P(SDXNODE,"^",3)
  1.  ;S SDXZERO=^DPT(SDXDFN,"S",SDXDT,0)
  1.  ;S SDXSTAT=$$STATUS^SDAM1(SDXDFN,SDXDT,SDXCLIEN,SDXZERO,"")
  1.  S SDXCLIEN=$P(SDXNODE,"^",5)
  1.  S SDDSS=$P($G(^DIC(40.7,+$P(SDXNODE,"^",6),0)),"^",2)
  1.  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
  1.  D PATINFO Q:SDUP
  1.  D RET Q:SDUP  D NOK Q:SDUP
  1.  D RET Q:SDUP  D EC Q:SDUP
  1.  D RET Q:SDUP  D PROV Q:SDUP
  1.  D RET Q:SDUP  D MHTC Q:SDUP
  1.  D RET Q:SDUP  D FUT Q:SDUP
  1.  D RET Q:SDUP  D RESULTS Q:SDUP
  1.  Q
  1.  ;
  1.  ;
  1. PATINFO ;Patients home, cell and office phones
  1.  N SDPHON,VAROOT,VAOA,SDEC6,SDEC5,DFN
  1.  S DFN=SDXDFN,VAROOT="SDEC6" D ADD^VADPT
  1.  I $D(SDEC6) D
  1.  .S SDPHON("HOME")=SDEC6(8)
  1.  S DFN=SDXDFN,VAOA("A")=5,VAROOT="SDEC5" D OAD^VADPT
  1.  I $D(SDEC5) D
  1.  .S SDPHON("WORK")=SDEC5(8)
  1.  D GETS^DIQ(2,SDXDFN_",",".134","E","SDPHON")
  1.  I $D(SDPHON(2,SDXDFN_",")) D
  1.  .S SDPHON("CELL")=$G(SDPHON(2,SDXDFN_",",".134","E"))
  1.  I $D(SDPHON("HOME")),SDPHON("HOME")]"" W !,?5,"Home: ",$$HLPHONE^HLFNC(SDPHON("HOME"),,) D RET Q:SDUP
  1.  I $D(SDPHON("WORK")),SDPHON("WORK")]"" W !,?5,"Work: ",$$HLPHONE^HLFNC(SDPHON("WORK"),,) D RET Q:SDUP
  1.  I $D(SDPHON("CELL")),SDPHON("CELL")]"" W !,?5,"Cell: ",$$HLPHONE^HLFNC(SDPHON("CELL"),,) D RET Q:SDUP
  1.  Q
  1.  ;
  1.  ;
  1. NOK ; Next of Kin information
  1.  N SDNOK,SDNOK2,SDNOKNM,SDNOKNM2,SDNOKR,SDNOKR2,SDNOKPH,SDNOKPH2,SDNOKPO,SDNOKPO2,SDNOKFL,VAOA,VAROOT,SDEC3,SDEC4,SDPHON,DFN
  1.  S DFN=SDXDFN,VAROOT="SDEC3" D OAD^VADPT
  1.  S DFN=SDXDFN,VAOA("A")=3,VAROOT="SDEC4" D OAD^VADPT
  1.  D GETS^DIQ(2,SDXDFN_",",".21011;.211011","E","SDPHON")
  1.  I $D(SDPHON(2,SDXDFN_",")) D
  1.  .S SDPHON("K-WORK")=$G(SDPHON(2,SDXDFN_",",".21011","E"))
  1.  .S SDPHON("K2-WORK")=$G(SDPHON(2,SDXDFN_",",".211011","E"))
  1.  ;.S SDPHON("K2-WORK")=$G(SDPHON(2,SDXDFN_",",".211011","E"))
  1.  I $D(SDEC3) D
  1.  .S SDNOKNM=SDEC3(9),SDNOKR=SDEC3(10),SDNOKPH=SDEC3(8),SDNOKPO=SDPHON("K-WORK")
  1.  I $D(SDEC4) D
  1.  .S SDNOKNM2=SDEC4(9),SDNOKR2=SDEC4(10),SDNOKPH2=SDEC3(8),SDNOKPO2=SDPHON("K2-WORK")
  1.  I SDNOKNM]""!(SDNOKNM2]"") D NOKFL D RET Q:SDUP
  1.  I SDNOKNM]"" W ?7,"NOK: "_SDNOKNM D RET Q:SDUP
  1.  I SDNOKNM2]"" W ?45,"NOK2: "_SDNOKNM2
  1.  I SDNOKR]""!(SDNOKR2]"") D  D RET Q:SDUP
  1.  .I '$D(SDNOKFL) D NOKFL Q
  1.  .W !
  1.  I SDNOKR]"" W ?7,"Relation: "_SDNOKR D RET Q:SDUP
  1.  I SDNOKR2]"" W ?45,"Relation: "_SDNOKR2
  1.  I SDNOKPH]""!(SDNOKPH2]"") D  D RET Q:SDUP
  1.  .I '$D(SDNOKFL) D NOKFL Q
  1.  .W !
  1.  D RET Q:SDUP
  1.  I SDNOKPH]"" W ?7,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH,,)
  1.  I SDNOKPH2]"" W ?45,"Phone: "_$$HLPHONE^HLFNC(SDNOKPH2,,)
  1.  I SDNOKPO]""!(SDNOKPO2]"") D  D RET Q:SDUP
  1.  .I '$D(SDNOKFL) D NOKFL Q
  1.  .W !
  1.  I SDNOKPO]"" W ?7,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO,,)
  1.  I SDNOKPO2]"" W ?45,"Work Phone: "_$$HLPHONE^HLFNC(SDNOKPO2,,)
  1.  W ! D RET Q:SDUP
  1.  Q
  1.  ;
  1.  ;
  1. NOKFL W !!,"     Next of Kin:",! S SDNOKFL=1
  1.  Q
  1.  ;
  1.  ;
  1. EC ;display emergency contact information
  1.  N SDEC1,SDEC2,SDPHON,VAROOT,VAOA
  1.  Q:'$G(SDXDFN)
  1.  N DFN
  1.  S DFN=SDXDFN
  1.  S VAOA("A")=1,VAROOT="SDEC1"  D OAD^VADPT ; Get Primary EC
  1.  S VAOA("A")=4,VAROOT="SDEC2"  D OAD^VADPT ; Get Secondary EC
  1.  D GETS^DIQ(2,SDXDFN_",",".33011;.331011","E","SDPHON")
  1.  I $D(SDPHON(2,SDXDFN_",")) D
  1.  .S SDPHON("E-WORK")=$G(SDPHON(2,SDXDFN_",",".33011","E"))
  1.  .S SDPHON("E2-WORK")=$G(SDPHON(2,SDXDFN_",",".331011","E"))
  1.  I SDEC1(9)]"" D
  1.  . D RET Q:SDUP  I $D(SDEC1)!($D(SDEC2)) W !,?5,"Emergency Contact:" D RET Q:SDUP
  1.  . ;Contacts name and realtionship
  1.  . I SDEC1(9)]"" W !?7,"E-Cont.: ",SDEC1(9)
  1.  . I SDEC2(9)]"" I SDEC2(9)]"" W ?45,"E2-Cont.: ",SDEC2(9)
  1.  . D RET Q:SDUP  I SDEC1(10)]"" W !,?7,"Relation: ",SDEC1(10)
  1.  . I SDEC2(10)]"" W ?45,"Relation: ",SDEC2(10)
  1.  . ;ECs address lines 1, 2 and 3
  1.  . D RET Q:SDUP  I SDEC1(1)]"" W !,?9,SDEC1(1)
  1.  . I SDEC1(1)']"",SDEC2(1)]"" D RET Q:SDUP  W !
  1.  . I SDEC2(1)]"" W ?47,SDEC2(1)
  1.  . D RET Q:SDUP  I SDEC1(2)]"" W !,?9,SDEC1(2)
  1.  . I SDEC1(2)']"",SDEC2(2)]"" D RET Q:SDUP  W !
  1.  . I SDEC2(2)]"" W ?47,SDEC2(2)
  1.  . D RET Q:SDUP  I SDEC1(3)]"" W !,?9,SDEC1(3)
  1.  . I SDEC1(3)']"",SDEC2(3)]"" D RET Q:SDUP  W !
  1.  . I SDEC2(3)]"" W ?47,SDEC2(3)
  1.  . ;Emergency Contact 1 City, State an Zip+4
  1.  . I SDEC1(4)]"" D
  1.  . . D RET Q:SDUP  W !,?9,SDEC1(4)
  1.  . . I SDEC1(5)]"" W ", "_$$GET1^DIQ(5,+SDEC1(5),1)
  1.  . . W "  ",$P(SDEC1(11),"^",2)
  1.  . ;Emergency Contact 2 City State and Zip+4
  1.  . I SDEC2(4)]"" D
  1.  . . D RET Q:SDUP  I SDEC1(4)']"" W !
  1.  . . W ?47,SDEC2(4)
  1.  . . I SDEC2(5)]"" W ", "_$$GET1^DIQ(5,+SDEC2(5),1)
  1.  . . W "  ",$P(SDEC2(11),"^",2)
  1.  . ;Home and work phones
  1.  . D RET Q:SDUP  I SDEC1(8)]"" W !,?7,"Phone: "_$$HLPHONE^HLFNC(SDEC1(8),,)
  1.  . I SDEC2(8)]"" W ?45,"Phone: "_$$HLPHONE^HLFNC(SDEC2(8),,)
  1.  . 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")
  1.  . 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")
  1.  D KVAR^VADPT
  1.  Q
  1.  ;
  1.  ;
  1. PROV ;Clinic Default Provider
  1.  N SDPNUM,SDPNODE
  1.  S SDPNUM=0
  1.  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
  1.  .W !,?5,"Provider:  "_$P(^VA(200,$P(SDPNODE,"^",1),0),"^",1) D RET
  1.  Q
  1.  ;
  1.  ;
  1. MHTC ;Mental Health Treatment Coordinator
  1.  W !,?5,"MHTC:  " D RET
  1.  Q
  1.  ;
  1.  ;
  1. FUT ; FUTURE SCHEDULED APPTS.
  1.  W !,?5,"Future Scheduled Appointments:  "
  1.  N SDARRAY,SDCOUNT,SDX,X1,X2,X
  1.  S X1=DT,X2=$S($D(SDFUTNUM):SDFUTNUM,1:30) D C^%DTC S SDX=X
  1.  S SDARRAY(1)=DT_";"_SDX
  1.  S SDARRAY("SORT")="P"
  1.  S SDARRAY(3)="NT;R"
  1.  S SDARRAY(4)=SDXDFN
  1.  S SDARRAY("FLDS")="1;2;3;4;10;13"
  1.  S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
  1.  I SDCOUNT>0 D  Q:SDUP
  1.  .;Get info on future scheduled appointments and display it
  1.  . N SDFA,SDFNODE,SDFUTDT  ;,SDFUTCNT
  1.  . ;S SDFUTCNT=0  ;List up to 6 future appts. for a patient.
  1.  . S SDFA=0 F  S SDFA=$O(^TMP($J,"SDAMA301",SDXDFN,SDFA)) Q:SDFA=""!(SDUP)  D  Q:SDUP
  1.  .. 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
  1.  ..D RET Q:SDUP
  1.  .Q
  1.  I SDCOUNT'>0 D  Q:SDUP
  1.  .W "NO APPOINTMENTS SCHEDULED WITHIN "_SDFUTNUM_" DAYS"
  1.  K ^TMP($J,"SDAMA301")
  1.  Q
  1.  ;
  1.  ;
  1. RESULTS ;Reminder information
  1.  W !,?5,"Results: "
  1.  D RET Q:SDUP
  1.  Q
  1.  ;
  1.  ;
  1. PID(DFN) ; Return PID
  1.  ; INPUT  - DFN
  1.  ; OUTPUT - PID or 'UNKNOWN'
  1.  N VA
  1.  D PID^VADPT6
  1.  Q $S(VA("BID")]"":VA("BID"),1:"UNKNOWN")
  1.  ;
  1.  ;
  1. RET ;
  1.  I $E(IOST,1,2)="C-",($Y+6)>IOSL D  Q:SDUP
  1.  . S DIR(0)="E"
  1.  . D ^DIR K DIR
  1.  . I 'Y S SDUP=1 Q
  1.  . K SDXFLG(SDXDIV)
  1.  . D HEAD^SDMHAD S SDXFLG(SDXDIV)=1,SDXFLG(SDXDIV,SDXCLIN)=1,SDXFLG(SDXDIV,SDXSTOP)=1