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"
Q
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
Q
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),%
Q
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
Q
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
Q
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
Q
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
Q
TOT ; Print case manager/provider total, called by ^HBHCRP4 & ^HBHCRP22
W !!,HBHCZ,!,HBHCWHOC_": "_HBHCNAM_" "_HBHCTXT_" Total: ",HBHCTOT,!,HBHCZ
S HBHCFTOT=HBHCFTOT+HBHCTOT,HBHCTOT=0
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCUTL2 5719 printed Dec 13, 2024@01:58:50 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
