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

HBHCXMD1.m

Go to the documentation of this file.
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