HBHCRP11.m

HBHCRP11 ; LR VAMC(IRMS)/MJT-HBHC rpt on file 631, All active (admitted but not D/C) cases by date range, sorted by HBHC Team, then by name, includes: patient name, Last Four, admission date, & totals for team & all ; 12/21/05 3:31pm

 ;;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^HBHCRP11",ZTDESC="HBPC Team Census Report",ZTSAVE("HBHC*")="" D ^%ZTLOAD G EXIT

DQ ; De-queue

 U IO

 K ^TMP("HBHC",$J)

 S $P(HBHCY,"-",81)="",(HBHCFTOT,HBHCTOT)=0,HBHCHEAD="Team Census",HBHCHDR="W !,""Patient Name"",?43,""Last Four"",?68,""Date""",HBHCCOLM=(80-(30+$L(HBHCHEAD))\2) S:HBHCCOLM'>0 HBHCCOLM=1

 D TODAY^HBHCUTL

LOOP ; Loop thru ^HBHC(631) "AD" (admission date) cross-ref to build report

 S X1=HBHCBEG1,X2=-1 D C^%DTC S HBHCADDT=X

 F  S HBHCADDT=$O(^HBHC(631,"AD",HBHCADDT)) Q:(HBHCADDT="")!(HBHCADDT>HBHCEND1)  S HBHCDFN="" F  S HBHCDFN=$O(^HBHC(631,"AD",HBHCADDT,HBHCDFN)) Q:HBHCDFN=""  S HBHCNOD0=^HBHC(631,HBHCDFN,0) D:$P(HBHCNOD0,U,15)=1 PROCESS

 I '$D(^TMP("HBHC",$J)) K HBHCNAM D HDRRANGE^HBHCUTL W !!,"No data found for Date Range selected."

 I $D(^TMP("HBHC",$J)) D PRTLOOP W !!,HBHCZ,!,"All Team Census Total: ",HBHCFTOT,!,HBHCZ

 D ENDRPT^HBHCUTL1

EXIT ; Exit module

 D ^%ZISC

 K HBHCADDT,HBHCBEG1,HBHCBEG2,HBHCCLM1,HBHCCC,HBHCCOLM,HBHCDFN,HBHCDPT0,HBHCDT,HBHCEND1,HBHCEND2,HBHCFFFL,HBHCFTOT,HBHCHDR,HBHCHEAD,HBHCN,HBHCNAM,HBHCNOD0,HBHCPAGE,HBHCPT,HBHCTDY,HBHCTOT,HBHCY,HBHCZ,X,X1,X2,Y,^TMP("HBHC",$J)

 Q

PROCESS ; Process record & build ^TMP("HBHC",$J) global

 Q:($P(HBHCNOD0,U,40)]"")&($P(HBHCNOD0,U,40)<HBHCEND1)

 S HBHCNAM=$P($G(^HBHC(631,HBHCDFN,1)),U,13) S:HBHCNAM]"" HBHCNAM=$G(^HBHC(633,$P(^HBHC(631.4,HBHCNAM,0),U,6),0)) S:HBHCNAM="" HBHCNAM="Unknown"

 S HBHCDPT0=^DPT($P(HBHCNOD0,U),0)

 S ^TMP("HBHC",$J,HBHCNAM,$P(HBHCDPT0,U),HBHCADDT)=$E($P(HBHCDPT0,U,9),6,9)

 Q

PRTLOOP ; Print loop

 S HBHCNAM=""

 F  S HBHCNAM=$O(^TMP("HBHC",$J,HBHCNAM)) D:HBHCTOT>0 TOT Q:HBHCNAM=""  D HDR S HBHCPT="" F  S HBHCPT=$O(^TMP("HBHC",$J,HBHCNAM,HBHCPT)) Q:HBHCPT=""   S HBHCDT="" F  S HBHCDT=$O(^TMP("HBHC",$J,HBHCNAM,HBHCPT,HBHCDT)) Q:HBHCDT=""  D PRT

 Q

HDR ; Print header

 S HBHCN=HBHCNAM,HBHCCLM1=(80-(22+$L(HBHCNAM))\2) S:HBHCCLM1'>0 HBHCCLM1=1 W:$D(HBHCFFFL) @IOF

 D:IO'=IO(0)!($D(IO("S"))) HDRRANGE^HBHCUTL

 I '$D(IO("S")),(IO=IO(0)) S HBHCCC=HBHCCC+1 D HDRRANGE^HBHCUTL

 S:'$D(HBHCFFFL) HBHCFFFL=1

 Q

PRT ; Print report

 I ($D(ZTRTN)!(HBHCCC=0))&((IOSL-$Y)<5) W @IOF D HDRRANGE^HBHCUTL

 S HBHCTOT=HBHCTOT+1,Y=HBHCDT D DD^%DT

 W !,HBHCPT,?43,^TMP("HBHC",$J,HBHCNAM,HBHCPT,HBHCDT),?68,Y,!,HBHCY

 Q

TOT ; Print HBHC team total

 W !!,"Team: "_HBHCN_"   Census Total: ",HBHCTOT

 S HBHCFTOT=HBHCFTOT+HBHCTOT,HBHCTOT=0

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---HBHCRP11   2818     printed  Apr 23, 2025@18:12:46                                                                                                                                                                                                    Page 2

HBHCRP11  ; LR VAMC(IRMS)/MJT-HBHC rpt on file 631, All active (admitted but not D/C) cases by date range, sorted by HBHC Team, then by name, includes: patient name, Last Four, admission date, & totals for team & all ; 12/21/05 3:31pm

 +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^HBHCRP11"

               SET ZTDESC="HBPC Team Census Report"

               SET ZTSAVE("HBHC*")=""

               DO ^%ZTLOAD

               GOTO EXIT

DQ        ; De-queue

 +1        USE IO

 +2        KILL ^TMP("HBHC",$JOB)

 +3        SET $PIECE(HBHCY,"-",81)=""

           SET (HBHCFTOT,HBHCTOT)=0

           SET HBHCHEAD="Team Census"

           SET HBHCHDR="W !,""Patient Name"",?43,""Last Four"",?68,""Date"""

           SET HBHCCOLM=(80-(30+$LENGTH(HBHCHEAD))\2)

           if HBHCCOLM'>0

               SET HBHCCOLM=1

 +4        DO TODAY^HBHCUTL

LOOP      ; Loop thru ^HBHC(631) "AD" (admission date) cross-ref to build report

 +1        SET X1=HBHCBEG1

           SET X2=-1

           DO C^%DTC

           SET HBHCADDT=X

 +2        FOR 

               SET HBHCADDT=$ORDER(^HBHC(631,"AD",HBHCADDT))

               if (HBHCADDT="")!(HBHCADDT>HBHCEND1)

                   QUIT 

               SET HBHCDFN=""

               FOR 

                   SET HBHCDFN=$ORDER(^HBHC(631,"AD",HBHCADDT,HBHCDFN))

                   if HBHCDFN=""

                       QUIT 

                   SET HBHCNOD0=^HBHC(631,HBHCDFN,0)

                   if $PIECE(HBHCNOD0,U,15)=1

                       DO PROCESS

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

               KILL HBHCNAM

               DO HDRRANGE^HBHCUTL

               WRITE !!,"No data found for Date Range selected."

 +4        IF $DATA(^TMP("HBHC",$JOB))

               DO PRTLOOP

               WRITE !!,HBHCZ,!,"All Team Census Total: ",HBHCFTOT,!,HBHCZ

 +5        DO ENDRPT^HBHCUTL1

EXIT      ; Exit module

 +1        DO ^%ZISC

 +2        KILL HBHCADDT,HBHCBEG1,HBHCBEG2,HBHCCLM1,HBHCCC,HBHCCOLM,HBHCDFN,HBHCDPT0,HBHCDT,HBHCEND1,HBHCEND2,HBHCFFFL,HBHCFTOT,HBHCHDR,HBHCHEAD,HBHCN,HBHCNAM,HBHCNOD0,HBHCPAGE,HBHCPT,HBHCTDY,HBHCTOT,HBHCY,HBHCZ,X,X1,X2,Y,^TMP("HBHC",$JOB)

 +3        QUIT 

PROCESS   ; Process record & build ^TMP("HBHC",$J) global

 +1        if ($PIECE(HBHCNOD0,U,40)]"")&($PIECE(HBHCNOD0,U,40)<HBHCEND1)

               QUIT 

 +2        SET HBHCNAM=$PIECE($GET(^HBHC(631,HBHCDFN,1)),U,13)

           if HBHCNAM]""

               SET HBHCNAM=$GET(^HBHC(633,$PIECE(^HBHC(631.4,HBHCNAM,0),U,6),0))

           if HBHCNAM=""

               SET HBHCNAM="Unknown"

 +3        SET HBHCDPT0=^DPT($PIECE(HBHCNOD0,U),0)

 +4        SET ^TMP("HBHC",$JOB,HBHCNAM,$PIECE(HBHCDPT0,U),HBHCADDT)=$EXTRACT($PIECE(HBHCDPT0,U,9),6,9)

 +5        QUIT 

PRTLOOP   ; Print loop

 +1        SET HBHCNAM=""

 +2        FOR 

               SET HBHCNAM=$ORDER(^TMP("HBHC",$JOB,HBHCNAM))

               if HBHCTOT>0

                   DO TOT

               if HBHCNAM=""

                   QUIT 

               DO HDR

               SET HBHCPT=""

               FOR 

                   SET HBHCPT=$ORDER(^TMP("HBHC",$JOB,HBHCNAM,HBHCPT))

                   if HBHCPT=""

                       QUIT 

                   SET HBHCDT=""

                   FOR 

                       SET HBHCDT=$ORDER(^TMP("HBHC",$JOB,HBHCNAM,HBHCPT,HBHCDT))

                       if HBHCDT=""

                           QUIT 

                       DO PRT

 +3        QUIT 

HDR       ; Print header

 +1        SET HBHCN=HBHCNAM

           SET HBHCCLM1=(80-(22+$LENGTH(HBHCNAM))\2)

           if HBHCCLM1'>0

               SET HBHCCLM1=1

           if $DATA(HBHCFFFL)

               WRITE @IOF

 +2        if IO'=IO(0)!($DATA(IO("S")))

               DO HDRRANGE^HBHCUTL

 +3        IF '$DATA(IO("S"))

               IF (IO=IO(0))

                   SET HBHCCC=HBHCCC+1

                   DO HDRRANGE^HBHCUTL

 +4        if '$DATA(HBHCFFFL)

               SET HBHCFFFL=1

 +5        QUIT 

PRT       ; Print report

 +1        IF ($DATA(ZTRTN)!(HBHCCC=0))&((IOSL-$Y)<5)

               WRITE @IOF

               DO HDRRANGE^HBHCUTL

 +2        SET HBHCTOT=HBHCTOT+1

           SET Y=HBHCDT

           DO DD^%DT

 +3        WRITE !,HBHCPT,?43,^TMP("HBHC",$JOB,HBHCNAM,HBHCPT,HBHCDT),?68,Y,!,HBHCY

 +4        QUIT 

TOT       ; Print HBHC team total

 +1        WRITE !!,"Team: "_HBHCN_"   Census Total: ",HBHCTOT

 +2        SET HBHCFTOT=HBHCFTOT+HBHCTOT

           SET HBHCTOT=0

 +3        QUIT