HBHCXMA ;LR VAMC(IRMS)/MJT - HBHC Evaluation/Admission Transactions; May 11, 2021@17:03
;;1.0;HOSPITAL BASED HOME CARE;**1,6,9,19,24,25,32**;NOV 01, 1993;Build 58
;
; This routine references the following supported ICRs:
; 5747 $$CODEC^ICDEX
; 7024 ^DG(40.8
;
D START^HBHCXMA1
LOOP ; Loop thru ^HBHC(631) "AE","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.1) => Evaluation/Admission Error(s) file
S HBHCDFN="" F S HBHCDFN=$O(^HBHC(631,"AE","N",HBHCDFN)) Q:HBHCDFN="" S HBHCFLG=1 D SETNODE I HBHCFLG D:HBHCDR="" TRANS D:HBHCDR]"" ERROR^HBHCXMA1
EXIT ; Exit module
D EXIT^HBHCXMA1
Q
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.1) Evaluation/Admission Error(s))
S HBHCINFO=^HBHC(631,HBHCDFN,0),HBHCXMT3=$P($G(^HBHC(631,HBHCDFN,1)),U,17)
; Quit if admission date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
I $P(HBHCINFO,U,18)>HBHCLSDT S HBHCFLG=0 Q
;HBH*1.0*32 retrieve parent site
N HBHCHOSPX
D PARENT^HBHCUTL1
;if patient admitted before install of HBH*1.0*32, use the parent site
;previously sent.
I $G(HBHCHOSPX)="" S HBHCHOSPX=HBHCHOSP
;end of HBH*1.0*32
S HBHCDPT0=^DPT(+HBHCINFO,0),HBHCDR=""
S DFN=+HBHCINFO K VADM D DEM^VADPT D RACE,ETH
S HBHCAFLG=0 F HBHCK=19:1:37 Q:HBHCAFLG S:$P(HBHCINFO,U,HBHCK)]"" HBHCAFLG=1
S HBHCRFLG=0 S:($P(HBHCINFO,U,16)]"")!($P(HBHCINFO,U,17)]"") HBHCRFLG=1
S HBHCADDT=$S($P(HBHCINFO,U,18)]"":$E($P(HBHCINFO,U,18),4,5)_$E($P(HBHCINFO,U,18),6,7)_(1700+$E($P(HBHCINFO,U,18),1,3)),1:HBHCSP8)
; Use Evaluation Date for historical 'Reject' purposes
S:HBHCADDT=HBHCSP8 HBHCADDT=$S($P(HBHCINFO,U,2)]"":$E($P(HBHCINFO,U,2),4,5)_$E($P(HBHCINFO,U,2),6,7)_(1700+$E($P(HBHCINFO,U,2),1,3)),1:HBHCSP8)
S:HBHCADDT=HBHCSP8 HBHCDR=HBHCDR_"17;"
S HBHCST=$S($P(HBHCINFO,U,3)]"":$P(^DIC(5,(+^HBHC(631.8,($P(HBHCINFO,U,3)),0)),0),U,3),1:"") S:HBHCST="" HBHCDR=HBHCDR_"2;"
S HBHCCNTY="" S:(($P(HBHCINFO,U,3)]"")&($P(HBHCINFO,U,4)]"")) HBHCCNTY=$P($G(^DIC(5,(+^HBHC(631.8,($P(HBHCINFO,U,3)),0)),1,$P(HBHCINFO,U,4),0)),U,3) S:HBHCCNTY="" HBHCDR=HBHCDR_"3;"
S HBHCZIP=$S($P(HBHCINFO,U,5)]"":$P(HBHCINFO,U,5),1:"") S:HBHCZIP="" HBHCDR=HBHCDR_"4;"
I $P(HBHCINFO,U,5)]"" S:$L(HBHCZIP)'=9 HBHCZIP=HBHCZIP_HBHCSP4
S HBHCELGE=$S($P(HBHCINFO,U,6)]"":$P(HBHCINFO,U,6),1:"") S:HBHCELGE="" HBHCDR=HBHCDR_"5;"
S HBHCBYR=$S($P(HBHCDPT0,U,3):1700+$E($P(HBHCDPT0,U,3),1,3),1:"0000")
S HBHCPSRV=$S($P(HBHCINFO,U,8)]"":$P(^HBHC(631.7,$P(HBHCINFO,U,8),0),U),1:"") S:HBHCPSRV="" HBHCDR=HBHCDR_"7;"
S HBHCSX=$P(HBHCDPT0,U,2),HBHCSEX=$S(HBHCSX="M":1,1:2)
; Obsolete with Race/Ethnicity Info Jan 2003 mandate; commented out historical reference; HBHCRC set to X in HBHCXMA1 mjt
;S HBHCRC=$S($P(HBHCDPT0,U,6)]"":$P(^DIC(10,$P(HBHCDPT0,U,6),0),U,2),1:""),HBHCRACE=$S(HBHCRC=6:1,HBHCRC=4:2,(HBHCRC=1)!(HBHCRC=2):3,HBHCRC=3:4,HBHCRC=5:5,1:9)
F HBHCI=1:1:4 S HBHCFLD=$P(HBHCFLD1,U,HBHCI) S @HBHCFLD=$S($P(HBHCINFO,U,HBHCI+10)]"":$P(HBHCINFO,U,HBHCI+10),1:"") S:@HBHCFLD="" HBHCDR=HBHCDR_(HBHCI+9)_";"
S HBHCRFIN=$S($P($G(^HBHC(631,HBHCDFN,1)),U,29)]"":$P($G(^HBHC(631,HBHCDFN,1)),U,29),1:HBHCSP1)
S HBHCACTN=$S($P(HBHCINFO,U,15)]"":$P(HBHCINFO,U,15),1:"") I (HBHCACTN="")!((HBHCACTN=1)&(HBHCRFLG=1))!((HBHCACTN=2)&(HBHCAFLG=1)) S HBHCDR=HBHCDR_"14;" Q
S HBHCREJ=$S($P(HBHCINFO,U,16)]"":$P(^HBHC(631.1,$P(HBHCINFO,U,16),0),U),1:HBHCSP2) S:(HBHCACTN=2)&(HBHCREJ=HBHCSP2) HBHCDR=HBHCDR_"15;"
S HBHCREJD=$S($P(HBHCINFO,U,17)]"":$P(HBHCINFO,U,17),1:HBHCSP1) S:(HBHCACTN=2)&(HBHCREJD=HBHCSP1) HBHCDR=HBHCDR_"16;"
;S HBHCICDA=$S($P(HBHCINFO,U,19)]"":$P($P(^ICD9($P(HBHCINFO,U,19),0),U),".")_$P($P(^ICD9($P(HBHCINFO,U,19),0),U),".",2),1:HBHCSP6) S:$L(HBHCICDA)<6 HBHCICDA=HBHCICDA_$J("",6-$L(HBHCICDA)) S:(HBHCACTN=1)&(HBHCICDA=HBHCSP6) HBHCDR=HBHCDR_"18;"
I $P(HBHCINFO,U,19)]"" D I 1
. N DXCODE
. S DXCODE=$$CODEC^ICDEX(80,$P(HBHCINFO,U,19))
. S HBHCICDA=$P(DXCODE,".",1)_$P(DXCODE,".",2)
E S HBHCICDA=HBHCSP8
S:$L(HBHCICDA)<8 HBHCICDA=HBHCICDA_$J("",8-$L(HBHCICDA)) S:(HBHCACTN=1)&(HBHCICDA=HBHCSP8) HBHCDR=HBHCDR_"18;"
F HBHCJ=1:1:18 S HBHCFLD=$P(HBHCFLD2,U,HBHCJ) S @HBHCFLD=$S($P(HBHCINFO,U,HBHCJ+19)]"":$P(HBHCINFO,U,HBHCJ+19),1:HBHCSP1) S:(HBHCACTN=1)&(@HBHCFLD=HBHCSP1) HBHCDR=HBHCDR_(HBHCJ+18)_";"
; Set field values = null
S HBHCMPT=HBHCSP1,HBHCIEN=HBHCSP5,HBHCRTDT=HBHCSP8,HBHCRTPD=HBHCSP6
; Check whether MFH site; Only validate data if Action = Admit
D MFHS^HBHCUTL3 I HBHCACTN=1 D:$D(HBHCMFHS) MFH
Q:HBHCDR]""
; HBHCCDTS (HBHC Creation Date/Time/Seconds) is used as unique record identifier on Austin end, seconds must be included for likelihood of being unique
NOW ; Get time NOW, repeat until Hours/Minutes/Seconds = 6 digits in length
D NOW^%DTC S HBHCX=$P(%,".",2) G:($L(HBHCX)'=6) NOW S HBHCCDTS=($E(%,4,5))_($E(%,6,7))_($S($E(%)=2:19,1:20))_($E(%,2,3))_HBHCX
S HBHCNAME=$P(^DPT($P(HBHCINFO,U),0),U) S:$L(HBHCNAME)<HBHCLNTH HBHCNAME=HBHCNAME_$J("",HBHCLNTH-$L(HBHCNAME))
S HBHCSSN=$P(^DPT($P(HBHCINFO,U),0),U,9)
;HBH*1.0*32 replace HBHCHOSP with HBHCHOSPX
S HBHCREC=HBHCFORM_HBHCHOSPX_HBHCSSN_HBHCADDT_HBHCST_HBHCCNTY_HBHCZIP_HBHCELGE_HBHCBYR_HBHCPSRV_HBHCSEX_HBHCRC_HBHCMARE_HBHCLIVE_HBHCCARE_HBHCTYPE_HBHCRFIN_HBHCACTN_HBHCREJ_HBHCREJD_HBHCNAME_HBHCICDA_HBHCVISA_HBHCHERA_HBHCEXCA
S HBHCREC=HBHCREC_HBHCRECA_HBHCBTHA_HBHCDRSA_HBHCTLTA_HBHCTRNA_HBHCEATA_HBHCWLKA_HBHCBWLA_HBHCBLDA_HBHCMOBA_HBHCADTA_HBHCBHVA_HBHCDSOA_HBHCMODA_HBHCLMTA_HBHCRACE_HBHCETH_HBHCMPT_HBHCIEN_HBHCRTDT_HBHCRTPD_HBHCCDTS_HBHCSP14
Q
RACE ; Race Jan 2003 mandate: 7 Race codes (w/corresponding Collection Method codes) exist, 4 additional 'slots' are for future expansion = 11 total for loop counter for data fill in transmit record
S HBHCRACE="",HBHCEND=11,HBHCNODE=12,HBHCFIL=1
D LOOP2
S HBHCRACE=HBHCVAR
Q
ETH ; Ethnicity Jan 2003 mandate: 4 Ethnicity codes (w/corresponding Collection Method codes) exist, 4 additional 'slots' are for future expansion = 8 total for loop counter for data fill in transmit record
S HBHCETH="",HBHCEND=8,HBHCNODE=11,HBHCFIL=2
D LOOP2
S HBHCETH=HBHCVAR
Q
LOOP2 ; Loop 2
S HBHCVAR=""
F HBHCL=1:1:HBHCEND S:'$D(VADM(HBHCNODE,HBHCL)) HBHCVAR=HBHCVAR_HBHCSP2 I $D(VADM(HBHCNODE,HBHCL)) D SET S HBHCVAR=HBHCVAR_HBHCPTFV_HBHCCM
Q
SET ; Set PTF Value & Collection Method Variables
S HBHCIENP=$P(VADM(HBHCNODE,HBHCL),U)
S HBHCIEN2=$P(VADM(HBHCNODE,HBHCL,1),U)
S HBHCPTFV=$$PTR2CODE^DGUTL4(HBHCIENP,HBHCFIL,HBHCPTF)
S HBHCCM=$$PTR2CODE^DGUTL4(HBHCIEN2,HBHCT103,HBHCPTF)
Q
TRANS ; Set node in ^HBHC(634) transmit file & flag record as 'F" (filed for transmit) in ^HBHC(631)
L +^HBHC(634,0):$S($D(DILOCKTM):DILOCKTM,1:3) Q:'$T S HBHCNDX1=$P(^HBHC(634,0),U,3)+1,$P(^HBHC(634,0),U,3)=HBHCNDX1,$P(^HBHC(634,0),U,4)=$P(^HBHC(634,0),U,4)+1 L -^HBHC(634,0)
S $P(^HBHC(634,HBHCNDX1,0),U)=HBHCREC,^HBHC(634,"B",$E(HBHCREC,1,30),HBHCNDX1)=""
L +^HBHC(631,HBHCDFN,1):$S($D(DILOCKTM):DILOCKTM,1:3) Q:'$T K:HBHCXMT3]"" ^HBHC(631,"AE",HBHCXMT3,HBHCDFN) S $P(^HBHC(631,HBHCDFN,1),U,17)="F",^HBHC(631,"AE","F",HBHCDFN)="",$P(^HBHC(631,HBHCDFN,1),U,19)=HBHCTDY L -^HBHC(631,HBHCDFN,1)
Q
MFH ; Medical Foster Home (MFH) processing; Check for existance of MFH fields: 89, 90 (.01 & 1), when 88 = Y signifying MFH Patient, in file 631; Set variables for HBHCREC
S HBHCNOD3=$G(^HBHC(631,HBHCDFN,3))
Q:$P(HBHCNOD3,U)'="Y"
S:$P(HBHCNOD3,U)="Y" HBHCMPT="Y"
S:$P(HBHCNOD3,U,2)="" HBHCDR=HBHCDR_"89;"
S:$P(HBHCNOD3,U,2)]"" HBHCIEN=$P(HBHCNOD3,U,2) S:$L(HBHCIEN)<5 HBHCIEN=HBHCIEN_$J("",5-$L(HBHCIEN))
; Process Current Rate Only
S (HBHCCURK,HBHCJ)=0 F S HBHCJ=$O(^HBHC(631,HBHCDFN,4,"B",HBHCJ)) Q:HBHCJ'>0 S HBHCCURJ=HBHCJ,HBHCK=0 F S HBHCK=$O(^HBHC(631,HBHCDFN,4,"B",HBHCJ,HBHCK)) Q:HBHCK'>0 S HBHCCURK=HBHCK
S HBHC=$G(^HBHC(631,HBHCDFN,4,HBHCCURK,0))
S:($P(HBHC,U)="")!($P(HBHC,U,2)="") HBHCDR=HBHCDR_"90;"
S:$P(HBHC,U)]"" HBHCRTDT=$E($P(HBHC,U),4,7)_"20"_$E($P(HBHC,U),2,3)
S:$P(HBHC,U,2)]"" HBHCRTPD=$P(HBHC,U,2)
S:HBHCRTPD'=HBHCSP6 HBHCRTPD=$S($L(HBHCRTPD)=4:$E(HBHCRTPD,1,4)_"00",$L(HBHCRTPD)=5:$E(HBHCRTPD,1,4)_"00",$L(HBHCRTPD)=6:$E(HBHCRTPD,1,4)_$E(HBHCRTPD,6)_"0",1:$E(HBHCRTPD,1,4)_$E(HBHCRTPD,6,7))
Q