SDMHAD1.m

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 ---SDMHAD1   11567     printed  Feb 19, 2025@00:25:07                                                                                                                                                                                                    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]""