SDMHNS1.m

SDMHNS1 ;MAF/ALB - MENTAL HEALTH NO SHOW REPORT (BGJ CONT.);SEPTEMBER 9, 2010

 ;;5.3;Scheduling;**578,588**;Aug13,1993;Build 53

DATA ; 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

 S (SDXDFN,SDXREM,SDCOUNT)=0

 I $D(^TMP(NAMSPC1,$J)) D TOTAL^SDMHNS

 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']""!(SDUP)  D

 ...S SDXNM=""

 ...F  S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM)) Q:SDXNM']""!(SDUP)  I SDXNM]"" D

 ....S SDXSTOP=0

 ....F  S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP)) Q:'SDXSTOP!(SDUP)  D

 .....S SDATE=0

 .....F  S SDATE=$O(^TMP("SDNS",$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE)) Q:'SDATE!(SDUP)  D

 ......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE)) D PRT

 .I SDTL="STOP" D

 ..S SDXSTOP=0

 ..F  S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP)) Q:SDXSTOP']""!(SDUP)  D

 ...S SDXNM=""

 ...F  S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM)) Q:SDXNM']""!(SDUP)  I SDXNM]""  D

 ....S SDXCLIN=""

 ....F  S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN)) Q:SDXCLIN']""!(SDUP)  D

 .....S SDATE=0

 .....F  S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE)) Q:SDATE=""!(SDUP)  D

 ......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE)) D PRT

 .I SDTL="MEN" D

 ..S SDXREM=""

 ..F  S SDXREM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM)) Q:SDXREM']""!(SDUP)  D

 ...S SDXNM=""

 ...F  S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXNM)) Q:SDXNM']""!(SDUP)  I SDXNM]""  D

 ....S SDXCLIN=""

 ....F  S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXNM,SDXCLIN)) Q:SDXCLIN']""!(SDUP)  D

 .....S SDATE=0

 .....F  S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXNM,SDXCLIN,SDATE)) Q:SDATE=""!(SDUP)  D

 ......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXNM,SDXCLIN,SDATE)) S SDXSTOP=$P(^TMP(NAMSPC1,$J,SDXDIV,SDXREM,SDXNM,SDXCLIN,SDATE),"^",6) D PRT

 Q

 ;

 ;

PRT ;Print  report

 N SDX

 D COUNT^SDMHNS

 I '$D(SDXFLG(SDXDIV)) D HEAD^SDMHNS  S SDXFLG(SDXDIV)=1,SDXFLG(SDXDIV,SDXCLIN)=1

 I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV,SDXCLIN)) S SDX=$$SETSTR("",X,1,80) D SET1(SDX) D HEAD1^SDMHNS S SDXFLG(SDXDIV,SDXCLIN)=1

 N SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDX,SDDSS

 S SDXSORT1=$S(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)

 S SDXSORT2=$S(SDTL="CLIN":SDXSTOP,1:SDXCLIN)

 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 SDXCLIEN=$P(SDXNODE,"^",5)

 S SDDSS=$P($G(^DIC(40.7,+$P(SDXNODE,"^",6),0)),"^",2)

 I '$D(SDXFLG(SDXDIV,SDXCLIN)) D HEAD1^SDMHNS  S SDXFLG(SDXDIV,SDXCLIN)=1

 S SDXDT=$$FMTE^XLFDT(SDXDT,"5")

 D SET

 ;S SDX=$$SETSTR(SDCOUNT,X,1,2)_$$SETSTR($P(^DPT(SDXDFN,0),"^",1),X,4,20)_$$SETSTR(SDXID,X,2,4)_$$SETSTR(SDXDT,X,6,20)_$$SETSTR(SDXCLIN,X,2,15)_$$SETSTR("*"_SDXSTAT,X,2,4) D SET1(SDX) I SDCOUNT=$P($G(TOTAL(SDXDIV,SDXCLIN)),"^",1) S SDCOUNT=0

 N SDPROV S SDPROV=""

 S SDX=$$SETSTR(SDCOUNT,X,1,3)_$$SETSTR($P(^DPT(SDXDFN,0),"^",1),X,3,20)_$$SETSTR(SDXID,X,2,5)_$$SETSTR(SDXDT,X,2,16)_$$SETSTR(SDXCLIN,X,2,30) D SET1(SDX) D PROV D

 .S SDX=$$SETSTR("*"_SDXSTAT,X,49,5)_$$SETSTR(SDPROV,X,1,26) D SET1(SDX) I SDCOUNT=$P($G(TOTAL(SDXDIV,SDXCLIN)),"^",1) S SDCOUNT=0

 ;D PATINFO

 ;D NOK

 ;D EC

 ;D PROV

 ;D MHTC

 D FUT

 ;D RESULTS

 Q

 ;

 ;

SETSTR(W,X,Y,Z) ;SET UP THE STRING

 ;W= String 

 ;X= Variable to set it into

 ;Y= column to set it into

 ;Z= length of the strubg

 S X=$$SETSTR^SDUL1(W,X,Y,Z)

 Q X

SET1(X) ;Sets the XMTEXT global

 S SDLN=SDLN+1,^TMP("SDNS1",$J,SDLN,0)=X Q

SET ;

 S X="" S SDLN=SDLN+1,^TMP("SDNS1",$J,SDLN,0)=X

 Q

 ;

PATINFO ;Patients home, cell and office phones

 N SDPHON,SDX,VAROOT,SDEC6,SDEC5

 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")]"" S SDX=$$SETSTR("Home:  ",X,4,7)_$$HLPHONE^HLFNC(SDPHON("HOME"),,) D SET1(SDX)

 I $D(SDPHON("WORK")),SDPHON("WORK")]"" S SDX=$$SETSTR("Work:  ",X,4,7)_$$HLPHONE^HLFNC(SDPHON("WORK"),,) D SET1(SDX)

 I $D(SDPHON("CELL")),SDPHON("CELL")]"" S SDX=$$SETSTR("Cell:  ",X,4,7)_$$HLPHONE^HLFNC(SDPHON("CELL"),,) D SET1(SDX)

 Q

 ;

 ;

NOK ; Next of Kin information

 N SDNOK,SDNOK2,SDNOKNM,SDNOKNM2,SDNOKR,SDNOKR2,SDNOKPH,SDNOKPH2,SDNOKPO,SDNOKPO2,SDNOKFL,SDX,SDSET,VAOA,VAROOT,SDEC3,SDEC4,X,SDPHON

 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 SDNOKFL=0

 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")

 S X="",SDX="",SDSET=0

 I $D(SDNOKNM),SDNOKNM]"" D:'SDNOKFL NOKFL S SDX=$$SETSTR("NOK: "_SDNOKNM,X,6,20) S SDSET=1

 I $D(SDNOKNM2),SDNOKNM2]"" D:'SDNOKFL NOKFL S SDX=SDX_$$SETSTR("NOK2: "_SDNOKNM2,X,20,20) S SDSET=1

 I SDSET D SET1(SDX)

 S X="",SDX="",SDSET=0

 I $D(SDNOKR),SDNOKR]"" D:'SDNOKFL NOKFL S SDX=$$SETSTR("Relation: "_SDNOKR,X,6,20) S SDSET=1

 I $D(SDNOKR2),SDNOKR2]""  D:'SDNOKFL NOKFL S SDX=SDX_$$SETSTR("Relation: "_SDNOKR2,X,20,20) S SDSET=1

 I SDSET D SET1(SDX)

 S X="",SDX="",SDSET=0

 I $D(SDNOKPH),SDNOKPH]"" D:'SDNOKFL NOKFL S SDX=$$SETSTR("     Phone: ",X,6,12)_$$SETSTR($$HLPHONE^HLFNC(SDNOKPH,,),X,1,15) S SDSET=1

 I $D(SDNOKPH2),SDNOKPH2]"" D:'SDNOKFL NOKFL S SDX=SDX_$$SETSTR("     Phone: ",X,13,12)_$$SETSTR($$HLPHONE^HLFNC(SDNOKPH2,,),X,1,15) S SDSET=1

 I SDSET D SET1(SDX)

 S X="",SDX="",SDSET=0

 I $D(SDNOKPO),SDNOKPO]"" D:'SDNOKFL NOKFL S SDX=$$SETSTR("Office Phone: ",X,6,14)_$$SETSTR($$HLPHONE^HLFNC(SDNOKPO,,),X,1,13) S SDSET=1

 I $D(SDNOKPO2),SDNOKPO2]"" D:'SDNOKFL NOKFL S SDX=SDX_$$SETSTR("Office Phone: ",X,13,14)_$$SETSTR($$HLPHONE^HLFNC(SDNOKPO2,,),X,1,15) S SDSET=1

 I SDSET D SET1(SDX)

 Q

 ;

 ;

NOKFL S SDX=$$SETSTR("   Next of Kin: ",X,1,16) D SET1(SDX) S SDNOKFL=1,SDX=""

 Q

 ;

 ;

EC ;display emergency contact information

 N SDEC1,SDEC2,SDX,DFN,X,SDPHON,VAROOT,VAOA

 Q:'$G(SDXDFN)

 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

 .S X=""

 . I $D(SDEC1)!($D(SDEC2)) S SDX=$$SETSTR("   Emergency Contact: ",X,1,50) D SET1(SDX)

 . ;Contacts name and realtionship

 . S SDX=""

 . I SDEC1(9)]"" S SDX=$$SETSTR("E-Cont.: ",X,6,10)_$E(SDEC1(9),1,20)

 . I SDEC2(9)]"" S SDX=SDX_$$SETSTR("E2-Cont.: ",X,20,10)_$E(SDEC2(9),1,20)

 . I SDX]"" D SET1(SDX)

 . S SDX=""

 . I SDEC1(10)]"" S SDX=$$SETSTR("Relation: ",X,6,10)_SDEC1(10)

 . I SDEC2(10)]"" S SDX=SDX_$$SETSTR("Relation: ",X,25,10)_SDEC2(10)

 . I SDX]"" D SET1(SDX)

 . ;ECs address lines 1, 2 and 3

 . S SDX=""

 . I SDEC1(1)]"" S SDX=$$SETSTR(SDEC1(1),X,15,20)

 . I SDEC2(1)]"" S SDX=SDX_$$SETSTR(SDEC2(1),X,20,20)

 . I SDX]"" D SET1(SDX)

 . S SDX=""

 . I SDEC1(2)]"" S SDX=$$SETSTR(SDEC1(2),X,15,20)

 . I SDEC2(2)]"" S SDX=SDX_$$SETSTR(SDEC2(2),X,20,20)

 . I SDX]"" D SET1(SDX)

 . S SDX=""

 . I SDEC1(3)]"" S SDX=$$SETSTR(SDEC1(3),X,15,20)

 . I SDEC2(3)]"" S SDX=SDX_$$SETSTR(SDEC2(3),X,20,20)

 . I SDX]"" D SET1(SDX)

 . S SDX=""

 . ;Emergency Contact 1 City, State an Zip+4

 . I SDEC1(4)]"" D

 . . S SDX=""

 . . N SDZ

 . . S SDZ=$L(SDEC1(4))

 . . S SDX=$$SETSTR(SDEC1(4),X,15,SDZ)

 . . I SDEC1(5)]"" S SDX=SDX_", "_$$GET1^DIQ(5,+SDEC1(5),1)

 . . S SDX=SDX_"  "_$P(SDEC1(11),"^",2)

 . ;Emergency Contact 2 City State and Zip+4

 . I SDEC2(4)]"" D

 . . S SDZ=$L(SDEC2(4))

 . . S SDX=SDX_$$SETSTR(SDEC2(4),X,23,SDZ)

 . . I SDEC2(5)]"" S SDX=SDX_", "_$$GET1^DIQ(5,+SDEC2(5),1)

 . . S SDX=SDX_"  "_$P(SDEC2(11),"^",2)

 . I SDX]"" D SET1(SDX)

 . ;Home and work phones

 . S SDX=""

 . I SDEC1(8)]"" S SDX=$$SETSTR("Phone: ",X,6,8)_$$HLPHONE^HLFNC(SDEC1(8),,)

 . I SDEC2(8)]"" S SDX=SDX_$$SETSTR("Phone: ",X,20,8)_$$HLPHONE^HLFNC(SDEC2(8),,)

 . I SDX]"" D SET1(SDX)

 . S SDX=""

 . I SDPHON("E-WORK")]"" S SDX=$$SETSTR("Work Phone: ",X,6,11)_$$HLPHONE^HLFNC(SDPHON("E-WORK"),,)

 . I SDPHON("E2-WORK")]"" S SDX=SDX_$$SETSTR("Work Phone: ",X,17,12)_$$HLPHONE^HLFNC(SDPHON("E2-WORK"),,)

 .I SDX]"" D SET1(SDX)

 D KVAR^VADPT

 Q

 ;

 ;

PROV ;Clinic Default Provider

 N SDPNUM,SDPNODE,SDX

 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=$P(^VA(200,$P(SDPNODE,"^",1),0),"^",1)

 Q

 ;

 ;

MHTC ;Mental Health Treatment Coordinator

 S SDX=""

 S SDX=$$SETSTR("MHTC:  ",X,4,11)

 D SET1(SDX)

 Q

 ;

 ;

FUT ; FUTURE SCHEDULED APPTS.

 N SDARRAY,SDCOUNT,SDX,X1,X2,X,SDNOSDAY

 ;S SDNOSDAY=$$GET^XPAR("PKG.SCHEDULING","SDMH NO SHOW DAYS",1,"E")

 S SDNOSDAY=$$GET^XPAR("SYS^PKG.SCHEDULING","SDMH NO SHOW DAYS",1,"Q")

 S SDNOSDAY=$S(SDNOSDAY]"":SDNOSDAY,1:30)

 ;Find Scheduled apointments witin 30 days using scheduling API

 S X1=DT,X2=SDNOSDAY 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

 . S SDX="",X=""

 . S SDX=$$SETSTR("         Future Scheduled Appointments:  ",X,1,40) D SET1(SDX)

 . N SDFA,SDFNODE,SDFUTDT  ;,SDFUTCNT

 . ;S SDFUTCNT=0  ;List up to 6 future appts for one patient

 . S SDFA=0 F  S SDFA=$O(^TMP($J,"SDAMA301",SDXDFN,SDFA)) Q:SDFA=""  D

 ..S (SDX,X)=""

 ..S SDFUTDT=$$FMTE^XLFDT(SDFA,"5") S SDFNODE=^TMP($J,"SDAMA301",SDXDFN,SDFA)

 ..S SDX=$$SETSTR(SDFUTDT,X,12,18)_$$SETSTR($P($P(SDFNODE,"^",2),";",2),X,2,30)

 ..D SET1(SDX)

 .Q

 I SDCOUNT'>0 D

 .S (SDX,X)=""

 .S SDX="     Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN "_SDNOSDAY_$S(SDNOSDAY=1:" DAY",1:" DAYS")

 .S SDX=$$SETSTR(SDX,X,1,80) D SET1(SDX)

 ;.S SDX=$$SETSTR("     Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN 30 DAYS",X,1,80) D SET1(SDX)

 K ^TMP($J,"SDAMA301")

 Q

 ;

 ;

RESULTS ;Reminder information

 N SDX

 S (SDX,X)=""

 S SDX=$$SETSTR("Results: ",X,4,9) D SET1(SDX)

 Q

 ;

 ;

PID(DFN) ; Return PID

 ; INPUT  - DFN

 ; OUTPUT - PID or 'UNKNOWN'

 N VA

 D PID^VADPT6

 Q $S(VA("BID")]"":VA("BID"),1:"UNKNOWN")

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SDMHNS1   11380     printed  Feb 19, 2025@00:25:10                                                                                                                                                                                                    Page 2

SDMHNS1   ;MAF/ALB - MENTAL HEALTH NO SHOW REPORT (BGJ CONT.);SEPTEMBER 9, 2010

 +1       ;;5.3;Scheduling;**578,588**;Aug13,1993;Build 53

DATA      ; 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

 +2        SET (SDXDFN,SDXREM,SDCOUNT)=0

 +3        IF $DATA(^TMP(NAMSPC1,$JOB))

               DO TOTAL^SDMHNS

 +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 SDXCLIN=""

 +8                        FOR 

                               SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN))

                               if SDXCLIN']""!(SDUP)

                                   QUIT 

                               Begin DoDot:3

 +9                                SET SDXNM=""

 +10                               FOR 

                                       SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN,SDXNM))

                                       if SDXNM']""!(SDUP)

                                           QUIT 

                                       IF SDXNM]""

                                           Begin DoDot:4

 +11                                           SET SDXSTOP=0

 +12                                           FOR 

                                                   SET SDXSTOP=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXCLIN,SDXNM,SDXSTOP))

                                                   if 'SDXSTOP!(SDUP)

                                                       QUIT 

                                                   Begin DoDot:5

 +13                                                   SET SDATE=0

 +14                                                   FOR 

                                                           SET SDATE=$ORDER(^TMP("SDNS",$JOB,SDXDIV,SDXCLIN,SDXNM,SDXSTOP,SDATE))

                                                           if 'SDATE!(SDUP)

                                                               QUIT 

                                                           Begin DoDot:6

 +15                                                           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

 +16               IF SDTL="STOP"

                       Begin DoDot:2

 +17                       SET SDXSTOP=0

 +18                       FOR 

                               SET SDXSTOP=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP))

                               if SDXSTOP']""!(SDUP)

                                   QUIT 

                               Begin DoDot:3

 +19                               SET SDXNM=""

 +20                               FOR 

                                       SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM))

                                       if SDXNM']""!(SDUP)

                                           QUIT 

                                       IF SDXNM]""

                                           Begin DoDot:4

 +21                                           SET SDXCLIN=""

 +22                                           FOR 

                                                   SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM,SDXCLIN))

                                                   if SDXCLIN']""!(SDUP)

                                                       QUIT 

                                                   Begin DoDot:5

 +23                                                   SET SDATE=0

 +24                                                   FOR 

                                                           SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE))

                                                           if SDATE=""!(SDUP)

                                                               QUIT 

                                                           Begin DoDot:6

 +25                                                           IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSTOP,SDXNM,SDXCLIN,SDATE))

                                                                   DO PRT

                                                           End DoDot:6

                                                   End DoDot:5

                                           End DoDot:4

                               End DoDot:3

                       End DoDot:2

 +26               IF SDTL="MEN"

                       Begin DoDot:2

 +27                       SET SDXREM=""

 +28                       FOR 

                               SET SDXREM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM))

                               if SDXREM']""!(SDUP)

                                   QUIT 

                               Begin DoDot:3

 +29                               SET SDXNM=""

 +30                               FOR 

                                       SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXNM))

                                       if SDXNM']""!(SDUP)

                                           QUIT 

                                       IF SDXNM]""

                                           Begin DoDot:4

 +31                                           SET SDXCLIN=""

 +32                                           FOR 

                                                   SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXNM,SDXCLIN))

                                                   if SDXCLIN']""!(SDUP)

                                                       QUIT 

                                                   Begin DoDot:5

 +33                                                   SET SDATE=0

 +34                                                   FOR 

                                                           SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXNM,SDXCLIN,SDATE))

                                                           if SDATE=""!(SDUP)

                                                               QUIT 

                                                           Begin DoDot:6

 +35                                                           IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXNM,SDXCLIN,SDATE))

                                                                   SET SDXSTOP=$PIECE(^TMP(NAMSPC1,$JOB,SDXDIV,SDXREM,SDXNM,SDXCLIN,SDATE),"^",6)

                                                                   DO PRT

                                                           End DoDot:6

                                                   End DoDot:5

                                           End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +36       QUIT 

 +37      ;

 +38      ;

PRT       ;Print  report

 +1        NEW SDX

 +2        DO COUNT^SDMHNS

 +3        IF '$DATA(SDXFLG(SDXDIV))

               DO HEAD^SDMHNS

               SET SDXFLG(SDXDIV)=1

               SET SDXFLG(SDXDIV,SDXCLIN)=1

 +4        IF $DATA(SDXFLG(SDXDIV))

               IF '$DATA(SDXFLG(SDXDIV,SDXCLIN))

                   SET SDX=$$SETSTR("",X,1,80)

                   DO SET1(SDX)

                   DO HEAD1^SDMHNS

                   SET SDXFLG(SDXDIV,SDXCLIN)=1

 +5        NEW SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDX,SDDSS

 +6        SET SDXSORT1=$SELECT(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)

 +7        SET SDXSORT2=$SELECT(SDTL="CLIN":SDXSTOP,1:SDXCLIN)

 +8        SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXSORT1,SDXNM,SDXSORT2,SDATE))

 +9        SET SDXDFN=$PIECE(SDXNODE,"^",1)

           if SDXDFN']""

               QUIT 

 +10       SET SDXID=$PIECE(SDXNODE,"^",4)

 +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,SDXCLIN))

               DO HEAD1^SDMHNS

               SET SDXFLG(SDXDIV,SDXCLIN)=1

 +16       SET SDXDT=$$FMTE^XLFDT(SDXDT,"5")

 +17       DO SET

 +18      ;S SDX=$$SETSTR(SDCOUNT,X,1,2)_$$SETSTR($P(^DPT(SDXDFN,0),"^",1),X,4,20)_$$SETSTR(SDXID,X,2,4)_$$SETSTR(SDXDT,X,6,20)_$$SETSTR(SDXCLIN,X,2,15)_$$SETSTR("*"_SDXSTAT,X,2,4) D SET1(SDX) I SDCOUNT=$P($G(TOTAL(SDXDIV,SDXCLIN)),"^",1) S SDCOUNT=0

 +19       NEW SDPROV

           SET SDPROV=""

 +20       SET SDX=$$SETSTR(SDCOUNT,X,1,3)_$$SETSTR($PIECE(^DPT(SDXDFN,0),"^",1),X,3,20)_$$SETSTR(SDXID,X,2,5)_$$SETSTR(SDXDT,X,2,16)_$$SETSTR(SDXCLIN,X,2,30)

           DO SET1(SDX)

           DO PROV

           Begin DoDot:1

 +21           SET SDX=$$SETSTR("*"_SDXSTAT,X,49,5)_$$SETSTR(SDPROV,X,1,26)

               DO SET1(SDX)

               IF SDCOUNT=$PIECE($GET(TOTAL(SDXDIV,SDXCLIN)),"^",1)

                   SET SDCOUNT=0

           End DoDot:1

 +22      ;D PATINFO

 +23      ;D NOK

 +24      ;D EC

 +25      ;D PROV

 +26      ;D MHTC

 +27       DO FUT

 +28      ;D RESULTS

 +29       QUIT 

 +30      ;

 +31      ;

SETSTR(W,X,Y,Z) ;SET UP THE STRING

 +1       ;W= String 

 +2       ;X= Variable to set it into

 +3       ;Y= column to set it into

 +4       ;Z= length of the strubg

 +5        SET X=$$SETSTR^SDUL1(W,X,Y,Z)

 +6        QUIT X

SET1(X)   ;Sets the XMTEXT global

 +1        SET SDLN=SDLN+1

           SET ^TMP("SDNS1",$JOB,SDLN,0)=X

           QUIT 

SET       ;

 +1        SET X=""

           SET SDLN=SDLN+1

           SET ^TMP("SDNS1",$JOB,SDLN,0)=X

 +2        QUIT 

 +3       ;

PATINFO   ;Patients home, cell and office phones

 +1        NEW SDPHON,SDX,VAROOT,SDEC6,SDEC5

 +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")]""

                   SET SDX=$$SETSTR("Home:  ",X,4,7)_$$HLPHONE^HLFNC(SDPHON("HOME"),,)

                   DO SET1(SDX)

 +12       IF $DATA(SDPHON("WORK"))

               IF SDPHON("WORK")]""

                   SET SDX=$$SETSTR("Work:  ",X,4,7)_$$HLPHONE^HLFNC(SDPHON("WORK"),,)

                   DO SET1(SDX)

 +13       IF $DATA(SDPHON("CELL"))

               IF SDPHON("CELL")]""

                   SET SDX=$$SETSTR("Cell:  ",X,4,7)_$$HLPHONE^HLFNC(SDPHON("CELL"),,)

                   DO SET1(SDX)

 +14       QUIT 

 +15      ;

 +16      ;

NOK       ; Next of Kin information

 +1        NEW SDNOK,SDNOK2,SDNOKNM,SDNOKNM2,SDNOKR,SDNOKR2,SDNOKPH,SDNOKPH2,SDNOKPO,SDNOKPO2,SDNOKFL,SDX,SDSET,VAOA,VAROOT,SDEC3,SDEC4,X,SDPHON

 +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        SET SDNOKFL=0

 +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       SET X=""

           SET SDX=""

           SET SDSET=0

 +14       IF $DATA(SDNOKNM)

               IF SDNOKNM]""

                   if 'SDNOKFL

                       DO NOKFL

                   SET SDX=$$SETSTR("NOK: "_SDNOKNM,X,6,20)

                   SET SDSET=1

 +15       IF $DATA(SDNOKNM2)

               IF SDNOKNM2]""

                   if 'SDNOKFL

                       DO NOKFL

                   SET SDX=SDX_$$SETSTR("NOK2: "_SDNOKNM2,X,20,20)

                   SET SDSET=1

 +16       IF SDSET

               DO SET1(SDX)

 +17       SET X=""

           SET SDX=""

           SET SDSET=0

 +18       IF $DATA(SDNOKR)

               IF SDNOKR]""

                   if 'SDNOKFL

                       DO NOKFL

                   SET SDX=$$SETSTR("Relation: "_SDNOKR,X,6,20)

                   SET SDSET=1

 +19       IF $DATA(SDNOKR2)

               IF SDNOKR2]""

                   if 'SDNOKFL

                       DO NOKFL

                   SET SDX=SDX_$$SETSTR("Relation: "_SDNOKR2,X,20,20)

                   SET SDSET=1

 +20       IF SDSET

               DO SET1(SDX)

 +21       SET X=""

           SET SDX=""

           SET SDSET=0

 +22       IF $DATA(SDNOKPH)

               IF SDNOKPH]""

                   if 'SDNOKFL

                       DO NOKFL

                   SET SDX=$$SETSTR("     Phone: ",X,6,12)_$$SETSTR($$HLPHONE^HLFNC(SDNOKPH,,),X,1,15)

                   SET SDSET=1

 +23       IF $DATA(SDNOKPH2)

               IF SDNOKPH2]""