HBHCRP16 ; LR VAMC(IRMS)/MJT-HBHC report on file 631, Admit/Reject Action field=Reject for date range, sorted by name, includes: patient name, Last Four, & evaluation date ; 12/21/05 3:30pm
;;1.0;HOSPITAL BASED HOME CARE;**6,22**;NOV 01, 1993;Build 2
D START^HBHCUTL
G:(HBHCBEG1=-1)!(HBHCEND1=-1) EXIT
S %ZIS="Q",HBHCCC=0 K IOP,ZTIO,ZTSAVE D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="DQ^HBHCRP16",ZTDESC="HBPC Rejections from Program Report",ZTSAVE("HBHC*")="" D ^%ZTLOAD G EXIT
DQ ; De-queue
U IO
K ^TMP("HBHC",$J)
S $P(HBHCY,"-",133)="",$P(HBHCZ,"=",133)="",HBHCHEAD="Rejections from Program",HBHCHDR="W !,""Patient Name"",?37,""Last Four"",?55,""Date"",?70,""Reject/Withdraw Reason""",HBHCCOLM=(132-(30+$L(HBHCHEAD))\2) S:HBHCCOLM'>0 HBHCCOLM=1
D TODAY^HBHCUTL D:IO'=IO(0)!($D(IO("S"))) HDR132^HBHCUTL
I '$D(IO("S")),(IO=IO(0)) S HBHCCC=HBHCCC+1 D HDR132^HBHCUTL
LOOP ; Loop thru ^HBHC(631,"AI") evaluation date cross-ref to build report, rejects will only contain evaluation date data until HBHC/PCE patch installed
S X1=HBHCBEG1,X2=-1 D C^%DTC S (HBHCDAT,HBHCDATE)=X
F S HBHCDATE=$O(^HBHC(631,"AI",HBHCDATE)) Q:(HBHCDATE="")!(HBHCDATE>HBHCEND1) S HBHCDFN="" F S HBHCDFN=$O(^HBHC(631,"AI",HBHCDATE,HBHCDFN)) Q:HBHCDFN="" D PROCESS
; Loop thru ^HBHC(631,"AD") Date cross-ref to build report, after HBHC/PCE patch installed, only Date (formerly Admission Date) will contain data
S HBHCDATE=HBHCDAT F S HBHCDATE=$O(^HBHC(631,"AD",HBHCDATE)) Q:(HBHCDATE="")!(HBHCDATE>HBHCEND1) S HBHCDFN="" F S HBHCDFN=$O(^HBHC(631,"AD",HBHCDATE,HBHCDFN)) Q:HBHCDFN="" D PROCESS
I $D(^TMP("HBHC",$J)) D PRTLOOP W !!,HBHCZ,!,"Program Rejections Total: ",HBHCTOT,!,HBHCZ
D END132^HBHCUTL1
EXIT ; Exit module
D ^%ZISC
K HBHCBEG1,HBHCBEG2,HBHCCC,HBHCCOLM,HBHCDAT,HBHCDATE,HBHCDFN,HBHCDPT0,HBHCEND1,HBHCEND2,HBHCHDR,HBHCHEAD,HBHCNAME,HBHCNOD0,HBHCPAGE,HBHCREJ,HBHCTDY,HBHCTMP,HBHCTOT,HBHCY,HBHCZ,X,X1,X2,Y,^TMP("HBHC",$J)
Q
PROCESS ; Process record & build ^TMP("HBHC",$J) global
S HBHCNOD0=^HBHC(631,HBHCDFN,0)
; Q:Admit/Reject Action field=Admit or is null
Q:($P(HBHCNOD0,U,15)=1)!($P(HBHCNOD0,U,15)="")
S HBHCDPT0=^DPT($P(HBHCNOD0,U),0),HBHCREJ=$S($P(HBHCNOD0,U,16)]"":$P(^HBHC(631.1,$P(HBHCNOD0,U,16),0),U,2),1:"")
S ^TMP("HBHC",$J,$P(HBHCDPT0,U),HBHCDATE)=$E($P(HBHCDPT0,U,9),6,9)_U_HBHCREJ
Q
PRTLOOP ; Print loop
S HBHCTOT=0
S HBHCNAME="" F S HBHCNAME=$O(^TMP("HBHC",$J,HBHCNAME)) Q:HBHCNAME="" S HBHCDATE="" F S HBHCDATE=$O(^TMP("HBHC",$J,HBHCNAME,HBHCDATE)) Q:HBHCDATE="" D PRINT
Q
PRINT ; Print report
I ($D(ZTRTN)!(HBHCCC=0))&((IOSL-$Y)<5) W @IOF D HDR132^HBHCUTL
S HBHCTMP=^TMP("HBHC",$J,HBHCNAME,HBHCDATE),HBHCTOT=HBHCTOT+1
W !,HBHCNAME,?37,$P(HBHCTMP,U),?55,$E(HBHCDATE,4,5)_"-"_$E(HBHCDATE,6,7)_"-"_$E(HBHCDATE,2,3),?70,$P(HBHCTMP,U,2),!,HBHCY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCRP16 2821 printed Dec 13, 2024@01:58:19 Page 2
HBHCRP16 ; LR VAMC(IRMS)/MJT-HBHC report on file 631, Admit/Reject Action field=Reject for date range, sorted by name, includes: patient name, Last Four, & evaluation date ; 12/21/05 3:30pm
+1 ;;1.0;HOSPITAL BASED HOME CARE;**6,22**;NOV 01, 1993;Build 2
+2 DO START^HBHCUTL
+3 if (HBHCBEG1=-1)!(HBHCEND1=-1)
GOTO EXIT
+4 SET %ZIS="Q"
SET HBHCCC=0
KILL IOP,ZTIO,ZTSAVE
DO ^%ZIS
if POP
GOTO EXIT
+5 IF $DATA(IO("Q"))
SET ZTRTN="DQ^HBHCRP16"
SET ZTDESC="HBPC Rejections from Program Report"
SET ZTSAVE("HBHC*")=""
DO ^%ZTLOAD
GOTO EXIT
DQ ; De-queue
+1 USE IO
+2 KILL ^TMP("HBHC",$JOB)
+3 SET $PIECE(HBHCY,"-",133)=""
SET $PIECE(HBHCZ,"=",133)=""
SET HBHCHEAD="Rejections from Program"
SET HBHCHDR="W !,""Patient Name"",?37,""Last Four"",?55,""Date"",?70,""Reject/Withdraw Reason"""
SET HBHCCOLM=(132-(30+$LENGTH(HBHCHEAD))\2)
if HBHCCOLM'>0
SET HBHCCOLM=1
+4 DO TODAY^HBHCUTL
if IO'=IO(0)!($DATA(IO("S")))
DO HDR132^HBHCUTL
+5 IF '$DATA(IO("S"))
IF (IO=IO(0))
SET HBHCCC=HBHCCC+1
DO HDR132^HBHCUTL
LOOP ; Loop thru ^HBHC(631,"AI") evaluation date cross-ref to build report, rejects will only contain evaluation date data until HBHC/PCE patch installed
+1 SET X1=HBHCBEG1
SET X2=-1
DO C^%DTC
SET (HBHCDAT,HBHCDATE)=X
+2 FOR
SET HBHCDATE=$ORDER(^HBHC(631,"AI",HBHCDATE))
if (HBHCDATE="")!(HBHCDATE>HBHCEND1)
QUIT
SET HBHCDFN=""
FOR
SET HBHCDFN=$ORDER(^HBHC(631,"AI",HBHCDATE,HBHCDFN))
if HBHCDFN=""
QUIT
DO PROCESS
+3 ; Loop thru ^HBHC(631,"AD") Date cross-ref to build report, after HBHC/PCE patch installed, only Date (formerly Admission Date) will contain data
+4 SET HBHCDATE=HBHCDAT
FOR
SET HBHCDATE=$ORDER(^HBHC(631,"AD",HBHCDATE))
if (HBHCDATE="")!(HBHCDATE>HBHCEND1)
QUIT
SET HBHCDFN=""
FOR
SET HBHCDFN=$ORDER(^HBHC(631,"AD",HBHCDATE,HBHCDFN))
if HBHCDFN=""
QUIT
DO PROCESS
+5 IF $DATA(^TMP("HBHC",$JOB))
DO PRTLOOP
WRITE !!,HBHCZ,!,"Program Rejections Total: ",HBHCTOT,!,HBHCZ
+6 DO END132^HBHCUTL1
EXIT ; Exit module
+1 DO ^%ZISC
+2 KILL HBHCBEG1,HBHCBEG2,HBHCCC,HBHCCOLM,HBHCDAT,HBHCDATE,HBHCDFN,HBHCDPT0,HBHCEND1,HBHCEND2,HBHCHDR,HBHCHEAD,HBHCNAME,HBHCNOD0,HBHCPAGE,HBHCREJ,HBHCTDY,HBHCTMP,HBHCTOT,HBHCY,HBHCZ,X,X1,X2,Y,^TMP("HBHC",$JOB)
+3 QUIT
PROCESS ; Process record & build ^TMP("HBHC",$J) global
+1 SET HBHCNOD0=^HBHC(631,HBHCDFN,0)
+2 ; Q:Admit/Reject Action field=Admit or is null
+3 if ($PIECE(HBHCNOD0,U,15)=1)!($PIECE(HBHCNOD0,U,15)="")
QUIT
+4 SET HBHCDPT0=^DPT($PIECE(HBHCNOD0,U),0)
SET HBHCREJ=$SELECT($PIECE(HBHCNOD0,U,16)]"":$PIECE(^HBHC(631.1,$PIECE(HBHCNOD0,U,16),0),U,2),1:"")
+5 SET ^TMP("HBHC",$JOB,$PIECE(HBHCDPT0,U),HBHCDATE)=$EXTRACT($PIECE(HBHCDPT0,U,9),6,9)_U_HBHCREJ
+6 QUIT
PRTLOOP ; Print loop
+1 SET HBHCTOT=0
+2 SET HBHCNAME=""
FOR
SET HBHCNAME=$ORDER(^TMP("HBHC",$JOB,HBHCNAME))
if HBHCNAME=""
QUIT
SET HBHCDATE=""
FOR
SET HBHCDATE=$ORDER(^TMP("HBHC",$JOB,HBHCNAME,HBHCDATE))
if HBHCDATE=""
QUIT
DO PRINT
+3 QUIT
PRINT ; Print report
+1 IF ($DATA(ZTRTN)!(HBHCCC=0))&((IOSL-$Y)<5)
WRITE @IOF
DO HDR132^HBHCUTL
+2 SET HBHCTMP=^TMP("HBHC",$JOB,HBHCNAME,HBHCDATE)
SET HBHCTOT=HBHCTOT+1
+3 WRITE !,HBHCNAME,?37,$PIECE(HBHCTMP,U),?55,$EXTRACT(HBHCDATE,4,5)_"-"_$EXTRACT(HBHCDATE,6,7)_"-"_$EXTRACT(HBHCDATE,2,3),?70,$PIECE(HBHCTMP,U,2),!,HBHCY
+4 QUIT
