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 ---[H[J[2J[HSDMHAP 10846 printed Oct 16, 2024@18:59:01 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_" "
+3 SET $PIECE(X,"*",(IOM/2)-($LENGTH(STR)/2))=""
+4 QUIT X_STR_X
+5 ;
LINE1(STR) ; Print display prompts
+1 NEW X
+2 if STR]""
SET STR=" "_STR_" "
+3 SET $PIECE(X," ",(IOM/2)-($LENGTH(STR)/2))=""
+4 QUIT X_STR_X
+5 ;
+6 ;
TOTAL(DIV) ;INITIALIZE total(DIV,CLIN/STOP)
+1 IF '$DATA(TOTAL(DIV))
Begin DoDot:1
+2 NEW SDCNTT
SET SDCNTT=0
+3 SET TOTAL(DIV)="0^0^0^0^0"
End DoDot:1
+4 IF $DATA(TOTAL(DIV))
Begin DoDot:1
+5 SET $PIECE(TOTAL(DIV),"^",1)=$PIECE($GET(TOTAL(DIV)),"^",1)+1
+6 NEW X
SET X=$SELECT(SDSTAT="NS":2,SDSTAT="NSA":3,1:4)
SET $PIECE(TOTAL(DIV),"^",X)=$PIECE(TOTAL(DIV),"^",X)+1
+7 IF '$DATA(SDPAT(DIV,DFN))
SET SDPAT(DIV,DFN)=""
SET $PIECE(TOTAL(DIV),"^",5)=$PIECE(TOTAL(DIV),"^",5)+1
End DoDot:1
+8 QUIT
+9 ;
+10 ;
CLIN ;select clinics
+1 WRITE !!,"Sort the report by:",!,?20,"A All clinics",!,?20,"M Mental Health clinics only",!
+2 READ !,"Sort by: (A)ll clinics A//",X:DTIME
if X["^"!('$TEST)
SET Y=-1
if Y=-1
QUIT
SET X=$SELECT(X="":"A",1:$EXTRACT(X))
IF "AMam"'[X
WRITE !,"Enter a 'A' for All clinics or 'M' for Mental Health clinics only"
GOTO CLIN
+3 SET SDALL=X
+4 NEW DIC,K,VAUTVB,VAUTSTR,VAUTNI
+5 SET VAUTVB="VAUTCL"
SET DIC="^SC("
+6 IF SDALL="M"
SET 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))"
+7 SET VAUTSTR="Clinic"
SET VAUTNI=2
DO FIRST^VAUTOMA
if Y=-1
SET SDFL=1
if $DATA(SDFL)
QUIT
+8 QUIT
+9 ;
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 ;
RANGE1(SDBEG,SDEND,SDAMETH) ; -- select range
+1 NEW SDWITCH,SDT,X1,X2,X
+2 SET (SDBEG,SDEND)=0
SET SDT=DT
+3 IF $GET(SDAMETH)>0
SET X1=DT
SET X2=-1
DO C^%DTC
SET SDT=X
+4 SET DIR("B")=$$FDATE^VALM1(SDT)
SET SDWITCH=$$SWITCH^SDAMU
+5 SET DIR("?",1)="Dates in the past (after "_$$FDATE^VALM1(SDWITCH)_" ) and into the future can be entered"
SET DIR("?")=" "
+6 SET DIR(0)="DA"
SET DIR("A")="Select Beginning Date: "
+7 WRITE !
DO ^DIR
KILL DIR
if Y'>0
GOTO RANGEQ
SET SDBEG=Y
+8 SET DIR("B")=$$FDATE^VALM1(SDT)
+9 SET DIR(0)="DA"
SET DIR("A")="Select Ending Date: "
+10 SET DIR("?",1)="Dates between "_$$FDATE^VALM1(SDBEG)_"and into the future can be entered. "
SET DIR("?")=" "
+11 DO ^DIR
KILL DIR
if Y'>0
GOTO RANGEQ
SET SDEND=Y_".24"
RANGEQ QUIT SDEND
+1 ;
NAMSPC() ; API returns the name space for this patch
+1 QUIT "SDPRO"
NAMSPC1() ; API returns the name space for this patch
+1 QUIT "SDPRO1"
PXRMD ;Set up Reminder Location List valid Stop Codes for Proactive Report
+1 NEW SDX,SDY,SDI,SDSFL,SDCFL
+2 SET SDY=0
+3 SET SDX=$ORDER(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL",0))
if SDX']""
QUIT
FOR
SET SDY=$ORDER(^PXRMD(810.9,SDX,40.7,"B",SDY))
if SDY']""
QUIT
Begin DoDot:1
+4 SET SDSTOP(+SDY)=""
+5 IF SDTL="MEN"
NEW SDI
SET SDI=0
FOR
SET SDI=$ORDER(^SC("AST",+SDY,SDI))
if SDI']""
QUIT
SET VAUTRR(+$PIECE($GET(^SC(+SDI,0)),"^",15),+SDY,+SDI)=""
+6 IF $DATA(VAUTSC)
IF $GET(VAUTSC)=1
SET VAUTSC(+SDY)=$PIECE($GET(^DIC(40.7,+SDY,0)),"^",1)
SET SDSFL=1
+7 IF $DATA(VAUTCL)
IF $GET(VAUTCL)=1
NEW SDI
SET SDI=0
FOR
SET SDI=$ORDER(^SC("AST",+SDY,SDI))
if SDI']""
QUIT
Begin DoDot:2
+8 SET VAUTCL(+SDI)=$PIECE($GET(^SC(+SDI,0)),"^",1)
SET SDCFL=1
End DoDot:2
End DoDot:1
+9 IF $DATA(SDSFL)
SET VAUTSC=0
+10 IF $DATA(SDCFL)
SET VAUTCL=0
+11 QUIT
END ;NO RECORDS
+1 DO HEAD
+2 WRITE !!,$$LINE1(">>>>>> NO RECORDS FOUND <<<<<<")
QUIT KILL %DT,DIR,SDTBEG,SDTEND,SDDIV,SDFL,SDTOTPG,SDXDIV,SDMHNFLG,VAUTD,VAUTCL,VAUTR,VAUTSC,VADAT,VADATE,POP,X,Y
+1 KILL ^TMP("SDPRO",$JOB),^TMP("SDPRO1",$JOB)
+2 DO CLOSE^DGUTQ
QUIT
