Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HBHCUTL

HBHCUTL.m

Go to the documentation of this file.
  1. 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
  1. ;******************************************************************************
  1. ;******************************************************************************
  1. ; --- ROUTINE MODIFICATION LOG ---
  1. ;
  1. ;PKG/PATCH DATE DEVELOPER MODIFICATION
  1. ;----------- ---------- ----------- ----------------------------------------
  1. ;HBH*1.0*25 APR 2012 K GUPTA Support for ICD-10 Coding System
  1. ;******************************************************************************
  1. ;******************************************************************************
  1. ;
  1. ACTION ; Set appropriate fields/variables for Admit/Reject Action
  1. K HBHCQ,HBHCKEEP
  1. S HBHCY0=^HBHC(631,HBHCDFN,0)
  1. 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
  1. S HBHCAFLG=0 F HBHCI=19:1:37 Q:HBHCAFLG S:$P(HBHCY0,U,HBHCI)]"" HBHCAFLG=1
  1. S HBHCRFLG=0 I ($P(HBHCY0,U,16)]"")!($P(HBHCY0,U,17)]"") S HBHCRFLG=1
  1. Q:(HBHCAFLG=0)&(HBHCRFLG=0)
  1. Q:(HBHCRFLG=0)&(X=1)
  1. Q:(HBHCAFLG=0)&(X=2)
  1. S HBHCWRD1=$S(HBHCAFLG=1:"admission",1:"rejection")
  1. S HBHCWRD2=$S(X="":"to 'Delete'",X=2:"'Reject' in",1:"'Admit' in")
  1. S HBHCWRD3=$S(HBHCAFLG=1:"1 for Admit",1:"2 for Reject")
  1. D PROCADM I %=1 D:HBHCAFLG ADMIT S:HBHCRFLG $P(^HBHC(631,HBHCDFN,0),U,16)="",$P(^HBHC(631,HBHCDFN,0),U,17)=""
  1. Q
  1. PROCADM ; Process 'Delete' & 'Reject' responses
  1. 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
  1. W ! W:%=0 !!,"Admit/Reject Action field must either contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
  1. I %'=1 S Y=$S($D(HBHCUPD):0,1:14) S:$D(HBHCUPD) HBHCKEEP=1
  1. Q
  1. ADMIT ; Set appropriate fields = null
  1. F HBHCJ=19:1:37 S $P(^HBHC(631,HBHCDFN,0),U,HBHCJ)=""
  1. S $P(^HBHC(631,HBHCDFN,1),U,14)=""
  1. Q
  1. STATUS ; Set appropriate fields/variables for Discharge Status
  1. K HBHCQ,HBHCQ1,HBHCKEEP
  1. S HBHC12="^1^2^",HBHC359="^3^5^9^",HBHCNOD1=$G(^HBHC(631,HBHCDFN,1)),HBHCY0=^HBHC(631,HBHCDFN,0)
  1. 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)
  1. S HBHCTFLG=0 S:($P(HBHCY0,U,45)]"")!($P(HBHCY0,U,46)]"") HBHCTFLG=1
  1. S HBHCDIED=0 S:$P($G(^HBHC(631,HBHCDFN,1)),U,15)]"" HBHCDIED=1
  1. S HBHCDFLG=0 F HBHCL=47:1:55 Q:HBHCDFLG S:$P(HBHCY0,U,HBHCL)]"" HBHCDFLG=1
  1. I HBHCNOD1]"" F HBHCM=1:1:10 Q:HBHCDFLG S:$P(HBHCNOD1,U,HBHCM)]"" HBHCDFLG=1
  1. Q:(HBHCTFLG=0)&(HBHCDIED=0)&(HBHCDFLG=0)
  1. Q:(HBHC12[(U_X_U))&(HBHCDIED=0)
  1. Q:(X=4)&(HBHCTFLG=0)&(HBHCDFLG=0)
  1. Q:(HBHC359[(U_X_U))&(HBHCTFLG=0)&(HBHCDIED=0)
  1. S HBHCWRD1=$S(HBHCTFLG:"transfer",HBHCDIED:"deceased",1:"discharge")
  1. S HBHCWRD2=$S(X="":"to 'Delete'",HBHC12[(U_X_U):"'Transfer' in",X=4:"'Died' in",1:"'Discharge' in")
  1. S HBHCWRD3=$S(HBHCTFLG:"1 or 2 for Transfer",HBHCDIED:"4 for Died on HBHC",1:"3, 5 or 9 for Discharge")
  1. D PROCDIS Q:%'=1
  1. S:HBHCTFLG $P(^HBHC(631,HBHCDFN,0),U,45)="",$P(^HBHC(631,HBHCDFN,0),U,46)=""
  1. D:(HBHCDFLG)&((X=4)!(X="")) DISCHRG
  1. S:HBHCDIED $P(^HBHC(631,HBHCDFN,1),U,15)=""
  1. Q
  1. PROCDIS ; Process 'Delete', '1 or 2', '4', & '3 or 5 or 9' responses
  1. 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
  1. W ! W:%=0 !!,"Discharge Status field must contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
  1. I %'=1 S Y=$S($D(HBHCUPD):0,1:43) S:$D(HBHCUPD) HBHCKEEP=1
  1. Q
  1. DISCHRG ; Delete discharge data
  1. F HBHCI=47:1:55 S $P(^HBHC(631,HBHCDFN,0),U,HBHCI)=""
  1. F HBHCJ=1:1:10 S $P(^HBHC(631,HBHCDFN,1),U,HBHCJ)=""
  1. S $P(^HBHC(631,HBHCDFN,1),U,16)=""
  1. Q
  1. START ; Prompt for beginning/ending report dates
  1. 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
  1. END ; Ending date prompt
  1. 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
  1. S HBHCEND1=Y_.9999 Q:HBHCEND1=-1 D DD^%DT S HBHCEND2=Y
  1. TODAY ; Obtain current date
  1. S $P(HBHCZ,"=",81)=""
  1. K %DT S X="T" D ^%DT,DD^%DT S HBHCTDY=Y K %DT
  1. Q
  1. HDRPAGE ; Print header with Page
  1. S HBHCPAGE=HBHCPAGE+1
  1. W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!!,"Run Date: ",HBHCTDY,!! I $D(HBHCHDR) X HBHCHDR W !
  1. W HBHCZ
  1. Q
  1. HDRRANGE ; Print header with Date Range
  1. S HBHCPAGE=HBHCPAGE+1
  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,!
  1. I $D(HBHCHDR) X HBHCHDR W !
  1. W HBHCZ
  1. Q
  1. HDR132 ; Print 132 column header with Date Range
  1. S HBHCPAGE=HBHCPAGE+1
  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 !
  1. W HBHCZ
  1. Q
  1. HDR132NR ; Print 132 column header with No Date Range
  1. S HBHCPAGE=HBHCPAGE+1
  1. W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?123,"Page: ",HBHCPAGE,! W !,"Run Date: ",HBHCTDY I $D(HBHCHDR) X HBHCHDR W !
  1. W HBHCZ
  1. Q
  1. HDRXPAGE ; Print header with Page & xtra info
  1. S HBHCPAGE=HBHCPAGE+1
  1. W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!! I $D(HBHCHDRX) X HBHCHDRX W !!,"Run Date: ",HBHCTDY,! I $D(HBHCHDR) X HBHCHDR W !
  1. W HBHCZ
  1. Q