HBHCXMD1 ;LR VAMC(IRMS)/MJT - HBHC, called by ^HBHCXMD, calls HOSP^HBHCUTL1 ;9/2/09
;;1.0;HOSPITAL BASED HOME CARE;**2,6,19,24,25**;NOV 01, 1993;Build 45
;
; This routine references the following supported ICRs:
; 5747 $$CODEC^ICDEX
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;HBH*1.0*25 APR 2012 K GUPTA Support for ICD-10 Coding System
;******************************************************************************
;******************************************************************************
;
START ; Initialization
W !,"Processing Discharge/Form 5 Data"
S HBHCFORM=5,HBHC12="^1^2^",HBHC359="^3^5^9^",$P(HBHCSP1," ",2)="",$P(HBHCSP4," ",5)="",$P(HBHCSP8," ",9)="",$P(HBHCS129," ",130)="",HBHCLNTH=5
D HOSP^HBHCUTL1
S HBHCFLD1="HBHCELGD^HBHCMARD^HBHCLIVD^HBHCSTAT"
S HBHCFLD2="HBHCVISD^HBHCHERD^HBHCEXCD^HBHCRECD^HBHCBTHD^HBHCDRSD^HBHCTLTD^HBHCTRND"
S HBHCFLD3="HBHCEATD^HBHCWLKD^HBHCBWLD^HBHCBLDD^HBHCMOBD^HBHCADTD^HBHCBHVD^HBHCDSOD^HBHCMODD^HBHCLMTD"
K %DT S X="T" D ^%DT S HBHCTDY=Y
Q
DFLT1 ; Process fields 5, 10, & 11 as default values for fields 40, 41 & 42
S HBHCX=$S(HBHCI=1:6,HBHCI=2:11,HBHCI=3:12,1:""),HBHCDFLT=""
S:$P(HBHCNOD0,U,HBHCX)]"" HBHCDFLT=$P($P(^DD(631,(HBHCX-1),0),($P(HBHCNOD0,U,HBHCX)_":"),2),";")
S HBHCDR1=$S(HBHCDFLT]"":HBHCDR1_(HBHCI+39)_"//"_HBHCDFLT_";",1:HBHCDR1_(HBHCI+39)_";")
Q
ICDDFLT ; Process field 18 as default value for field 46
S HBHCDFLT=""
S HBHCDFLT=$$DFLTDCDX^HBHCLKU1(HBHCDFN) ;default only if same coding system
S:HBHCDFLT]"" HBHCDFLT=$$CODEC^ICDEX(80,HBHCDFLT)
S HBHCDR1=HBHCDR1_"46"_$S(HBHCDFLT]"":"//"_HBHCDFLT,1:"")_";"
Q
DFLT2 ; Process fields 19 - 26 as default values for fields 47 - 54
S HBHCDFLT=""
S:(HBHCJ=3)&($P(HBHCNOD0,U,22)]"") HBHCDFLT=$P(^HBHC(631.2,$P(HBHCNOD0,U,22),0),U)
S:(HBHCJ=4)&($P(HBHCNOD0,U,23)]"") HBHCDFLT=$P(^HBHC(631.3,$P(HBHCNOD0,U,23),0),U)
S:(HBHCJ'=3)&(HBHCJ'=4)&($P(HBHCNOD0,U,HBHCJ+19)]"") HBHCDFLT=$P($P(^DD(631,(HBHCJ+18),0),($P(HBHCNOD0,U,HBHCJ+19)_":"),2),";")
S:(HBHCJ=1)!(HBHCJ=2) HBHCDR1=$S(HBHCDFLT]"":HBHCDR1_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR1_(HBHCJ+46)_";")
S:(HBHCJ=3)!(HBHCJ=4)!(HBHCJ=5) HBHCDR2=$S(HBHCDFLT]"":HBHCDR2_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR2_(HBHCJ+46)_";")
S:(HBHCJ=6)!(HBHCJ=7)!(HBHCJ=8) HBHCDR3=$S(HBHCDFLT]"":HBHCDR3_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR3_(HBHCJ+46)_";")
Q
DFLT3 ; Process fields 27 - 36 as default values for fields 55 - 64
S HBHCDFLT=""
S:$P(HBHCNOD0,U,HBHCK+27)]"" HBHCDFLT=$P($P(^DD(631,(HBHCK+26),0),($P(HBHCNOD0,U,HBHCK+27)_":"),2),";")
S:HBHCK=1 HBHCDR3=$S(HBHCDFLT]"":HBHCDR3_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR3_(HBHCK+54)_";")
S:(HBHCK>1)&(HBHCK<6) HBHCDR4=$S(HBHCDFLT]"":HBHCDR4_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR4_(HBHCK+54)_";")
S:HBHCK>5 HBHCDR5=$S(HBHCDFLT]"":HBHCDR5_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR5_(HBHCK+54)_";")
Q
EXIT ; Exit module
K DILOCKTM,HBHC12,HBHC359,HBHCADDT,HBHCADTD,HBHCAGCY,HBHCBHVD,HBHCBLDD,HBHCBTHD,HBHCBWLD,HBHCCONT,HBHCDATE,HBHCDDTA,HBHCDEST,HBHCDFLG,HBHCDFLT,HBHCDFN,HBHCDR1,HBHCDR2,HBHCDR3,HBHCDR3,HBHCDR4,HBHCDR5,HBHCDRSD,HBHCDSDT,HBHCDSOD,HBHCEATD
K HBHCELGD,HBHCEXCD,HBHCFLD,HBHCFLD1,HBHCFLD2,HBHCFLD3,HBHCFLG,HBHCFORM,HBHCHERD,HBHCHOSP,HBHCI,HBHCICDD,HBHCJ,HBHCK,HBHCL,HBHCLIVD,HBHCLMTD,HBHCLNTH,HBHCM,HBHCMARD,HBHCMOBD,HBHCMODD,HBHCNAME,HBHCNDX1,HBHCNDX2,HBHCNOD0
K HBHCNOD1,HBHCREC,HBHCRECD,HBHCSP1,HBHCS129,HBHCSP4,HBHCSP8,HBHCSSN,HBHCSTAT,HBHCTDY,HBHCTFLG,HBHCTLTD,HBHCTRND,HBHCVISD,HBHCWLKD,HBHCX,HBHCXMT5,X,Y,%DT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCXMD1 3857 printed Sep 23, 2025@19:35:01 Page 2
HBHCXMD1 ;LR VAMC(IRMS)/MJT - HBHC, called by ^HBHCXMD, calls HOSP^HBHCUTL1 ;9/2/09
+1 ;;1.0;HOSPITAL BASED HOME CARE;**2,6,19,24,25**;NOV 01, 1993;Build 45
+2 ;
+3 ; This routine references the following supported ICRs:
+4 ; 5747 $$CODEC^ICDEX
+5 ;
+6 ;******************************************************************************
+7 ;******************************************************************************
+8 ; --- ROUTINE MODIFICATION LOG ---
+9 ;
+10 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+11 ;----------- ---------- ----------- ----------------------------------------
+12 ;HBH*1.0*25 APR 2012 K GUPTA Support for ICD-10 Coding System
+13 ;******************************************************************************
+14 ;******************************************************************************
+15 ;
START ; Initialization
+1 WRITE !,"Processing Discharge/Form 5 Data"
+2 SET HBHCFORM=5
SET HBHC12="^1^2^"
SET HBHC359="^3^5^9^"
SET $PIECE(HBHCSP1," ",2)=""
SET $PIECE(HBHCSP4," ",5)=""
SET $PIECE(HBHCSP8," ",9)=""
SET $PIECE(HBHCS129," ",130)=""
SET HBHCLNTH=5
+3 DO HOSP^HBHCUTL1
+4 SET HBHCFLD1="HBHCELGD^HBHCMARD^HBHCLIVD^HBHCSTAT"
+5 SET HBHCFLD2="HBHCVISD^HBHCHERD^HBHCEXCD^HBHCRECD^HBHCBTHD^HBHCDRSD^HBHCTLTD^HBHCTRND"
+6 SET HBHCFLD3="HBHCEATD^HBHCWLKD^HBHCBWLD^HBHCBLDD^HBHCMOBD^HBHCADTD^HBHCBHVD^HBHCDSOD^HBHCMODD^HBHCLMTD"
+7 KILL %DT
SET X="T"
DO ^%DT
SET HBHCTDY=Y
+8 QUIT
DFLT1 ; Process fields 5, 10, & 11 as default values for fields 40, 41 & 42
+1 SET HBHCX=$SELECT(HBHCI=1:6,HBHCI=2:11,HBHCI=3:12,1:"")
SET HBHCDFLT=""
+2 if $PIECE(HBHCNOD0,U,HBHCX)]""
SET HBHCDFLT=$PIECE($PIECE(^DD(631,(HBHCX-1),0),($PIECE(HBHCNOD0,U,HBHCX)_":"),2),";")
+3 SET HBHCDR1=$SELECT(HBHCDFLT]"":HBHCDR1_(HBHCI+39)_"//"_HBHCDFLT_";",1:HBHCDR1_(HBHCI+39)_";")
+4 QUIT
ICDDFLT ; Process field 18 as default value for field 46
+1 SET HBHCDFLT=""
+2 ;default only if same coding system
SET HBHCDFLT=$$DFLTDCDX^HBHCLKU1(HBHCDFN)
+3 if HBHCDFLT]""
SET HBHCDFLT=$$CODEC^ICDEX(80,HBHCDFLT)
+4 SET HBHCDR1=HBHCDR1_"46"_$SELECT(HBHCDFLT]"":"//"_HBHCDFLT,1:"")_";"
+5 QUIT
DFLT2 ; Process fields 19 - 26 as default values for fields 47 - 54
+1 SET HBHCDFLT=""
+2 if (HBHCJ=3)&($PIECE(HBHCNOD0,U,22)]"")
SET HBHCDFLT=$PIECE(^HBHC(631.2,$PIECE(HBHCNOD0,U,22),0),U)
+3 if (HBHCJ=4)&($PIECE(HBHCNOD0,U,23)]"")
SET HBHCDFLT=$PIECE(^HBHC(631.3,$PIECE(HBHCNOD0,U,23),0),U)
+4 if (HBHCJ'=3)&(HBHCJ'=4)&($PIECE(HBHCNOD0,U,HBHCJ+19)]"")
SET HBHCDFLT=$PIECE($PIECE(^DD(631,(HBHCJ+18),0),($PIECE(HBHCNOD0,U,HBHCJ+19)_":"),2),";")
+5 if (HBHCJ=1)!(HBHCJ=2)
SET HBHCDR1=$SELECT(HBHCDFLT]"":HBHCDR1_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR1_(HBHCJ+46)_";")
+6 if (HBHCJ=3)!(HBHCJ=4)!(HBHCJ=5)
SET HBHCDR2=$SELECT(HBHCDFLT]"":HBHCDR2_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR2_(HBHCJ+46)_";")
+7 if (HBHCJ=6)!(HBHCJ=7)!(HBHCJ=8)
SET HBHCDR3=$SELECT(HBHCDFLT]"":HBHCDR3_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR3_(HBHCJ+46)_";")
+8 QUIT
DFLT3 ; Process fields 27 - 36 as default values for fields 55 - 64
+1 SET HBHCDFLT=""
+2 if $PIECE(HBHCNOD0,U,HBHCK+27)]""
SET HBHCDFLT=$PIECE($PIECE(^DD(631,(HBHCK+26),0),($PIECE(HBHCNOD0,U,HBHCK+27)_":"),2),";")
+3 if HBHCK=1
SET HBHCDR3=$SELECT(HBHCDFLT]"":HBHCDR3_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR3_(HBHCK+54)_";")
+4 if (HBHCK>1)&(HBHCK<6)
SET HBHCDR4=$SELECT(HBHCDFLT]"":HBHCDR4_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR4_(HBHCK+54)_";")
+5 if HBHCK>5
SET HBHCDR5=$SELECT(HBHCDFLT]"":HBHCDR5_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR5_(HBHCK+54)_";")
+6 QUIT
EXIT ; Exit module
+1 KILL DILOCKTM,HBHC12,HBHC359,HBHCADDT,HBHCADTD,HBHCAGCY,HBHCBHVD,HBHCBLDD,HBHCBTHD,HBHCBWLD,HBHCCONT,HBHCDATE,HBHCDDTA,HBHCDEST,HBHCDFLG,HBHCDFLT,HBHCDFN,HBHCDR1,HBHCDR2,HBHCDR3,HBHCDR3,HBHCDR4,HBHCDR5,HBHCDRSD,HBHCDSDT,HBHCDSOD,HBHCEATD
+2 KILL HBHCELGD,HBHCEXCD,HBHCFLD,HBHCFLD1,HBHCFLD2,HBHCFLD3,HBHCFLG,HBHCFORM,HBHCHERD,HBHCHOSP,HBHCI,HBHCICDD,HBHCJ,HBHCK,HBHCL,HBHCLIVD,HBHCLMTD,HBHCLNTH,HBHCM,HBHCMARD,HBHCMOBD,HBHCMODD,HBHCNAME,HBHCNDX1,HBHCNDX2,HBHCNOD0
+3 KILL HBHCNOD1,HBHCREC,HBHCRECD,HBHCSP1,HBHCS129,HBHCSP4,HBHCSP8,HBHCSSN,HBHCSTAT,HBHCTDY,HBHCTFLG,HBHCTLTD,HBHCTRND,HBHCVISD,HBHCWLKD,HBHCX,HBHCXMT5,X,Y,%DT
+4 QUIT
