SDMHAP.m

SDMHAP ;MAF/ALB - MENTAL HEALTH AD HOC PROACTIVE HIGH RISK REPORT;JULY 14, 2010

 ;;5.3;Scheduling;**588**;Aug 13,1993;Build 53

 ;

EN ;entry point for the manual generation of the Proactive Report

 N SDBEG,SDEND,VAUTD,Y,SDUP,SDXFLG,SDTL,SDALL,SDDAT,Y,X,SDDAT,VADAT,ZTRTN,ZTSAVE,VADATE,%ZIS,%

 I '$$RANGE G QUIT

 I '$$DIV G QUIT

SORT ;sort is by clinic

 S SDTL="CLIN"

 D @(SDTL) G:Y=-1 QUIT

 W !!,*7,"This output requires 80 column output",!

 D NOW^%DTC S Y=$E(%,1,12) S SDDAT=$$FMTE^XLFDT(Y,"5")

 S IOM=80 S %ZIS="QM",%ZIS("A")="Select Device: ",%ZIS("B")="" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTRTN="START^SDMHAP",ZTSAVE("SD*")="",ZTSAVE("VA*")="" D ^%ZTLOAD K IO("Q"),ZTSK Q

 ;

START ;

 I $E(IOST)="C" D WAIT^DICD I $D(SDXFLG) D

 .W !!,?10,"This report option generates a mail message containing the"

 .W !,?10,"High Risk Mental Health Proactive Nightly Report which is sent only"

 .W !,?10,"to individuals in the SD MH NO SHOW NOTIFICATION mailgroup.",!

 N SDDIV,SDPAG,SDCL,SDSC,SDRLL,SDPAG,NAMSPC,NAMSPC1,SDSTOP,VAUTRR,SDLINE,Y,TOTAL,SDPAT

 N X S X="DGPFAPIH" X ^%ZOSF("TEST") S X="" I '$T D  Q

 .I '$D(SDXFLG) W !!,"Patch DG*5.3*836 needs to be installed - ICR 4903.",!,"Routines required to run report. Aborting!",! Q

 .N SDX S SDX=""

 .S SDX=$$SETSTR^SDMHPRO1("Patch DG*5.3*836 needs to be installed - ICR 4903.",X,1,80) D SET1^SDMHPRO1(SDX)

 .S SDX="" S SDX=$$SETSTR^SDMHPRO1("Routines required to run report. Report Aborted!",X,1,80) D SET1^SDMHPRO1(SDX)

 .S SDX=""

 S Y=0 D LIST Q:Y=1

 S NAMSPC=$$NAMSPC

 S NAMSPC1=$$NAMSPC1

 K ^TMP(NAMSPC),^TMP(NAMSPC1)

 S (SDPAG,SDCL,SDSC,SDRLL)=0

 I $D(SDXFLG),SDXFLG=1 S VAUTCL=1

 ;I $D(SDXFLG) D PXRMD

 I $D(SDALL) I SDALL="M" D PXRMD

 I VAUTD=1 D

 .S SDDIV=0 F SDDIV=0:0 S SDDIV=$O(^DG(40.8,SDDIV)) Q:'SDDIV  I $D(^DG(40.8,SDDIV,0)) S VAUTD(SDDIV)=$P(^DG(40.8,SDDIV,0),"^",1)

 I SDTL'="MEN" F SDCL=0:0 S SDCL=$O(^SC(SDCL)) Q:'SDCL  I $D(^SC(SDCL,0)),$P($G(^SC(SDCL,0)),"^",3)="C" D

 .S SDSC=$P($G(^SC(SDCL,0)),"^",7),SDDIV=$S('$P($G(^SC(SDCL,0)),"^",15):"NOT SPECIFIED",1:$P($G(^SC(SDCL,0)),"^",15)) I SDSC D CHK  ;S ^TMP("SDCLST",$J,SDCL,SDSC)=$P(^SC(SDCL,0),"^",1)

 I SDTL="MEN" S SDRLL=$O(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL",0)) D

 .F SDDIV=0:0 S SDDIV=$O(VAUTRR(SDDIV)) Q:'SDDIV  F SDSC=0:0 S SDSC=$O(VAUTRR(SDDIV,SDSC)) Q:'SDSC  F SDCL=0:0 S SDCL=$O(VAUTRR(SDDIV,SDSC,SDCL)) Q:'SDCL  I SDCL D CHK

 S SDLINE=$S($D(^TMP(NAMSPC,$J)):"PROCESS",1:"END")

 D @SDLINE

 G QUIT

 ;

 ;

PROCESS ;find patients in date range that have scheduled appt for a clinic in the date range.

 N SDIV,SDC,SDR,SDS,SDHFL,SDUP,SDMHFLG,SDMHNFLG,SDACT

 S (SDIV,SDC,SDR,SDS,SDUP)=0

 S SDMHFLG=$$GET^XPAR("PKG.REGISTRATION","DGPF SUICIDE FLAG",1,"E")

 S SDMHFLG("L")=$$GETFLAG^DGPFAPIU(SDMHFLG,"L")

 S SDMHNFLG="HIGH RISK FOR SUICIDE"

 S SDMHFLG("N")=$$GETFLAG^DGPFAPIU(SDMHNFLG,"N")

 F SDIV=0:0 S SDIV=$O(^TMP(NAMSPC,$J,SDIV)) Q:SDIV=""!(SDUP)  F SDC=SDC:0 S SDC=$O(^TMP(NAMSPC,$J,SDIV,SDC)) Q:SDC=""!(SDUP)  F SDS=SDS:0 S SDS=$O(^TMP(NAMSPC,$J,SDIV,SDC,SDS)) Q:SDS=""!(SDUP)  D

 .I SDTL="MEN" S SDR=$P($G(^TMP(NAMSPC,$J,SDIV,SDC,SDS)),"^",4)

 .N SDDT,SDNUM,SDNUM1,DFN,SDSTAT,ACT,SDRR

 .S (SDDT,SDNUM,SDNUM1,DFN,SDSTAT)=0

 .F SDDT=SDBEG:0 S SDDT=$O(^SC(SDC,"S",SDDT)) Q:'SDDT!(SDDT>SDEND)!(SDUP)  F SDNUM=0:0 S SDNUM=$O(^SC(SDC,"S",SDDT,SDNUM)) Q:'SDNUM!(SDUP)  F SDNUM1=0:0 S SDNUM1=$O(^SC(SDC,"S",SDDT,SDNUM,SDNUM1)) Q:'SDNUM1!(SDUP)  D

 ..Q:'$D(^SC(SDC,"S",SDDT,SDNUM,SDNUM1,0))

 ..S DFN=$P($G(^SC(SDC,"S",SDDT,SDNUM,SDNUM1,0)),"^",1) Q:'DFN  Q:$D(^SC(SDC,"S",SDDT,SDNUM,SDNUM1,"C"))

 ..;I $D(^DPT(DFN,0)),$D(^DPT(DFN,"S",SDDT)) S SDSTAT=$P($G(^DPT(DFN,"S",SDDT,0)),"^",2) I $$GETINF^DGPFAPIH(DFN,SDMHFLG("L"),SDDT,SDDT,"ACT")!($$GETINF^DGPFAPIH(DFN,SDMHFLG("N"),SDDT,SDDT,"ACT")) D  Q:SDUP

 ..I $D(^DPT(DFN,0)),$D(^DPT(DFN,"S",SDDT)) S SDSTAT=$P($G(^DPT(DFN,"S",SDDT,0)),"^",2) Q:SDSTAT="N"!(SDSTAT="NA")  D ACT I SDACT D  Q:SDUP

 ...N PATNM,SDCLNM,SDDIVNM,SDSCNM,SDZERO

 ...S SDDIVNM=$S($P(^DG(40.8,SDIV,0),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$P(^DG(40.8,SDIV,0),"^",1))

 ...S SDCLNM=$S($P($G(^SC(SDC,0)),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$P(^SC(SDC,0),"^",1))

 ...S SDSCNM=$S($P($G(^DIC(40.7,SDS,0)),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$P(^DIC(40.7,SDS,0),"^",1))

 ...S PATNM=$S($P($G(^DPT(DFN,0)),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$P(^DPT(DFN,0),"^",1))

 ...I SDTL="CLIN" S ^TMP(NAMSPC1,$J,SDDIVNM,PATNM,SDDT,SDCLNM,SDS)=DFN_"^"_SDDT_"^"_SDSTAT_"^"_$E(PATNM,1)_$$PID(DFN)_"^"_SDC_"^"_SDS ;D TOTAL(SDDIVNM,SDCLNM)

 ...I SDTL="STOP" S ^TMP(NAMSPC1,$J,SDDIVNM,SDSCNM,PATNM,SDCLNM,SDDT)=DFN_"^"_SDDT_"^"_SDSTAT_"^"_$E(PATNM,1)_$$PID(DFN)_"^"_SDC_"^"_SDS

 ...I SDTL="MEN" S SDRR=$P(^PXRMD(810.9,SDR,0),"^",1) S ^TMP(NAMSPC1,$J,SDDIVNM,SDRR,SDCLNM,PATNM,SDDT)=DFN_"^"_SDDT_"^"_SDSTAT_"^"_$E(PATNM,1)_$$PID(DFN)_"^"_SDC_"^"_SDS

 ...D TOTAL(SDDIVNM)

BGJ I $D(SDXFLG) D  Q

 .I '$D(^TMP(NAMSPC1,$J)) D HEAD^SDMHPRO

 .D ^SDMHPRO1 Q

 I '$D(^TMP(NAMSPC1,$J)) G END

 D ^SDMHAP1

 Q

CHK ;Check to see if Division/Clinic/Stop have been selected & if  Clinic and Stop code are a valid mental health pair.

 N SDFLG,SDCLNM,SDDIVNM,SDSCNM

 S SDFLG=0

 I $D(VAUTD) D  Q:SDFLG

 . I SDDIV="NOT SPECIFIED" S SDFLG=1 Q

 . I 'VAUTD,'$D(VAUTD(SDDIV)) S SDFLG=1 Q

 I $D(VAUTCL) D  Q:SDFLG

 . I SDCL="NOT SPECIFIED" S SDFLG=1 Q

 . I 'VAUTCL,'$D(VAUTCL(SDCL)) S SDFLG=1 Q

 I $D(VAUTSC) D  Q:SDFLG

 . I SDSC="NOT SPECIFIED" S SDFLG=1 Q

 . I 'VAUTSC,'$D(VAUTSC(SDSC)) S SDFLG=1 Q

 Q:'$D(^DG(40.8,SDDIV,0))

 S SDDIVNM=$S($P($G(^DG(40.8,SDDIV,0)),"^",1)="":"NOT SPECIFIED",1:$P(^DG(40.8,SDDIV,0),"^",1))

 Q:'$D(^SC(SDCL,0))

 S SDCLNM=$S($P($G(^SC(SDCL,0)),"^",1)="":"NOT SPECIFIED",1:$P(^SC(SDCL,0),"^",1))

 Q:'$D(^DIC(40.7,SDSC,0))

 S SDSCNM=$S($P($G(^DIC(40.7,SDSC,0)),"^",1)="":"NOT SPECIFIED",1:$P(^DIC(40.7,SDSC,0),"^",1))

 S ^TMP(NAMSPC,$J,SDDIV,SDCL,SDSC)=SDDIVNM_"^"_SDCLNM_"^"_SDSCNM_"^"_$S(SDRLL="NOT SPECIFIED":"NOT SPECIFIED",1:SDRLL)

 Q

 ;

ACT ;Make sure patient has active patient record flag

 N SDDTNT

 S SDDTNT=$P(SDDT,".",1)

 I $$GETINF^DGPFAPIH(DFN,SDMHFLG("L"),SDDTNT,SDDTNT,"ACT") S SDACT=1 Q

 I $$GETINF^DGPFAPIH(DFN,SDMHFLG("N"),SDDTNT,SDDTNT,"ACT") S SDACT=1 Q  ;For increment 3

 S SDACT=0

 Q

HEAD ;Heading for the report

 W @IOF

 W "HIGH RISK MENTAL HEALTH PROACTIVE ADHOC REPORT BY",?70,"PAGE " S SDPAG=SDPAG+1 W SDPAG,!

 W $S(SDTL="MEN":"MENTAL HEALTH",SDTL="STOP":"STOP CODE",1:"CLINIC")_" for Appointments "_$$FMTE^XLFDT(SDBEG,"2")_"-"_$$FMTE^XLFDT($P(SDEND,".",1),"2"),?56,"Run: "_SDDAT

 I $D(SDTOTPG) W !!,"Totals Page"

 I '$D(SDTOTPG) W !!,"#",?4,"PATIENT",?25,"PT ID",?32,"APPT D/T",?49,"CLINIC"

 W !,$$LINE(""),!

HEAD1 I $D(^TMP(NAMSPC1,$J)),'$D(SDTOTPG) D

 . N SDHEAD2

 .I SDTL'="STOP" S SDHEAD2="DIVISION: "_$E(SDXDIV,1,30)

 .W SDHEAD2,!

 Q

 ;

 ;

RANGE() ;Select Start and End date for report

 W !!,$$LINE(" High Risk Mental Health Proactive Adhoc Report")

 Q $$RANGE1(.SDBEG,.SDEND)

 ;

DIV() ;Division selection for multidivisional facility

 D ASK2^SDDIV I Y<0 K VAUTD

 Q $D(VAUTD)>0

 ;

LIST N X I '$D(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL")) D  Q

 .I '$D(SDXFLG) W !!!,"Reminder location List file is not current.",!,"Missing reminder location list 'VA-MH NO SHOW APPT CLINICS LL' in file 810.9.",!,"Report Aborting!",! S Y=1 Q

 .N SDX S SDX="",X=""

 .S SDX=$$SETSTR^SDMHPRO1("Reminder location List file is not current.",X,1,80) D SET1^SDMHPRO1(SDX)

 .S SDX="",X="" S SDX=$$SETSTR^SDMHPRO1("Missing reminder location list 'VA-MH NO SHOW APPT CLINICS LL' in file 810.9.",X,1,80) D SET1^SDMHPRO1(SDX)

 .S SDX="",X="" S SDX=$$SETSTR^SDMHPRO1("Report Aborted!",X,1,80) D SET1^SDMHPRO1(SDX)

 .S SDX=""

 .S Y=1

LINE(STR) ; Print display prompts

 N X

 S:STR]"" STR=" "_STR_" "

 S $P(X,"*",(IOM/2)-($L(STR)/2))=""

 Q X_STR_X

 ;

LINE1(STR) ; Print display prompts

 N X

 S:STR]"" STR=" "_STR_" "

 S $P(X," ",(IOM/2)-($L(STR)/2))=""

 Q X_STR_X

 ;

 ;

TOTAL(DIV) ;INITIALIZE total(DIV,CLIN/STOP)

 I '$D(TOTAL(DIV)) D

 .N SDCNTT S SDCNTT=0

 .S TOTAL(DIV)="0^0^0^0^0"

 I $D(TOTAL(DIV)) D

 .S $P(TOTAL(DIV),"^",1)=$P($G(TOTAL(DIV)),"^",1)+1

 .N X S X=$S(SDSTAT="NS":2,SDSTAT="NSA":3,1:4) S $P(TOTAL(DIV),"^",X)=$P(TOTAL(DIV),"^",X)+1

 .I '$D(SDPAT(DIV,DFN)) S SDPAT(DIV,DFN)="",$P(TOTAL(DIV),"^",5)=$P(TOTAL(DIV),"^",5)+1

 Q

 ;

 ;

CLIN ;select clinics

 W !!,"Sort the report by:",!,?20,"A  All clinics",!,?20,"M  Mental Health clinics only",!

 R !,"Sort by: (A)ll clinics  A//",X:DTIME S:X["^"!('$T) Y=-1 Q:Y=-1  S X=$S(X="":"A",1:$E(X)) I "AMam"'[X W !,"Enter a 'A' for All clinics or 'M' for Mental Health clinics only" G CLIN

 S SDALL=X

 N DIC,K,VAUTVB,VAUTSTR,VAUTNI

 S VAUTVB="VAUTCL",DIC="^SC("

 I SDALL="M" S DIC("S")="N X,K S X=$O(^PXRMD(810.9,""B"",""VA-MH NO SHOW APPT CLINICS LL"",0)) I $D(^SC(+Y,0)) S K=$P(^SC(+Y,0),""^"",7) I $D(^PXRMD(810.9,X,40.7,""B"",+K))"

 S VAUTSTR="Clinic",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 SDFL=1 Q:$D(SDFL)

 Q

 ;

PID(DFN) ; Return PID

 ; INPUT  - DFN

 ; OUTPUT - PID or 'UNKNOWN'

 N VA

 D PID^VADPT6

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

 ;

RANGE1(SDBEG,SDEND,SDAMETH) ; -- select range

 N SDWITCH,SDT,X1,X2,X

 S (SDBEG,SDEND)=0,SDT=DT

 I $G(SDAMETH)>0 S X1=DT,X2=-1 D C^%DTC S SDT=X

 S DIR("B")=$$FDATE^VALM1(SDT),SDWITCH=$$SWITCH^SDAMU

 S DIR("?",1)="Dates in the past (after "_$$FDATE^VALM1(SDWITCH)_" ) and into the  future can be entered",DIR("?")=" "

 S DIR(0)="DA",DIR("A")="Select Beginning Date: "

 W ! D ^DIR K DIR G RANGEQ:Y'>0 S SDBEG=Y

 S DIR("B")=$$FDATE^VALM1(SDT)

 S DIR(0)="DA",DIR("A")="Select    Ending Date: "

 S DIR("?",1)="Dates between "_$$FDATE^VALM1(SDBEG)_"and into the future can be entered. ",DIR("?")=" "

 D ^DIR K DIR G RANGEQ:Y'>0 S SDEND=Y_".24"

RANGEQ Q SDEND

 ;

NAMSPC() ; API returns the name space for this patch

 Q "SDPRO"

NAMSPC1() ; API returns the name space for this patch

 Q "SDPRO1"

PXRMD ;Set up Reminder Location List valid Stop Codes for Proactive Report

 N SDX,SDY,SDI,SDSFL,SDCFL

 S SDY=0

 S SDX=$O(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL",0)) Q:SDX']""  F  S SDY=$O(^PXRMD(810.9,SDX,40.7,"B",SDY)) Q:SDY']""  D

 .S SDSTOP(+SDY)=""

 .I SDTL="MEN" N SDI S SDI=0 F  S SDI=$O(^SC("AST",+SDY,SDI)) Q:SDI']""  S VAUTRR(+$P($G(^SC(+SDI,0)),"^",15),+SDY,+SDI)=""

 .I $D(VAUTSC),$G(VAUTSC)=1 S VAUTSC(+SDY)=$P($G(^DIC(40.7,+SDY,0)),"^",1) S SDSFL=1

 .I $D(VAUTCL),$G(VAUTCL)=1 N SDI S SDI=0 F  S SDI=$O(^SC("AST",+SDY,SDI)) Q:SDI']""  D 

 ..S VAUTCL(+SDI)=$P($G(^SC(+SDI,0)),"^",1) S SDCFL=1

 I $D(SDSFL) S VAUTSC=0

 I $D(SDCFL) S VAUTCL=0

 Q

END ;NO RECORDS

 D HEAD

 W !!,$$LINE1(">>>>>>  NO RECORDS FOUND <<<<<<")

QUIT K %DT,DIR,SDTBEG,SDTEND,SDDIV,SDFL,SDTOTPG,SDXDIV,SDMHNFLG,VAUTD,VAUTCL,VAUTR,VAUTSC,VADAT,VADATE,POP,X,Y

 K ^TMP("SDPRO",$J),^TMP("SDPRO1",$J)

 D CLOSE^DGUTQ Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SDMHAP   10846     printed  Mar 13, 2025@22:03:43                                                                                                                                                                                                     Page 2

SDMHAP    ;MAF/ALB - MENTAL HEALTH AD HOC PROACTIVE HIGH RISK REPORT;JULY 14, 2010

 +1       ;;5.3;Scheduling;**588**;Aug 13,1993;Build 53

 +2       ;

EN        ;entry point for the manual generation of the Proactive Report

 +1        NEW SDBEG,SDEND,VAUTD,Y,SDUP,SDXFLG,SDTL,SDALL,SDDAT,Y,X,SDDAT,VADAT,ZTRTN,ZTSAVE,VADATE,%ZIS,%

 +2        IF '$$RANGE

               GOTO QUIT

 +3        IF '$$DIV

               GOTO QUIT

SORT      ;sort is by clinic

 +1        SET SDTL="CLIN"

 +2        DO @(SDTL)

           if Y=-1

               GOTO QUIT

 +3        WRITE !!,*7,"This output requires 80 column output",!

 +4        DO NOW^%DTC

           SET Y=$EXTRACT(%,1,12)

           SET SDDAT=$$FMTE^XLFDT(Y,"5")

 +5        SET IOM=80

           SET %ZIS="QM"

           SET %ZIS("A")="Select Device: "

           SET %ZIS("B")=""

           DO ^%ZIS

           if POP

               GOTO QUIT

           IF $DATA(IO("Q"))

               SET ZTRTN="START^SDMHAP"

               SET ZTSAVE("SD*")=""

               SET ZTSAVE("VA*")=""

               DO ^%ZTLOAD

               KILL IO("Q"),ZTSK

               QUIT 

 +6       ;

START     ;

 +1        IF $EXTRACT(IOST)="C"

               DO WAIT^DICD

               IF $DATA(SDXFLG)

                   Begin DoDot:1

 +2                    WRITE !!,?10,"This report option generates a mail message containing the"

 +3                    WRITE !,?10,"High Risk Mental Health Proactive Nightly Report which is sent only"

 +4                    WRITE !,?10,"to individuals in the SD MH NO SHOW NOTIFICATION mailgroup.",!

                   End DoDot:1

 +5        NEW SDDIV,SDPAG,SDCL,SDSC,SDRLL,SDPAG,NAMSPC,NAMSPC1,SDSTOP,VAUTRR,SDLINE,Y,TOTAL,SDPAT

 +6        NEW X

           SET X="DGPFAPIH"

           XECUTE ^%ZOSF("TEST")

           SET X=""

           IF '$TEST

               Begin DoDot:1

 +7                IF '$DATA(SDXFLG)

                       WRITE !!,"Patch DG*5.3*836 needs to be installed - ICR 4903.",!,"Routines required to run report. Aborting!",!

                       QUIT 

 +8                NEW SDX

                   SET SDX=""

 +9                SET SDX=$$SETSTR^SDMHPRO1("Patch DG*5.3*836 needs to be installed - ICR 4903.",X,1,80)

                   DO SET1^SDMHPRO1(SDX)

 +10               SET SDX=""

                   SET SDX=$$SETSTR^SDMHPRO1("Routines required to run report. Report Aborted!",X,1,80)

                   DO SET1^SDMHPRO1(SDX)

 +11               SET SDX=""

               End DoDot:1

               QUIT 

 +12       SET Y=0

           DO LIST

           if Y=1

               QUIT 

 +13       SET NAMSPC=$$NAMSPC

 +14       SET NAMSPC1=$$NAMSPC1

 +15       KILL ^TMP(NAMSPC),^TMP(NAMSPC1)

 +16       SET (SDPAG,SDCL,SDSC,SDRLL)=0

 +17       IF $DATA(SDXFLG)

               IF SDXFLG=1

                   SET VAUTCL=1

 +18      ;I $D(SDXFLG) D PXRMD

 +19       IF $DATA(SDALL)

               IF SDALL="M"

                   DO PXRMD

 +20       IF VAUTD=1

               Begin DoDot:1

 +21               SET SDDIV=0

                   FOR SDDIV=0:0

                       SET SDDIV=$ORDER(^DG(40.8,SDDIV))

                       if 'SDDIV

                           QUIT 

                       IF $DATA(^DG(40.8,SDDIV,0))

                           SET VAUTD(SDDIV)=$PIECE(^DG(40.8,SDDIV,0),"^",1)

               End DoDot:1

 +22       IF SDTL'="MEN"

               FOR SDCL=0:0

                   SET SDCL=$ORDER(^SC(SDCL))

                   if 'SDCL

                       QUIT 

                   IF $DATA(^SC(SDCL,0))

                       IF $PIECE($GET(^SC(SDCL,0)),"^",3)="C"

                           Begin DoDot:1

 +23      ;S ^TMP("SDCLST",$J,SDCL,SDSC)=$P(^SC(SDCL,0),"^",1)

                               SET SDSC=$PIECE($GET(^SC(SDCL,0)),"^",7)

                               SET SDDIV=$SELECT('$PIECE($GET(^SC(SDCL,0)),"^",15):"NOT SPECIFIED",1:$PIECE($GET(^SC(SDCL,0)),"^",15))

                               IF SDSC

                                   DO CHK

                           End DoDot:1

 +24       IF SDTL="MEN"

               SET SDRLL=$ORDER(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL",0))

               Begin DoDot:1

 +25               FOR SDDIV=0:0

                       SET SDDIV=$ORDER(VAUTRR(SDDIV))

                       if 'SDDIV

                           QUIT 

                       FOR SDSC=0:0

                           SET SDSC=$ORDER(VAUTRR(SDDIV,SDSC))

                           if 'SDSC

                               QUIT 

                           FOR SDCL=0:0

                               SET SDCL=$ORDER(VAUTRR(SDDIV,SDSC,SDCL))

                               if 'SDCL

                                   QUIT 

                               IF SDCL

                                   DO CHK

               End DoDot:1

 +26       SET SDLINE=$SELECT($DATA(^TMP(NAMSPC,$JOB)):"PROCESS",1:"END")

 +27       DO @SDLINE

 +28       GOTO QUIT

 +29      ;

 +30      ;

PROCESS   ;find patients in date range that have scheduled appt for a clinic in the date range.

 +1        NEW SDIV,SDC,SDR,SDS,SDHFL,SDUP,SDMHFLG,SDMHNFLG,SDACT

 +2        SET (SDIV,SDC,SDR,SDS,SDUP)=0

 +3        SET SDMHFLG=$$GET^XPAR("PKG.REGISTRATION","DGPF SUICIDE FLAG",1,"E")

 +4        SET SDMHFLG("L")=$$GETFLAG^DGPFAPIU(SDMHFLG,"L")

 +5        SET SDMHNFLG="HIGH RISK FOR SUICIDE"

 +6        SET SDMHFLG("N")=$$GETFLAG^DGPFAPIU(SDMHNFLG,"N")

 +7        FOR SDIV=0:0

               SET SDIV=$ORDER(^TMP(NAMSPC,$JOB,SDIV))

               if SDIV=""!(SDUP)

                   QUIT 

               FOR SDC=SDC:0

                   SET SDC=$ORDER(^TMP(NAMSPC,$JOB,SDIV,SDC))

                   if SDC=""!(SDUP)

                       QUIT 

                   FOR SDS=SDS:0

                       SET SDS=$ORDER(^TMP(NAMSPC,$JOB,SDIV,SDC,SDS))

                       if SDS=""!(SDUP)

                           QUIT 

                       Begin DoDot:1

 +8                        IF SDTL="MEN"

                               SET SDR=$PIECE($GET(^TMP(NAMSPC,$JOB,SDIV,SDC,SDS)),"^",4)

 +9                        NEW SDDT,SDNUM,SDNUM1,DFN,SDSTAT,ACT,SDRR

 +10                       SET (SDDT,SDNUM,SDNUM1,DFN,SDSTAT)=0

 +11                       FOR SDDT=SDBEG:0

                               SET SDDT=$ORDER(^SC(SDC,"S",SDDT))

                               if 'SDDT!(SDDT>SDEND)!(SDUP)

                                   QUIT 

                               FOR SDNUM=0:0

                                   SET SDNUM=$ORDER(^SC(SDC,"S",SDDT,SDNUM))

                                   if 'SDNUM!(SDUP)

                                       QUIT 

                                   FOR SDNUM1=0:0

                                       SET SDNUM1=$ORDER(^SC(SDC,"S",SDDT,SDNUM,SDNUM1))

                                       if 'SDNUM1!(SDUP)

                                           QUIT 

                                       Begin DoDot:2

 +12                                       if '$DATA(^SC(SDC,"S",SDDT,SDNUM,SDNUM1,0))

                                               QUIT 

 +13                                       SET DFN=$PIECE($GET(^SC(SDC,"S",SDDT,SDNUM,SDNUM1,0)),"^",1)

                                           if 'DFN

                                               QUIT 

                                           if $DATA(^SC(SDC,"S",SDDT,SDNUM,SDNUM1,"C"))

                                               QUIT 

 +14      ;I $D(^DPT(DFN,0)),$D(^DPT(DFN,"S",SDDT)) S SDSTAT=$P($G(^DPT(DFN,"S",SDDT,0)),"^",2) I $$GETINF^DGPFAPIH(DFN,SDMHFLG("L"),SDDT,SDDT,"ACT")!($$GETINF^DGPFAPIH(DFN,SDMHFLG("N"),SDDT,SDDT,"ACT")) D  Q:SDUP

 +15                                       IF $DATA(^DPT(DFN,0))

                                               IF $DATA(^DPT(DFN,"S",SDDT))

                                                   SET SDSTAT=$PIECE($GET(^DPT(DFN,"S",SDDT,0)),"^",2)

                                                   if SDSTAT="N"!(SDSTAT="NA")

                                                       QUIT 

                                                   DO ACT

                                                   IF SDACT

                                                       Begin DoDot:3

 +16                                                       NEW PATNM,SDCLNM,SDDIVNM,SDSCNM,SDZERO

 +17                                                       SET SDDIVNM=$SELECT($PIECE(^DG(40.8,SDIV,0),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$PIECE(^DG(40.8,SDIV,0),"^",1))

 +18                                                       SET SDCLNM=$SELECT($PIECE($GET(^SC(SDC,0)),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$PIECE(^SC(SDC,0),"^",1))

 +19                                                       SET SDSCNM=$SELECT($PIECE($GET(^DIC(40.7,SDS,0)),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$PIECE(^DIC(40.7,SDS,0),"^",1))

 +20                                                       SET PATNM=$SELECT($PIECE($GET(^DPT(DFN,0)),"^",1)="NOT SPECIFIED":"NOT SPECIFIED",1:$PIECE(^DPT(DFN,0),"^",1))

 +21      ;D TOTAL(SDDIVNM,SDCLNM)

                                                           IF SDTL="CLIN"

                                                               SET ^TMP(NAMSPC1,$JOB,SDDIVNM,PATNM,SDDT,SDCLNM,SDS)=DFN_"^"_SDDT_"^"_SDSTAT_"^"_$EXTRACT(PATNM,1)_$$PID(DFN)_"^"_SDC_"^"_SDS

 +22                                                       IF SDTL="STOP"

                                                               SET ^TMP(NAMSPC1,$JOB,SDDIVNM,SDSCNM,PATNM,SDCLNM,SDDT)=DFN_"^"_SDDT_"^"_SDSTAT_"^"_$EXTRACT(PATNM,1)_$$PID(DFN)_"^"_SDC_"^"_SDS

 +23                                                       IF SDTL="MEN"

                                                               SET SDRR=$PIECE(^PXRMD(810.9,SDR,0),"^",1)

                                                               SET ^TMP(NAMSPC1,$JOB,SDDIVNM,SDRR,SDCLNM,PATNM,SDDT)=DFN_"^"_SDDT_"^"_SDSTAT_"^"_$EXTRACT(PATNM,1)_$$PID(DFN)_"^"_SDC_"^"_SDS

 +24                                                       DO TOTAL(SDDIVNM)

                                                       End DoDot:3

                                                       if SDUP

                                                           QUIT 

                                       End DoDot:2

                       End DoDot:1

BGJ        IF $DATA(SDXFLG)

               Begin DoDot:1

 +1                IF '$DATA(^TMP(NAMSPC1,$JOB))

                       DO HEAD^SDMHPRO

 +2                DO ^SDMHPRO1

                   QUIT 

               End DoDot:1

               QUIT 

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

               GOTO END

 +4        DO ^SDMHAP1

 +5        QUIT 

CHK       ;Check to see if Division/Clinic/Stop have been selected & if  Clinic and Stop code are a valid mental health pair.

 +1        NEW SDFLG,SDCLNM,SDDIVNM,SDSCNM

 +2        SET SDFLG=0

 +3        IF $DATA(VAUTD)

               Begin DoDot:1

 +4                IF SDDIV="NOT SPECIFIED"

                       SET SDFLG=1

                       QUIT 

 +5                IF 'VAUTD

                       IF '$DATA(VAUTD(SDDIV))

                           SET SDFLG=1

                           QUIT 

               End DoDot:1

               if SDFLG

                   QUIT 

 +6        IF $DATA(VAUTCL)

               Begin DoDot:1

 +7                IF SDCL="NOT SPECIFIED"

                       SET SDFLG=1

                       QUIT 

 +8                IF 'VAUTCL

                       IF '$DATA(VAUTCL(SDCL))

                           SET SDFLG=1

                           QUIT 

               End DoDot:1

               if SDFLG

                   QUIT 

 +9        IF $DATA(VAUTSC)

               Begin DoDot:1

 +10               IF SDSC="NOT SPECIFIED"

                       SET SDFLG=1

                       QUIT 

 +11               IF 'VAUTSC

                       IF '$DATA(VAUTSC(SDSC))

                           SET SDFLG=1

                           QUIT 

               End DoDot:1

               if SDFLG

                   QUIT 

 +12       if '$DATA(^DG(40.8,SDDIV,0))

               QUIT 

 +13       SET SDDIVNM=$SELECT($PIECE($GET(^DG(40.8,SDDIV,0)),"^",1)="":"NOT SPECIFIED",1:$PIECE(^DG(40.8,SDDIV,0),"^",1))

 +14       if '$DATA(^SC(SDCL,0))

               QUIT 

 +15       SET SDCLNM=$SELECT($PIECE($GET(^SC(SDCL,0)),"^",1)="":"NOT SPECIFIED",1:$PIECE(^SC(SDCL,0),"^",1))

 +16       if '$DATA(^DIC(40.7,SDSC,0))

               QUIT 

 +17       SET SDSCNM=$SELECT($PIECE($GET(^DIC(40.7,SDSC,0)),"^",1)="":"NOT SPECIFIED",1:$PIECE(^DIC(40.7,SDSC,0),"^",1))

 +18       SET ^TMP(NAMSPC,$JOB,SDDIV,SDCL,SDSC)=SDDIVNM_"^"_SDCLNM_"^"_SDSCNM_"^"_$SELECT(SDRLL="NOT SPECIFIED":"NOT SPECIFIED",1:SDRLL)

 +19       QUIT 

 +20      ;

ACT       ;Make sure patient has active patient record flag

 +1        NEW SDDTNT

 +2        SET SDDTNT=$PIECE(SDDT,".",1)

 +3        IF $$GETINF^DGPFAPIH(DFN,SDMHFLG("L"),SDDTNT,SDDTNT,"ACT")

               SET SDACT=1

               QUIT 

 +4       ;For increment 3

           IF $$GETINF^DGPFAPIH(DFN,SDMHFLG("N"),SDDTNT,SDDTNT,"ACT")

               SET SDACT=1

               QUIT 

 +5        SET SDACT=0

 +6        QUIT 

HEAD      ;Heading for the report

 +1        WRITE @IOF

 +2        WRITE "HIGH RISK MENTAL HEALTH PROACTIVE ADHOC REPORT BY",?70,"PAGE "

           SET SDPAG=SDPAG+1

           WRITE SDPAG,!

 +3        WRITE $SELECT(SDTL="MEN":"MENTAL HEALTH",SDTL="STOP":"STOP CODE",1:"CLINIC")_" for Appointments "_$$FMTE^XLFDT(SDBEG,"2")_"-"_$$FMTE^XLFDT($PIECE(SDEND,".",1),"2"),?56,"Run: "_SDDAT

 +4        IF $DATA(SDTOTPG)

               WRITE !!,"Totals Page"

 +5        IF '$DATA(SDTOTPG)

               WRITE !!,"#",?4,"PATIENT",?25,"PT ID",?32,"APPT D/T",?49,"CLINIC"

 +6        WRITE !,$$LINE(""),!

HEAD1      IF $DATA(^TMP(NAMSPC1,$JOB))

               IF '$DATA(SDTOTPG)

                   Begin DoDot:1

 +1                    NEW SDHEAD2

 +2                    IF SDTL'="STOP"

                           SET SDHEAD2="DIVISION: "_$EXTRACT(SDXDIV,1,30)

 +3                    WRITE SDHEAD2,!

                   End DoDot:1

 +4        QUIT 

 +5       ;

 +6       ;

RANGE()   ;Select Start and End date for report

 +1        WRITE !!,$$LINE(" High Risk Mental Health Proactive Adhoc Report")

 +2        QUIT $$RANGE1(.SDBEG,.SDEND)

 +3       ;

DIV()     ;Division selection for multidivisional facility

 +1        DO ASK2^SDDIV

           IF Y<0

               KILL VAUTD

 +2        QUIT $DATA(VAUTD)>0

 +3       ;

LIST       NEW X

           IF '$DATA(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL"))

               Begin DoDot:1

 +1                IF '$DATA(SDXFLG)

                       WRITE !!!,"Reminder location List file is not current.",!,"Missing reminder location list 'VA-MH NO SHOW APPT CLINICS LL' in file 810.9.",!,"Report Aborting!",!

                       SET Y=1

                       QUIT 

 +2                NEW SDX

                   SET SDX=""

                   SET X=""

 +3                SET SDX=$$SETSTR^SDMHPRO1("Reminder location List file is not current.",X,1,80)

                   DO SET1^SDMHPRO1(SDX)

 +4                SET SDX=""

                   SET X=""

                   SET SDX=$$SETSTR^SDMHPRO1("Missing reminder location list 'VA-MH NO SHOW APPT CLINICS LL' in file 810.9.",X,1,80)

                   DO SET1^SDMHPRO1(SDX)

 +5                SET SDX=""

                   SET X=""

                   SET SDX=$$SETSTR^SDMHPRO1("Report Aborted!",X,1,80)

                   DO SET1^SDMHPRO1(SDX)

 +6                SET SDX=""

 +7                SET Y=1

               End DoDot:1

               QUIT 

LINE(STR) ; Print display prompts

 +1        NEW X

 +2        if STR]""

               SET STR=" "_STR_" "