Routine: HBHCRP16

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)

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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCRP16   2821     printed  Apr 23, 2025@18:12:49                                                                                                                                                                                                    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

HBHCRP16.m