- 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 Jan 18, 2025@03:00 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