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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCXMA 8176 printed Dec 13, 2024@01:58:54 Page 2
HBHCXMA ;LR VAMC(IRMS)/MJT - HBHC Evaluation/Admission Transactions; May 11, 2021@17:03
+1 ;;1.0;HOSPITAL BASED HOME CARE;**1,6,9,19,24,25,32**;NOV 01, 1993;Build 58
+2 ;
+3 ; This routine references the following supported ICRs:
+4 ; 5747 $$CODEC^ICDEX
+5 ; 7024 ^DG(40.8
+6 ;
+7 DO 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
+1 SET HBHCDFN=""
FOR
SET HBHCDFN=$ORDER(^HBHC(631,"AE","N",HBHCDFN))
if HBHCDFN=""
QUIT
SET HBHCFLG=1
DO SETNODE
IF HBHCFLG
if HBHCDR=""
DO TRANS
if HBHCDR]""
DO ERROR^HBHCXMA1
EXIT ; Exit module
+1 DO EXIT^HBHCXMA1
+2 QUIT
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.1) Evaluation/Admission Error(s))
+1 SET HBHCINFO=^HBHC(631,HBHCDFN,0)
SET HBHCXMT3=$PIECE($GET(^HBHC(631,HBHCDFN,1)),U,17)
+2 ; Quit if admission date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
+3 IF $PIECE(HBHCINFO,U,18)>HBHCLSDT
SET HBHCFLG=0
QUIT
+4 ;HBH*1.0*32 retrieve parent site
+5 NEW HBHCHOSPX
+6 DO PARENT^HBHCUTL1
+7 ;if patient admitted before install of HBH*1.0*32, use the parent site
+8 ;previously sent.
+9 IF $GET(HBHCHOSPX)=""
SET HBHCHOSPX=HBHCHOSP
+10 ;end of HBH*1.0*32
+11 SET HBHCDPT0=^DPT(+HBHCINFO,0)
SET HBHCDR=""
+12 SET DFN=+HBHCINFO
KILL VADM
DO DEM^VADPT
DO RACE
DO ETH
+13 SET HBHCAFLG=0
FOR HBHCK=19:1:37
if HBHCAFLG
QUIT
if $PIECE(HBHCINFO,U,HBHCK)]""
SET HBHCAFLG=1
+14 SET HBHCRFLG=0
if ($PIECE(HBHCINFO,U,16)]"")!($PIECE(HBHCINFO,U,17)]"")
SET HBHCRFLG=1
+15 SET HBHCADDT=$SELECT($PIECE(HBHCINFO,U,18)]"":$EXTRACT($PIECE(HBHCINFO,U,18),4,5)_$EXTRACT($PIECE(HBHCINFO,U,18),6,7)_(1700+$EXTRACT($PIECE(HBHCINFO,U,18),1,3)),1:HBHCSP8)
+16 ; Use Evaluation Date for historical 'Reject' purposes
+17 if HBHCADDT=HBHCSP8
SET HBHCADDT=$SELECT($PIECE(HBHCINFO,U,2)]"":$EXTRACT($PIECE(HBHCINFO,U,2),4,5)_$EXTRACT($PIECE(HBHCINFO,U,2),6,7)_(1700+$EXTRACT($PIECE(HBHCINFO,U,2),1,3)),1:HBHCSP8)
+18 if HBHCADDT=HBHCSP8
SET HBHCDR=HBHCDR_"17;"
+19 SET HBHCST=$SELECT($PIECE(HBHCINFO,U,3)]"":$PIECE(^DIC(5,(+^HBHC(631.8,($PIECE(HBHCINFO,U,3)),0)),0),U,3),1:"")
if HBHCST=""
SET HBHCDR=HBHCDR_"2;"
+20 SET HBHCCNTY=""
if (($PIECE(HBHCINFO,U,3)]"")&($PIECE(HBHCINFO,U,4)]""))
SET HBHCCNTY=$PIECE($GET(^DIC(5,(+^HBHC(631.8,($PIECE(HBHCINFO,U,3)),0)),1,$PIECE(HBHCINFO,U,4),0)),U,3)
if HBHCCNTY=""
SET HBHCDR=HBHCDR_"3;"
+21 SET HBHCZIP=$SELECT($PIECE(HBHCINFO,U,5)]"":$PIECE(HBHCINFO,U,5),1:"")
if HBHCZIP=""
SET HBHCDR=HBHCDR_"4;"
+22 IF $PIECE(HBHCINFO,U,5)]""
if $LENGTH(HBHCZIP)'=9
SET HBHCZIP=HBHCZIP_HBHCSP4
+23 SET HBHCELGE=$SELECT($PIECE(HBHCINFO,U,6)]"":$PIECE(HBHCINFO,U,6),1:"")
if HBHCELGE=""
SET HBHCDR=HBHCDR_"5;"
+24 SET HBHCBYR=$SELECT($PIECE(HBHCDPT0,U,3):1700+$EXTRACT($PIECE(HBHCDPT0,U,3),1,3),1:"0000")
+25 SET HBHCPSRV=$SELECT($PIECE(HBHCINFO,U,8)]"":$PIECE(^HBHC(631.7,$PIECE(HBHCINFO,U,8),0),U),1:"")
if HBHCPSRV=""
SET HBHCDR=HBHCDR_"7;"
+26 SET HBHCSX=$PIECE(HBHCDPT0,U,2)
SET HBHCSEX=$SELECT(HBHCSX="M":1,1:2)
+27 ; Obsolete with Race/Ethnicity Info Jan 2003 mandate; commented out historical reference; HBHCRC set to X in HBHCXMA1 mjt
+28 ;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)
+29 FOR HBHCI=1:1:4
SET HBHCFLD=$PIECE(HBHCFLD1,U,HBHCI)
SET @HBHCFLD=$SELECT($PIECE(HBHCINFO,U,HBHCI+10)]"":$PIECE(HBHCINFO,U,HBHCI+10),1:"")
if @HBHCFLD=""
SET HBHCDR=HBHCDR_(HBHCI+9)_";"
+30 SET HBHCRFIN=$SELECT($PIECE($GET(^HBHC(631,HBHCDFN,1)),U,29)]"":$PIECE($GET(^HBHC(631,HBHCDFN,1)),U,29),1:HBHCSP1)
+31 SET HBHCACTN=$SELECT($PIECE(HBHCINFO,U,15)]"":$PIECE(HBHCINFO,U,15),1:"")
IF (HBHCACTN="")!((HBHCACTN=1)&(HBHCRFLG=1))!((HBHCACTN=2)&(HBHCAFLG=1))
SET HBHCDR=HBHCDR_"14;"
QUIT
+32 SET HBHCREJ=$SELECT($PIECE(HBHCINFO,U,16)]"":$PIECE(^HBHC(631.1,$PIECE(HBHCINFO,U,16),0),U),1:HBHCSP2)
if (HBHCACTN=2)&(HBHCREJ=HBHCSP2)
SET HBHCDR=HBHCDR_"15;"
+33 SET HBHCREJD=$SELECT($PIECE(HBHCINFO,U,17)]"":$PIECE(HBHCINFO,U,17),1:HBHCSP1)
if (HBHCACTN=2)&(HBHCREJD=HBHCSP1)
SET HBHCDR=HBHCDR_"16;"
+34 ;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;"
+35 IF $PIECE(HBHCINFO,U,19)]""
Begin DoDot:1
+36 NEW DXCODE
+37 SET DXCODE=$$CODEC^ICDEX(80,$PIECE(HBHCINFO,U,19))
+38 SET HBHCICDA=$PIECE(DXCODE,".",1)_$PIECE(DXCODE,".",2)
End DoDot:1
IF 1
+39 IF '$TEST
SET HBHCICDA=HBHCSP8
+40 if $LENGTH(HBHCICDA)<8
SET HBHCICDA=HBHCICDA_$JUSTIFY("",8-$LENGTH(HBHCICDA))
if (HBHCACTN=1)&(HBHCICDA=HBHCSP8)
SET HBHCDR=HBHCDR_"18;"
+41 FOR HBHCJ=1:1:18
SET HBHCFLD=$PIECE(HBHCFLD2,U,HBHCJ)
SET @HBHCFLD=$SELECT($PIECE(HBHCINFO,U,HBHCJ+19)]"":$PIECE(HBHCINFO,U,HBHCJ+19),1:HBHCSP1)
if (HBHCACTN=1)&(@HBHCFLD=HBHCSP1)
SET HBHCDR=HBHCDR_(HBHCJ+18)_";"
+42 ; Set field values = null
+43 SET HBHCMPT=HBHCSP1
SET HBHCIEN=HBHCSP5
SET HBHCRTDT=HBHCSP8
SET HBHCRTPD=HBHCSP6
+44 ; Check whether MFH site; Only validate data if Action = Admit
+45 DO MFHS^HBHCUTL3
IF HBHCACTN=1
if $DATA(HBHCMFHS)
DO MFH
+46 if HBHCDR]""
QUIT
+47 ; 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
+1 DO NOW^%DTC
SET HBHCX=$PIECE(%,".",2)
if ($LENGTH(HBHCX)'=6)
GOTO NOW
SET HBHCCDTS=($EXTRACT(%,4,5))_($EXTRACT(%,6,7))_($SELECT($EXTRACT(%)=2:19,1:20))_($EXTRACT(%,2,3))_HBHCX
+2 SET HBHCNAME=$PIECE(^DPT($PIECE(HBHCINFO,U),0),U)
if $LENGTH(HBHCNAME)<HBHCLNTH
SET HBHCNAME=HBHCNAME_$JUSTIFY("",HBHCLNTH-$LENGTH(HBHCNAME))
+3 SET HBHCSSN=$PIECE(^DPT($PIECE(HBHCINFO,U),0),U,9)
+4 ;HBH*1.0*32 replace HBHCHOSP with HBHCHOSPX
+5 SET 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
+6 SET 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
+7 QUIT
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
+1 SET HBHCRACE=""
SET HBHCEND=11
SET HBHCNODE=12
SET HBHCFIL=1
+2 DO LOOP2
+3 SET HBHCRACE=HBHCVAR
+4 QUIT
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
+1 SET HBHCETH=""
SET HBHCEND=8
SET HBHCNODE=11
SET HBHCFIL=2
+2 DO LOOP2
+3 SET HBHCETH=HBHCVAR
+4 QUIT
LOOP2 ; Loop 2
+1 SET HBHCVAR=""
+2 FOR HBHCL=1:1:HBHCEND
if '$DATA(VADM(HBHCNODE,HBHCL))
SET HBHCVAR=HBHCVAR_HBHCSP2
IF $DATA(VADM(HBHCNODE,HBHCL))
DO SET
SET HBHCVAR=HBHCVAR_HBHCPTFV_HBHCCM
+3 QUIT
SET ; Set PTF Value & Collection Method Variables
+1 SET HBHCIENP=$PIECE(VADM(HBHCNODE,HBHCL),U)
+2 SET HBHCIEN2=$PIECE(VADM(HBHCNODE,HBHCL,1),U)
+3 SET HBHCPTFV=$$PTR2CODE^DGUTL4(HBHCIENP,HBHCFIL,HBHCPTF)
+4 SET HBHCCM=$$PTR2CODE^DGUTL4(HBHCIEN2,HBHCT103,HBHCPTF)
+5 QUIT
TRANS ; Set node in ^HBHC(634) transmit file & flag record as 'F" (filed for transmit) in ^HBHC(631)
+1 LOCK +^HBHC(634,0):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if '$TEST
QUIT
SET HBHCNDX1=$PIECE(^HBHC(634,0),U,3)+1
SET $PIECE(^HBHC(634,0),U,3)=HBHCNDX1
SET $PIECE(^HBHC(634,0),U,4)=$PIECE(^HBHC(634,0),U,4)+1
LOCK -^HBHC(634,0)
+2 SET $PIECE(^HBHC(634,HBHCNDX1,0),U)=HBHCREC
SET ^HBHC(634,"B",$EXTRACT(HBHCREC,1,30),HBHCNDX1)=""
+3 LOCK +^HBHC(631,HBHCDFN,1):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if '$TEST
QUIT
if HBHCXMT3]""
KILL ^HBHC(631,"AE",HBHCXMT3,HBHCDFN)
SET $PIECE(^HBHC(631,HBHCDFN,1),U,17)="F"
SET ^HBHC(631,"AE","F",HBHCDFN)=""
SET $PIECE(^HBHC(631,HBHCDFN,1),U,19)=HBHCTDY
LOCK -^HBHC(631,HBHCDFN,1)
+4 QUIT
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
+1 SET HBHCNOD3=$GET(^HBHC(631,HBHCDFN,3))
+2 if $PIECE(HBHCNOD3,U)'="Y"
QUIT
+3 if $PIECE(HBHCNOD3,U)="Y"
SET HBHCMPT="Y"
+4 if $PIECE(HBHCNOD3,U,2)=""
SET HBHCDR=HBHCDR_"89;"
+5 if $PIECE(HBHCNOD3,U,2)]""
SET HBHCIEN=$PIECE(HBHCNOD3,U,2)
if $LENGTH(HBHCIEN)<5
SET HBHCIEN=HBHCIEN_$JUSTIFY("",5-$LENGTH(HBHCIEN))
+6 ; Process Current Rate Only
+7 SET (HBHCCURK,HBHCJ)=0
FOR
SET HBHCJ=$ORDER(^HBHC(631,HBHCDFN,4,"B",HBHCJ))
if HBHCJ'>0
QUIT
SET HBHCCURJ=HBHCJ
SET HBHCK=0
FOR
SET HBHCK=$ORDER(^HBHC(631,HBHCDFN,4,"B",HBHCJ,HBHCK))
if HBHCK'>0
QUIT
SET HBHCCURK=HBHCK
+8 SET HBHC=$GET(^HBHC(631,HBHCDFN,4,HBHCCURK,0))
+9 if ($PIECE(HBHC,U)="")!($PIECE(HBHC,U,2)="")
SET HBHCDR=HBHCDR_"90;"
+10 if $PIECE(HBHC,U)]""
SET HBHCRTDT=$EXTRACT($PIECE(HBHC,U),4,7)_"20"_$EXTRACT($PIECE(HBHC,U),2,3)
+11 if $PIECE(HBHC,U,2)]""
SET HBHCRTPD=$PIECE(HBHC,U,2)
+12 if HBHCRTPD'=HBHCSP6
SET HBHCRTPD=$SELECT($LENGTH(HBHCRTPD)=4:$EXTRACT(HBHCRTPD,1,4)_"00",$LENGTH(HBHCRTPD)=5:$EXTRACT(HBHCRTPD,1,4)_"00",$LENGTH(HBHCRTPD)=6:$EXTRACT(HBHCRTPD,1,4)_$EXTRACT(HBHCRTPD,6)_"0",1:$EXTRACT(HBHCRTPD,1,4)_$EXTRACT(HBHCRTPD,6,7))
+13 QUIT
