HBHCUTL ;LR VAMC(IRMS)/MJT - HBHC Utility module, Entry points: ACTION, STATUS, START, TODAY, HDRPAGE, HDRRANGE, HDR132, HDR132NR, HDRXPAGE ;Mar 2000
;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,16,24,25**;NOV 01, 1993;Build 45
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;HBH*1.0*25 APR 2012 K GUPTA Support for ICD-10 Coding System
;******************************************************************************
;******************************************************************************
;
ACTION ; Set appropriate fields/variables for Admit/Reject Action
K HBHCQ,HBHCKEEP
S HBHCY0=^HBHC(631,HBHCDFN,0)
S:X="" Y=$S($D(HBHCUPD):0,1:87) S:X=1 Y="@2" S:X=2 HBHCQ=1 ;changed to placeholder @2 from field 18
S HBHCAFLG=0 F HBHCI=19:1:37 Q:HBHCAFLG S:$P(HBHCY0,U,HBHCI)]"" HBHCAFLG=1
S HBHCRFLG=0 I ($P(HBHCY0,U,16)]"")!($P(HBHCY0,U,17)]"") S HBHCRFLG=1
Q:(HBHCAFLG=0)&(HBHCRFLG=0)
Q:(HBHCRFLG=0)&(X=1)
Q:(HBHCAFLG=0)&(X=2)
S HBHCWRD1=$S(HBHCAFLG=1:"admission",1:"rejection")
S HBHCWRD2=$S(X="":"to 'Delete'",X=2:"'Reject' in",1:"'Admit' in")
S HBHCWRD3=$S(HBHCAFLG=1:"1 for Admit",1:"2 for Reject")
D PROCADM I %=1 D:HBHCAFLG ADMIT S:HBHCRFLG $P(^HBHC(631,HBHCDFN,0),U,16)="",$P(^HBHC(631,HBHCDFN,0),U,17)=""
Q
PROCADM ; Process 'Delete' & 'Reject' responses
W $C(7),!!,"This record contains ",HBHCWRD1," data. Are you sure you want ",HBHCWRD2," the",!,"Admit/Reject Action field ('Yes' will delete the ",HBHCWRD1," data)" S %=2 D YN^DICN
W ! W:%=0 !!,"Admit/Reject Action field must either contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
I %'=1 S Y=$S($D(HBHCUPD):0,1:14) S:$D(HBHCUPD) HBHCKEEP=1
Q
ADMIT ; Set appropriate fields = null
F HBHCJ=19:1:37 S $P(^HBHC(631,HBHCDFN,0),U,HBHCJ)=""
S $P(^HBHC(631,HBHCDFN,1),U,14)=""
Q
STATUS ; Set appropriate fields/variables for Discharge Status
K HBHCQ,HBHCQ1,HBHCKEEP
S HBHC12="^1^2^",HBHC359="^3^5^9^",HBHCNOD1=$G(^HBHC(631,HBHCDFN,1)),HBHCY0=^HBHC(631,HBHCDFN,0)
S:X="" Y=$S($D(HBHCUPD):0,1:65) S:HBHC12[(U_X_U) HBHCQ1=1,Y=44 S:HBHC359[(U_X_U) Y="@1" S:X=4 HBHCQ=1,Y=$S($D(HBHCUPD):0,1:69)
S HBHCTFLG=0 S:($P(HBHCY0,U,45)]"")!($P(HBHCY0,U,46)]"") HBHCTFLG=1
S HBHCDIED=0 S:$P($G(^HBHC(631,HBHCDFN,1)),U,15)]"" HBHCDIED=1
S HBHCDFLG=0 F HBHCL=47:1:55 Q:HBHCDFLG S:$P(HBHCY0,U,HBHCL)]"" HBHCDFLG=1
I HBHCNOD1]"" F HBHCM=1:1:10 Q:HBHCDFLG S:$P(HBHCNOD1,U,HBHCM)]"" HBHCDFLG=1
Q:(HBHCTFLG=0)&(HBHCDIED=0)&(HBHCDFLG=0)
Q:(HBHC12[(U_X_U))&(HBHCDIED=0)
Q:(X=4)&(HBHCTFLG=0)&(HBHCDFLG=0)
Q:(HBHC359[(U_X_U))&(HBHCTFLG=0)&(HBHCDIED=0)
S HBHCWRD1=$S(HBHCTFLG:"transfer",HBHCDIED:"deceased",1:"discharge")
S HBHCWRD2=$S(X="":"to 'Delete'",HBHC12[(U_X_U):"'Transfer' in",X=4:"'Died' in",1:"'Discharge' in")
S HBHCWRD3=$S(HBHCTFLG:"1 or 2 for Transfer",HBHCDIED:"4 for Died on HBHC",1:"3, 5 or 9 for Discharge")
D PROCDIS Q:%'=1
S:HBHCTFLG $P(^HBHC(631,HBHCDFN,0),U,45)="",$P(^HBHC(631,HBHCDFN,0),U,46)=""
D:(HBHCDFLG)&((X=4)!(X="")) DISCHRG
S:HBHCDIED $P(^HBHC(631,HBHCDFN,1),U,15)=""
Q
PROCDIS ; Process 'Delete', '1 or 2', '4', & '3 or 5 or 9' responses
W $C(7),!!,"This record contains ",HBHCWRD1," data. Are you sure you want ",HBHCWRD2," the",!,"Discharge Status field ('Yes' will delete the ",HBHCWRD1," data)" S %=2 D YN^DICN
W ! W:%=0 !!,"Discharge Status field must contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
I %'=1 S Y=$S($D(HBHCUPD):0,1:43) S:$D(HBHCUPD) HBHCKEEP=1
Q
DISCHRG ; Delete discharge data
F HBHCI=47:1:55 S $P(^HBHC(631,HBHCDFN,0),U,HBHCI)=""
F HBHCJ=1:1:10 S $P(^HBHC(631,HBHCDFN,1),U,HBHCJ)=""
S $P(^HBHC(631,HBHCDFN,1),U,16)=""
Q
START ; Prompt for beginning/ending report dates
W ! K %DT S (HBHCBEG1,HBHCEND1,HBHCPAGE)=0,%DT("A")="Beginning Report Date: ",%DT="AEX" D ^%DT S HBHCBEG1=Y Q:HBHCBEG1=-1 D DD^%DT S HBHCBEG2=Y
END ; Ending date prompt
S %DT("A")="Ending Report Date: " D ^%DT I (Y>0)&(Y<HBHCBEG1) W $C(7),!!,"Ending Report Date must be closer to today than the Beginning Report Date",! G END
S HBHCEND1=Y_.9999 Q:HBHCEND1=-1 D DD^%DT S HBHCEND2=Y
TODAY ; Obtain current date
S $P(HBHCZ,"=",81)=""
K %DT S X="T" D ^%DT,DD^%DT S HBHCTDY=Y K %DT
Q
HDRPAGE ; Print header with Page
S HBHCPAGE=HBHCPAGE+1
W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!!,"Run Date: ",HBHCTDY,!! I $D(HBHCHDR) X HBHCHDR W !
W HBHCZ
Q
HDRRANGE ; Print header with Date Range
S HBHCPAGE=HBHCPAGE+1
W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,! W:$D(HBHCNAM) ?HBHCCLM1,$S($D(HBHCONE):"Provider: ",1:"HBPC Team: "),HBHCNAM,! W !,"Run Date: ",HBHCTDY,?53,"Date Range: ",HBHCBEG2," to",!?65,HBHCEND2,!
I $D(HBHCHDR) X HBHCHDR W !
W HBHCZ
Q
HDR132 ; Print 132 column header with Date Range
S HBHCPAGE=HBHCPAGE+1
W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?123,"Page: ",HBHCPAGE,! W:$D(HBHCNAM) ?HBHCCLM1,HBHCWHOC_": ",HBHCNAM,! W !,"Run Date: ",HBHCTDY,?105,"Date Range: ",HBHCBEG2," to",!?117,HBHCEND2,! I $D(HBHCHDR) X HBHCHDR W !
W HBHCZ
Q
HDR132NR ; Print 132 column header with No Date Range
S HBHCPAGE=HBHCPAGE+1
W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?123,"Page: ",HBHCPAGE,! W !,"Run Date: ",HBHCTDY I $D(HBHCHDR) X HBHCHDR W !
W HBHCZ
Q
HDRXPAGE ; Print header with Page & xtra info
S HBHCPAGE=HBHCPAGE+1
W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!! I $D(HBHCHDRX) X HBHCHDRX W !!,"Run Date: ",HBHCTDY,! I $D(HBHCHDR) X HBHCHDR W !
W HBHCZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCUTL 5894 printed Sep 23, 2025@19:34:51 Page 2
HBHCUTL ;LR VAMC(IRMS)/MJT - HBHC Utility module, Entry points: ACTION, STATUS, START, TODAY, HDRPAGE, HDRRANGE, HDR132, HDR132NR, HDRXPAGE ;Mar 2000
+1 ;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,16,24,25**;NOV 01, 1993;Build 45
+2 ;******************************************************************************
+3 ;******************************************************************************
+4 ; --- ROUTINE MODIFICATION LOG ---
+5 ;
+6 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+7 ;----------- ---------- ----------- ----------------------------------------
+8 ;HBH*1.0*25 APR 2012 K GUPTA Support for ICD-10 Coding System
+9 ;******************************************************************************
+10 ;******************************************************************************
+11 ;
ACTION ; Set appropriate fields/variables for Admit/Reject Action
+1 KILL HBHCQ,HBHCKEEP
+2 SET HBHCY0=^HBHC(631,HBHCDFN,0)
+3 ;changed to placeholder @2 from field 18
if X=""
SET Y=$SELECT($DATA(HBHCUPD):0,1:87)
if X=1
SET Y="@2"
if X=2
SET HBHCQ=1
+4 SET HBHCAFLG=0
FOR HBHCI=19:1:37
if HBHCAFLG
QUIT
if $PIECE(HBHCY0,U,HBHCI)]""
SET HBHCAFLG=1
+5 SET HBHCRFLG=0
IF ($PIECE(HBHCY0,U,16)]"")!($PIECE(HBHCY0,U,17)]"")
SET HBHCRFLG=1
+6 if (HBHCAFLG=0)&(HBHCRFLG=0)
QUIT
+7 if (HBHCRFLG=0)&(X=1)
QUIT
+8 if (HBHCAFLG=0)&(X=2)
QUIT
+9 SET HBHCWRD1=$SELECT(HBHCAFLG=1:"admission",1:"rejection")
+10 SET HBHCWRD2=$SELECT(X="":"to 'Delete'",X=2:"'Reject' in",1:"'Admit' in")
+11 SET HBHCWRD3=$SELECT(HBHCAFLG=1:"1 for Admit",1:"2 for Reject")
+12 DO PROCADM
IF %=1
if HBHCAFLG
DO ADMIT
if HBHCRFLG
SET $PIECE(^HBHC(631,HBHCDFN,0),U,16)=""
SET $PIECE(^HBHC(631,HBHCDFN,0),U,17)=""
+13 QUIT
PROCADM ; Process 'Delete' & 'Reject' responses
+1 WRITE $CHAR(7),!!,"This record contains ",HBHCWRD1," data. Are you sure you want ",HBHCWRD2," the",!,"Admit/Reject Action field ('Yes' will delete the ",HBHCWRD1," data)"
SET %=2
DO YN^DICN
+2 WRITE !
if %=0
WRITE !!,"Admit/Reject Action field must either contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
+3 IF %'=1
SET Y=$SELECT($DATA(HBHCUPD):0,1:14)
if $DATA(HBHCUPD)
SET HBHCKEEP=1
+4 QUIT
ADMIT ; Set appropriate fields = null
+1 FOR HBHCJ=19:1:37
SET $PIECE(^HBHC(631,HBHCDFN,0),U,HBHCJ)=""
+2 SET $PIECE(^HBHC(631,HBHCDFN,1),U,14)=""
+3 QUIT
STATUS ; Set appropriate fields/variables for Discharge Status
+1 KILL HBHCQ,HBHCQ1,HBHCKEEP
+2 SET HBHC12="^1^2^"
SET HBHC359="^3^5^9^"
SET HBHCNOD1=$GET(^HBHC(631,HBHCDFN,1))
SET HBHCY0=^HBHC(631,HBHCDFN,0)
+3 if X=""
SET Y=$SELECT($DATA(HBHCUPD):0,1:65)
if HBHC12[(U_X_U)
SET HBHCQ1=1
SET Y=44
if HBHC359[(U_X_U)
SET Y="@1"
if X=4
SET HBHCQ=1
SET Y=$SELECT($DATA(HBHCUPD):0,1:69)
+4 SET HBHCTFLG=0
if ($PIECE(HBHCY0,U,45)]"")!($PIECE(HBHCY0,U,46)]"")
SET HBHCTFLG=1
+5 SET HBHCDIED=0
if $PIECE($GET(^HBHC(631,HBHCDFN,1)),U,15)]""
SET HBHCDIED=1
+6 SET HBHCDFLG=0
FOR HBHCL=47:1:55
if HBHCDFLG
QUIT
if $PIECE(HBHCY0,U,HBHCL)]""
SET HBHCDFLG=1
+7 IF HBHCNOD1]""
FOR HBHCM=1:1:10
if HBHCDFLG
QUIT
if $PIECE(HBHCNOD1,U,HBHCM)]""
SET HBHCDFLG=1
+8 if (HBHCTFLG=0)&(HBHCDIED=0)&(HBHCDFLG=0)
QUIT
+9 if (HBHC12[(U_X_U))&(HBHCDIED=0)
QUIT
+10 if (X=4)&(HBHCTFLG=0)&(HBHCDFLG=0)
QUIT
+11 if (HBHC359[(U_X_U))&(HBHCTFLG=0)&(HBHCDIED=0)
QUIT
+12 SET HBHCWRD1=$SELECT(HBHCTFLG:"transfer",HBHCDIED:"deceased",1:"discharge")
+13 SET HBHCWRD2=$SELECT(X="":"to 'Delete'",HBHC12[(U_X_U):"'Transfer' in",X=4:"'Died' in",1:"'Discharge' in")
+14 SET HBHCWRD3=$SELECT(HBHCTFLG:"1 or 2 for Transfer",HBHCDIED:"4 for Died on HBHC",1:"3, 5 or 9 for Discharge")
+15 DO PROCDIS
if %'=1
QUIT
+16 if HBHCTFLG
SET $PIECE(^HBHC(631,HBHCDFN,0),U,45)=""
SET $PIECE(^HBHC(631,HBHCDFN,0),U,46)=""
+17 if (HBHCDFLG)&((X=4)!(X=""))
DO DISCHRG
+18 if HBHCDIED
SET $PIECE(^HBHC(631,HBHCDFN,1),U,15)=""
+19 QUIT
PROCDIS ; Process 'Delete', '1 or 2', '4', & '3 or 5 or 9' responses
+1 WRITE $CHAR(7),!!,"This record contains ",HBHCWRD1," data. Are you sure you want ",HBHCWRD2," the",!,"Discharge Status field ('Yes' will delete the ",HBHCWRD1," data)"
SET %=2
DO YN^DICN
+2 WRITE !
if %=0
WRITE !!,"Discharge Status field must contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
+3 IF %'=1
SET Y=$SELECT($DATA(HBHCUPD):0,1:43)
if $DATA(HBHCUPD)
SET HBHCKEEP=1
+4 QUIT
DISCHRG ; Delete discharge data
+1 FOR HBHCI=47:1:55
SET $PIECE(^HBHC(631,HBHCDFN,0),U,HBHCI)=""
+2 FOR HBHCJ=1:1:10
SET $PIECE(^HBHC(631,HBHCDFN,1),U,HBHCJ)=""
+3 SET $PIECE(^HBHC(631,HBHCDFN,1),U,16)=""
+4 QUIT
START ; Prompt for beginning/ending report dates
+1 WRITE !
KILL %DT
SET (HBHCBEG1,HBHCEND1,HBHCPAGE)=0
SET %DT("A")="Beginning Report Date: "
SET %DT="AEX"
DO ^%DT
SET HBHCBEG1=Y
if HBHCBEG1=-1
QUIT
DO DD^%DT
SET HBHCBEG2=Y
END ; Ending date prompt
+1 SET %DT("A")="Ending Report Date: "
DO ^%DT
IF (Y>0)&(Y<HBHCBEG1)
WRITE $CHAR(7),!!,"Ending Report Date must be closer to today than the Beginning Report Date",!
GOTO END
+2 SET HBHCEND1=Y_.9999
if HBHCEND1=-1
QUIT
DO DD^%DT
SET HBHCEND2=Y
TODAY ; Obtain current date
+1 SET $PIECE(HBHCZ,"=",81)=""
+2 KILL %DT
SET X="T"
DO ^%DT
DO DD^%DT
SET HBHCTDY=Y
KILL %DT
+3 QUIT
HDRPAGE ; Print header with Page
+1 SET HBHCPAGE=HBHCPAGE+1
+2 WRITE !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!!,"Run Date: ",HBHCTDY,!!
IF $DATA(HBHCHDR)
XECUTE HBHCHDR
WRITE !
+3 WRITE HBHCZ
+4 QUIT
HDRRANGE ; Print header with Date Range
+1 SET HBHCPAGE=HBHCPAGE+1
+2 WRITE !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!
if $DATA(HBHCNAM)
WRITE ?HBHCCLM1,$SELECT($DATA(HBHCONE):"Provider: ",1:"HBPC Team: "),HBHCNAM,!
WRITE !,"Run Date: ",HBHCTDY,?53,"Date Range: ",HBHCBEG2," to",!?65,HBHCEND2,!
+3 IF $DATA(HBHCHDR)
XECUTE HBHCHDR
WRITE !
+4 WRITE HBHCZ
+5 QUIT
HDR132 ; Print 132 column header with Date Range
+1 SET HBHCPAGE=HBHCPAGE+1
+2 WRITE !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?123,"Page: ",HBHCPAGE,!
if $DATA(HBHCNAM)
WRITE ?HBHCCLM1,HBHCWHOC_": ",HBHCNAM,!
WRITE !,"Run Date: ",HBHCTDY,?105,"Date Range: ",HBHCBEG2," to",!?117,HBHCEND2,!
IF $DATA(HBHCHDR)
XECUTE HBHCHDR
WRITE !
+3 WRITE HBHCZ
+4 QUIT
HDR132NR ; Print 132 column header with No Date Range
+1 SET HBHCPAGE=HBHCPAGE+1
+2 WRITE !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?123,"Page: ",HBHCPAGE,!
WRITE !,"Run Date: ",HBHCTDY
IF $DATA(HBHCHDR)
XECUTE HBHCHDR
WRITE !
+3 WRITE HBHCZ
+4 QUIT
HDRXPAGE ; Print header with Page & xtra info
+1 SET HBHCPAGE=HBHCPAGE+1
+2 WRITE !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!!
IF $DATA(HBHCHDRX)
XECUTE HBHCHDRX
WRITE !!,"Run Date: ",HBHCTDY,!
IF $DATA(HBHCHDR)
XECUTE HBHCHDR
WRITE !
+3 WRITE HBHCZ
+4 QUIT
