Routine: HBHCUTL2

HBHCUTL2 ; LR VAMC(IRMS)/MJT-HBHC Utility module, Entry points:  PROV, EN, EN2, TOT, & FTOT (see line labels for called by routines) ; Aug 2000

 ;;1.0;HOSPITAL BASED HOME CARE;**6,16,14,22**;NOV 01, 1993;Build 2

PROV ; Provider variable setup, called by ^HBHCRP4, ^HBHCRP9, ^HBHCRP22

 S HBHCWHO="provider",HBHCWHOS="providers",HBHCWHOC="Provider"

EN ; Entry point called by ^HBHCRP4, ^HBHCRP6, ^HBHCRP9, & ^HBHCRP22

 S HBHCCC=0

 W !!,"Do you wish to include ALL ",HBHCWHOS," on the report" S %=1 D YN^DICN

W !

 I %=0 W !!,"A 'Yes' response will include ALL "_HBHCWHOS_".  A 'No' response will",!,"prompt for an individual "_HBHCWHO_" name." G EN

 I %=2 K DIC S DIC="^HBHC(631.4,",DIC(0)="AEMQ",DIC("A")="Select HBPC "_HBHCWHOC_": ",DIC("S")="I $P(^HBHC(631.4,Y,0),U,7)="""""

ENPRV ; Enter provider prompt

 I %=2 D ^DIC S:+Y>0 HBHCPRVL(+Y)="" G:Y>0 ENPRV

EN2 ; Entry point 2 called by ^HBHCRP6 & ^HBHCRP9

 D START^HBHCUTL

 G:(HBHCBEG1=-1)!(HBHCEND1=-1) EXIT

 S %ZIS="Q" K IOP,ZTIO,ZTSAVE D ^%ZIS G:POP EXIT

 I $D(IO("Q")) S ZTRTN="DQ^HBHCUTL2",ZTDESC="HBPC "_HBHCWHOC_" Census Report",ZTSAVE("HBHC*")="" D ^%ZTLOAD G EXIT

DQ ; De-queue

 U IO

 K ^TMP("HBHC",$J)

 S $P(HBHCY,"-",133)="",$P(HBHCZ,"=",133)="",HBHCTXT="Case Census",HBHCHEAD=HBHCWHOC_" Census",HBHCHDR="W !,""Patient Name"",?28,""Last Four"",?41,""Date"",?51,""Street Address"",?83,""City"",?100,""ZIP Code"",?112,""Phone"""

 S HBHCCOLM=(132-(30+$L(HBHCHEAD))\2) S:HBHCCOLM'>0 HBHCCOLM=1 S (HBHCTOT,HBHCFTOT)=0

 D TODAY^HBHCUTL

LOOP ; Loop thru ^HBHC(631) "AD" (Admission Date) cross-ref to build report for case manager report or thru ^HBHC(632) "C" (Visit Date) for provider report

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

 F  S HBHCDATE=$O(^HBHC(HBHCFILE,HBHCXREF,HBHCDATE)) Q:(HBHCDATE="")!(HBHCDATE>HBHCEND1)  S HBHCDFN="" F  S HBHCDFN=$O(^HBHC(HBHCFILE,HBHCXREF,HBHCDATE,HBHCDFN)) Q:HBHCDFN=""  D PROCESS

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

 I $D(^TMP("HBHC",$J)) D PRTLOOP D:'$D(HBHCPRVL) FTOT

 D END132^HBHCUTL1

EXIT ; Exit module

 D ^%ZISC

 K DIC,DTOUT,DUOUT,HBHCADDT,HBHCBEG1,HBHCBEG2,HBHCC,HBHCCC,HBHCCLM1,HBHCCOLM,HBHCDATE,HBHCDFN,HBHCDPT0,HBHCDPTA,HBHCEND1,HBHCEND2,HBHCFILE,HBHCFTOT,HBHCHDR,HBHCHEAD,HBHCLST4,HBHCNAM,HBHCNBR,HBHCNDX,HBHCNM,HBHCNOD0,HBHCNOD1

 K HBHCPAGE,HBHCPHON,HBHCPRV,HBHCPRVL,HBHCTDY,HBHCTMP,HBHCTOT,HBHCTXT,HBHCWHO,HBHCWHOC,HBHCWHOS,HBHCXREF,HBHCY,HBHCZ,HBHCZIP,X,Y,^TMP("HBHC",$J),%

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

 S HBHCNOD0=^HBHC(HBHCFILE,HBHCDFN,0),HBHCNOD1=$G(^HBHC(HBHCFILE,HBHCDFN,1))

 ; Q if no case manager or not selected case manager

 I HBHCFILE=631 Q:$P(HBHCNOD1,U,13)=""  Q:($D(HBHCPRVL))&('$D(HBHCPRVL($P(HBHCNOD1,U,13))))

 I HBHCFILE=631 Q:(($P(HBHCNOD0,U,40)]"")&($P(HBHCNOD0,U,40)<HBHCEND1))!($P(HBHCNOD0,U,15)=2)!($P(HBHCNOD1,U,13)="")  S HBHCADDT=$E(HBHCDATE,4,5)_"-"_$E(HBHCDATE,6,7)_"-"_$E(HBHCDATE,2,3)

 I HBHCFILE=632 Q:$P(HBHCNOD0,U,4)=""  Q:($D(HBHCPRVL))&('$D(HBHCPRVL($P(HBHCNOD0,U,4))))  ; Q if not selected provider

 I HBHCFILE=632 S (HBHCNBR,HBHCNDX)="" F  S HBHCNBR=$O(^HBHC(631,"B",+HBHCNOD0,HBHCNBR)) Q:HBHCNBR=""  S HBHCNDX=HBHCNBR

 I HBHCFILE=632 Q:HBHCNDX=""  Q:(($P(^HBHC(631,HBHCNDX,0),U,40)]"")&($P(^HBHC(631,HBHCNDX,0),U,40)<HBHCEND1))!($P(^HBHC(631,HBHCNDX,0),U,15)=2)

 I HBHCFILE=632 S HBHCADDT=$P(^HBHC(631,HBHCNDX,0),U,18),HBHCADDT=$E(HBHCADDT,4,5)_"-"_$E(HBHCADDT,6,7)_"-"_$E(HBHCADDT,2,3) Q:$P(HBHCNOD0,U,4)=""

 S HBHCNAM=$S(HBHCFILE=631:$P(^VA(200,$P(^HBHC(631.4,$P(HBHCNOD1,U,13),0),U,2),0),U)_"  ("_$P(^HBHC(631.4,$P(HBHCNOD1,U,13),0),U)_")",1:$P(^VA(200,$P(^HBHC(631.4,$P(HBHCNOD0,U,4),0),U,2),0),U)_"  ("_$P(^HBHC(631.4,$P(HBHCNOD0,U,4),0),U)_")")

 S HBHCDPT0=^DPT($P(HBHCNOD0,U),0),HBHCDPTA=$G(^DPT($P(HBHCNOD0,U),.11))

 S HBHCLST4=$E($P(HBHCDPT0,U,9),6,9),HBHCNM=$E($P(HBHCDPT0,U),1,26)

 S HBHCZIP=$S(($P(HBHCDPTA,U,12)]""):$E($P(HBHCDPTA,U,12),1,5)_$S($E($P(HBHCDPTA,U,12),6,9)]"":"-"_$E($P(HBHCDPTA,U,12),6,9),1:""),1:$E($P(HBHCDPTA,U,6),1,5)_$S($E($P(HBHCDPTA,U,6),6,9)]"":"-"_$E($P(HBHCDPTA,U,6),6,9),1:""))

 S HBHCPHON=$P($G(^DPT($P(HBHCNOD0,U),.13)),U) S:HBHCPHON?7N HBHCPHON=$E(HBHCPHON,1,3)_"-"_$E(HBHCPHON,4,7) S:HBHCPHON?10N HBHCPHON="("_$E(HBHCPHON,1,3)_") "_$E(HBHCPHON,4,6)_"-"_$E(HBHCPHON,7,10)

 S ^TMP("HBHC",$J,HBHCNAM,HBHCNM)=HBHCLST4_U_HBHCADDT_U_$P(HBHCDPTA,U)_U_$P(HBHCDPTA,U,2)_U_$P(HBHCDPTA,U,3)_U_$E($P(HBHCDPTA,U,4),1,15)_U_HBHCZIP_U_HBHCPHON

PRTLOOP ; Print loop

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

HDR ; Report header setup

 S HBHCPAGE=0,HBHCNAM=HBHCPRV,HBHCCLM1=(132-(HBHCC+$L(HBHCNAM))\2) S:HBHCCLM1'>0 HBHCCLM1=1

 W @IOF D HDR132^HBHCUTL

PRT ; Print report

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

 S HBHCTOT=HBHCTOT+1,HBHCTMP=^TMP("HBHC",$J,HBHCPRV,HBHCNM)

 W !,HBHCNM,?28,$P(HBHCTMP,U),?41,$P(HBHCTMP,U,2),?51,$P(HBHCTMP,U,3),?83,$P(HBHCTMP,U,6),?100,$P(HBHCTMP,U,7),?112,$P(HBHCTMP,U,8)

 W:$P(HBHCTMP,U,4)]"" !?51,$P(HBHCTMP,U,4)

 W:$P(HBHCTMP,U,5)]"" !?51,$P(HBHCTMP,U,5)

 W !,HBHCY

TOT ; Print case manager/provider total, called by ^HBHCRP4 & ^HBHCRP22

 W !!,HBHCZ,!,HBHCWHOC_": "_HBHCNAM_"  "_HBHCTXT_" Total:  ",HBHCTOT,!,HBHCZ

 S HBHCFTOT=HBHCFTOT+HBHCTOT,HBHCTOT=0

FTOT ; Print report final total, called by ^HBHCRP4 & ^HBHCRP22

 K HBHCHDR,HBHCNAM S HBHCPAGE=0 W @IOF

 ; for HBHCUTL2 calls (called from HBHCRP6 & HBHCRP9)

 D:$L(HBHCZ)=132 HDR132^HBHCUTL

 ; for HBHCRP4 & HBHCRP22 calls

 D:$L(HBHCZ)=80 HDRRANGE^HBHCUTL

 W !!,HBHCTXT_" Total:  ",HBHCFTOT,!!,HBHCZ

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCUTL2   5719     printed  Feb 18, 2025@23:25:13                                                                                                                                                                                                    Page 2

HBHCUTL2  ; LR VAMC(IRMS)/MJT-HBHC Utility module, Entry points:  PROV, EN, EN2, TOT, & FTOT (see line labels for called by routines) ; Aug 2000

 +1       ;;1.0;HOSPITAL BASED HOME CARE;**6,16,14,22**;NOV 01, 1993;Build 2

PROV      ; Provider variable setup, called by ^HBHCRP4, ^HBHCRP9, ^HBHCRP22

 +1        SET HBHCWHO="provider"

           SET HBHCWHOS="providers"

           SET HBHCWHOC="Provider"

 +2        QUIT

EN        ; Entry point called by ^HBHCRP4, ^HBHCRP6, ^HBHCRP9, & ^HBHCRP22

 +1        SET HBHCCC=0

 +2        WRITE !!,"Do you wish to include ALL ",HBHCWHOS," on the report"

           SET %=1

           DO YN^DICN

 +3        WRITE !

 +4        IF %=0

               WRITE !!,"A 'Yes' response will include ALL "_HBHCWHOS_".  A 'No' response will",!,"prompt for an individual "_HBHCWHO_" name."

               GOTO EN

 +5        IF %=2

               KILL DIC

               SET DIC="^HBHC(631.4,"

               SET DIC(0)="AEMQ"

               SET DIC("A")="Select HBPC "_HBHCWHOC_": "

               SET DIC("S")="I $P(^HBHC(631.4,Y,0),U,7)="""""

ENPRV     ; Enter provider prompt

 +1        IF %=2

               DO ^DIC

               if +Y>0

                   SET HBHCPRVL(+Y)=""

               if Y>0

                   GOTO ENPRV

 +2        QUIT

EN2       ; Entry point 2 called by ^HBHCRP6 & ^HBHCRP9

 +1        DO START^HBHCUTL

 +2        if (HBHCBEG1=-1)!(HBHCEND1=-1)

               GOTO EXIT

 +3        SET %ZIS="Q"

           KILL IOP,ZTIO,ZTSAVE

           DO ^%ZIS

           if POP

               GOTO EXIT

 +4        IF $DATA(IO("Q"))

               SET ZTRTN="DQ^HBHCUTL2"

               SET ZTDESC="HBPC "_HBHCWHOC_" Census 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 HBHCTXT="Case Census"

           SET HBHCHEAD=HBHCWHOC_" Census"

           SET HBHCHDR="W !,""Patient Name"",?28,""Last Four"",?41,""Date"",?51,""Street Address"",?83,""City"",?100,""ZIP Code"",?112,""Phone"""

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

           if HBHCCOLM'>0

               SET HBHCCOLM=1

           SET (HBHCTOT,HBHCFTOT)=0

 +5        DO TODAY^HBHCUTL

LOOP      ; Loop thru ^HBHC(631) "AD" (Admission Date) cross-ref to build report for case manager report or thru ^HBHC(632) "C" (Visit Date) for provider report

 +1        SET X1=HBHCBEG1

           SET X2=-1

           DO C^%DTC

           SET HBHCDATE=X

 +2        FOR

               SET HBHCDATE=$ORDER(^HBHC(HBHCFILE,HBHCXREF,HBHCDATE))

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

                   QUIT

               SET HBHCDFN=""

FOR

                   SET HBHCDFN=$ORDER(^HBHC(HBHCFILE,HBHCXREF,HBHCDATE,HBHCDFN))

                   if HBHCDFN=""

                       QUIT

                   DO PROCESS

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

               KILL HBHCNAM

               DO HDR132^HBHCUTL

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

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

               DO PRTLOOP

               if '$DATA(HBHCPRVL)

                   DO FTOT

 +5        DO END132^HBHCUTL1

EXIT      ; Exit module

 +1        DO ^%ZISC

 +2        KILL DIC,DTOUT,DUOUT,HBHCADDT,HBHCBEG1,HBHCBEG2,HBHCC,HBHCCC,HBHCCLM1,HBHCCOLM,HBHCDATE,HBHCDFN,HBHCDPT0,HBHCDPTA,HBHCEND1,HBHCEND2,HBHCFILE,HBHCFTOT,HBHCHDR,HBHCHEAD,HBHCLST4,HBHCNAM,HBHCNBR,HBHCNDX,HBHCNM,HBHCNOD0,HBHCNOD1

 +3        KILL HBHCPAGE,HBHCPHON,HBHCPRV,HBHCPRVL,HBHCTDY,HBHCTMP,HBHCTOT,HBHCTXT,HBHCWHO,HBHCWHOC,HBHCWHOS,HBHCXREF,HBHCY,HBHCZ,HBHCZIP,X,Y,^TMP("HBHC",$JOB),%

 +4        QUIT

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

 +1        SET HBHCNOD0=^HBHC(HBHCFILE,HBHCDFN,0)

           SET HBHCNOD1=$GET(^HBHC(HBHCFILE,HBHCDFN,1))

 +2       ; Q if no case manager or not selected case manager

 +3        IF HBHCFILE=631

               if $PIECE(HBHCNOD1,U,13)=""

                   QUIT

               if ($DATA(HBHCPRVL))&('$DATA(HBHCPRVL($PIECE(HBHCNOD1,U,13))))

                   QUIT

 +4        IF HBHCFILE=631

               if (($PIECE(HBHCNOD0,U,40)]"")&($PIECE(HBHCNOD0,U,40)<HBHCEND1))!($PIECE(HBHCNOD0,U,15)=2)!($PIECE(HBHCNOD1,U,13)="")

                   QUIT

               SET HBHCADDT=$EXTRACT(HBHCDATE,4,5)_"-"_$EXTRACT(HBHCDATE,6,7)_"-"_$EXTRACT(HBHCDATE,2,3)

 +5       ; Q if not selected provider

           IF HBHCFILE=632

               if $PIECE(HBHCNOD0,U,4)=""

                   QUIT

               if ($DATA(HBHCPRVL))&('$DATA(HBHCPRVL($PIECE(HBHCNOD0,U,4))))

                   QUIT

 +6        IF HBHCFILE=632

               SET (HBHCNBR,HBHCNDX)=""

FOR

                   SET HBHCNBR=$ORDER(^HBHC(631,"B",+HBHCNOD0,HBHCNBR))

                   if HBHCNBR=""

                       QUIT

                   SET HBHCNDX=HBHCNBR

 +7        IF HBHCFILE=632

               if HBHCNDX=""

                   QUIT

               if (($PIECE(^HBHC(631,HBHCNDX,0),U,40)]"")&($PIECE(^HBHC(631,HBHCNDX,0),U,40)<HBHCEND1))!($PIECE(^HBHC(631,HBHCNDX,0),U,15)=2)

                   QUIT

 +8        IF HBHCFILE=632

               SET HBHCADDT=$PIECE(^HBHC(631,HBHCNDX,0),U,18)

               SET HBHCADDT=$EXTRACT(HBHCADDT,4,5)_"-"_$EXTRACT(HBHCADDT,6,7)_"-"_$EXTRACT(HBHCADDT,2,3)

               if $PIECE(HBHCNOD0,U,4)=""

                   QUIT

 +9       SET HBHCNAM=$SELECT(HBHCFILE=631:$PIECE(^VA(200,...

           ... $PIECE(^HBHC(631.4,$PIECE(HBHCNOD1,U,13),0),U,2),0),U)_"  ("_$PIECE(^HBHC(631.4,$PIECE(HBHCNOD1,U,13),0),U)_")",1:$PIECE(^VA(200,$PIECE(^HBHC(631.4,$PIECE(HBHCNOD0,U,4),0),U,2),0),U)_"  ("_$PIECE(^HBHC(631.4,$PIECE(HBHCNOD0,U,4),0),U)_")")

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

           SET HBHCDPTA=$GET(^DPT($PIECE(HBHCNOD0,U),.11))

 +11       SET HBHCLST4=$EXTRACT($PIECE(HBHCDPT0,U,9),6,9)

           SET HBHCNM=$EXTRACT($PIECE(HBHCDPT0,U),1,26)

 +12      SET HBHCZIP=$SELECT(($PIECE(HBHCDPTA,U,12)]""):$EXTRACT($PIECE(HBHCDPTA,U,12),1,5)_$SELECT($EXTRACT(...

           ... $PIECE(HBHCDPTA,U,12),6,9)]"":"-"_$EXTRACT($PIECE(HBHCDPTA,U,12),6,9),1:""),1:$EXTRACT($PIECE(HBHCDPTA,U,6),1,5)_$SELECT($EXTRACT($PIECE(HBHCDPTA,U,6),6,9)]"":"-"_$EXTRACT($PIECE(HBHCDPTA,U,6),6,9),1:""))

 +13       SET HBHCPHON=$PIECE($GET(^DPT($PIECE(HBHCNOD0,U),.13)),U)

           if HBHCPHON?7N

               SET HBHCPHON=$EXTRACT(HBHCPHON,1,3)_"-"_$EXTRACT(HBHCPHON,4,7)

           if HBHCPHON?10N

               SET HBHCPHON="("_$EXTRACT(HBHCPHON,1,3)_") "_$EXTRACT(HBHCPHON,4,6)_"-"_$EXTRACT(HBHCPHON,7,10)

 +14       SET ^TMP("HBHC",$JOB,HBHCNAM,HBHCNM)=HBHCLST4_U_HBHCADDT_U_$PIECE(HBHCDPTA,U)_U_$PIECE(HBHCDPTA,U,2)_U_$PIECE(HBHCDPTA,U,3)_U_$EXTRACT($PIECE(HBHCDPTA,U,4),1,15)_U_HBHCZIP_U_HBHCPHON

 +15       QUIT

PRTLOOP   ; Print loop

 +1        SET HBHCPRV=""

FOR

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

               if HBHCTOT>0

                   DO TOT

               if HBHCPRV=""

                   QUIT

               DO HDR

               SET HBHCNM=""

FOR

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

                   if HBHCNM=""

                       QUIT

                   DO PRT

 +2        QUIT

HDR       ; Report header setup

 +1        SET HBHCPAGE=0

           SET HBHCNAM=HBHCPRV

           SET HBHCCLM1=(132-(HBHCC+$LENGTH(HBHCNAM))\2)

           if HBHCCLM1'>0

               SET HBHCCLM1=1

 +2        WRITE @IOF

           DO HDR132^HBHCUTL

 +3        QUIT

PRT       ; Print report

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

               WRITE @IOF

               DO HDR132^HBHCUTL

 +2        SET HBHCTOT=HBHCTOT+1

           SET HBHCTMP=^TMP("HBHC",$JOB,HBHCPRV,HBHCNM)

 +3        WRITE !,HBHCNM,?28,$PIECE(HBHCTMP,U),?41,$PIECE(HBHCTMP,U,2),?51,$PIECE(HBHCTMP,U,3),?83,$PIECE(HBHCTMP,U,6),?100,$PIECE(HBHCTMP,U,7),?112,$PIECE(HBHCTMP,U,8)

 +4        if $PIECE(HBHCTMP,U,4)]""

               WRITE !?51,$PIECE(HBHCTMP,U,4)

 +5        if $PIECE(HBHCTMP,U,5)]""

               WRITE !?51,$PIECE(HBHCTMP,U,5)

 +6        WRITE !,HBHCY

 +7        QUIT

TOT       ; Print case manager/provider total, called by ^HBHCRP4 & ^HBHCRP22

 +1        WRITE !!,HBHCZ,!,HBHCWHOC_": "_HBHCNAM_"  "_HBHCTXT_" Total:  ",HBHCTOT,!,HBHCZ

 +2        SET HBHCFTOT=HBHCFTOT+HBHCTOT

           SET HBHCTOT=0

 +3        QUIT

FTOT      ; Print report final total, called by ^HBHCRP4 & ^HBHCRP22

 +1        KILL HBHCHDR,HBHCNAM

           SET HBHCPAGE=0

           WRITE @IOF

 +2       ; for HBHCUTL2 calls (called from HBHCRP6 & HBHCRP9)

 +3        if $LENGTH(HBHCZ)=132

               DO HDR132^HBHCUTL

 +4       ; for HBHCRP4 & HBHCRP22 calls

 +5        if $LENGTH(HBHCZ)=80

               DO HDRRANGE^HBHCUTL

 +6        WRITE !!,HBHCTXT_" Total:  ",HBHCFTOT,!!,HBHCZ

 +7        QUIT

HBHCUTL2.m