HBHCXMM ; LR VAMC(IRMS)/MJT-HBHC Transmit Medical Foster Home Data to AITC; May 21, 2021@12:36
;;1.0;HOSPITAL BASED HOME CARE;**24,32**;NOV 01, 1993;Build 58
;
;Reference to:
; ^DG(40.8 supported by ICR #7024
; ^DIC(4 supported by ICR #10090
;
START ; Initialization
W !,"Processing Medical Foster Home Form 7 Data"
N HBHCHOSPX
S HBHCFORM=7,$P(HBHCSP4," ",5)="",$P(HBHCSP8," ",9)="",$P(HBHCS101," ",102)="",HBHCLNTH=30
D HOSP^HBHCUTL1
LOOP ; Loop thru ^HBHC(633.2) "AC","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.7) => Medical Foster Home Error(s) file
S HBHCDFN="" F S HBHCDFN=$O(^HBHC(633.2,"AC","N",HBHCDFN)) Q:HBHCDFN="" S HBHCFLG=1 D SETNODE I HBHCFLG D:HBHCDR="" TRANS D:HBHCDR]"" ERROR
EXIT ; Exit module
K HBHCBEDM,HBHCCDOB,HBHCCDTS,HBHCCLOS,HBHCCNTY,HBHCDFN,HBHCDR,HBHCFLG,HBHCFORM,HBHCHOSP,HBHCIEN,HBHCINFO,HBHCLNTH,HBHCLREQ,HBHCLSDT,HBHCMFHN,HBHCMXPT,HBHCNDX1,HBHCNDX2,HBHCOPEN,HBHCREC,HBHCS101,HBHCSP4,HBHCSP8,HBHCST
K HBHCX,HBHCXMT7,HBHCZIP,%
Q
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.7) Medical Foster Home Error(s))
S HBHCINFO=^HBHC(633.2,HBHCDFN,0),HBHCXMT7=$P($G(^HBHC(633.2,HBHCDFN,12)),U)
; HBHCLSDT set here to make routine freestanding if needed
S:'$D(HBHCLSDT) HBHCLSDT=DT
; Quit if Opened Date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
I $P(HBHCINFO,U,2)>HBHCLSDT S HBHCFLG=0 Q
S HBHCDR=""
;HBH*1.0*32 retrieve parent site
D PARENT
S HBHCMFHN=$P(HBHCINFO,U) S:$L(HBHCMFHN)<HBHCLNTH HBHCMFHN=HBHCMFHN_$J("",HBHCLNTH-$L(HBHCMFHN))
S HBHCST=$S($P(HBHCINFO,U,10)]"":$P(^DIC(5,(+^HBHC(631.8,($P(HBHCINFO,U,10)),0)),0),U,3),1:"") S:HBHCST="" HBHCDR=HBHCDR_"9;"
S HBHCCNTY="" S:(($P(HBHCINFO,U,10)]"")&($P(HBHCINFO,U,15)]"")) HBHCCNTY=$P($G(^DIC(5,(+^HBHC(631.8,($P(HBHCINFO,U,10)),0)),1,$P(HBHCINFO,U,15),0)),U,3) S:HBHCCNTY="" HBHCDR=HBHCDR_"25;"
S HBHCZIP=$S($P(HBHCINFO,U,11)]"":$P(HBHCINFO,U,11),1:"") S:HBHCZIP="" HBHCDR=HBHCDR_"10;"
I $P(HBHCINFO,U,11)]"" S:$L(HBHCZIP)'=9 HBHCZIP=HBHCZIP_HBHCSP4
S HBHCOPEN=$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:HBHCOPEN=HBHCSP8 HBHCDR=HBHCDR_"1;"
S HBHCCDOB=$S($P(HBHCINFO,U,16)]"":$E($P(HBHCINFO,U,16),4,5)_$E($P(HBHCINFO,U,16),6,7)_(1700+$E($P(HBHCINFO,U,16),1,3)),1:HBHCSP8) S:HBHCCDOB=HBHCSP8 HBHCDR=HBHCDR_"26;"
S HBHCMXPT=$S($P(HBHCINFO,U,4)]"":$P(HBHCINFO,U,4),1:"") S:HBHCMXPT="" HBHCDR=HBHCDR_"3;"
S HBHCBEDM=$S($P(HBHCINFO,U,5)]"":$P(HBHCINFO,U,5),1:"") S:HBHCBEDM="" HBHCDR=HBHCDR_"4;"
S HBHCLREQ=$S($P(HBHCINFO,U,12)]"":$P(HBHCINFO,U,12),1:"") S:HBHCLREQ="" HBHCDR=HBHCDR_"11;"
; HBHCCLOS represents MFH Closure Date; field may be blank
S HBHCCLOS=$S($P(HBHCINFO,U,6)]"":$E($P(HBHCINFO,U,6),4,5)_$E($P(HBHCINFO,U,6),6,7)_(1700+$E($P(HBHCINFO,U,6),1,3)),1:HBHCSP8)
Q:HBHCDR]""
; Pad HBHCDFN to length of 5, without changing HBHCDFN, since used in loop
S:$L(HBHCDFN)<5 HBHCIEN=HBHCDFN_$J("",5-$L(HBHCDFN))
; 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
; "H" represents HBPC record origin (vs. e.g. SCI (Spinal Cord Injury) record origin)
;HBH*1.0*32 - replace HBHCHOSP with HBHCHOSPX in string below
S HBHCREC=HBHCFORM_HBHCHOSPX_HBHCMFHN_HBHCCDTS_"H"_HBHCIEN_HBHCST_HBHCCNTY_HBHCZIP_HBHCCDOB_HBHCMXPT_HBHCBEDM_HBHCLREQ_HBHCOPEN_HBHCCLOS_HBHCS101
Q
;
PARENT ;
;HBH*1.0*32 retrieve parent site
;If a MFH is added/edited after the install of HBH*1.0*32,
;a parent site must be defined for the MFH.
;For multidivisional sites, if parent sites were added/edited
;between the time of last AITC transmission and install of
;HBH*1.0*32, the sites will generate HBHC Medical Foster Home Errors
;and will need to be edited to add a parent site.
N HBHCPRNT
S HBHCHOSPX=""
S HBHCPRNT=$P($G(^HBHC(633.2,HBHCDFN,13)),"^")
;If site has only one parent site defined, use that site.
I HBHCPRNT="",$P(^HBHC(631.9,1,1,0),"^",4)=1 D
. S HBHCPRNT=$O(^HBHC(631.9,1,1,"B",""))
I HBHCPRNT]"" D
. ;retrieve institution file pointer for the division
. S HBHCPRNT=$P(^DG(40.8,HBHCPRNT,0),"^",7)
. ;retrieve station number
. S HBHCHOSPX=$P($G(^DIC(4,+HBHCPRNT,99)),"^")
. I HBHCHOSPX]"",$L(HBHCHOSPX)'=7 S HBHCHOSPX=HBHCHOSPX_$E(HBHCSP4,1,(7-($L(HBHCHOSPX))))
;If this is a multi-divisional site and the MFH does not have a parent site defined,
;generate error.
I HBHCHOSPX="" S HBHCDR=HBHCDR_"35;"
;end of HBH*1.0*32
Q
;
TRANS ; Set node in ^HBHC(634) transmit file & flag record as 'F" (filed for transmit) in ^HBHC(633.2)
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(633.2,HBHCDFN,12):$S($D(DILOCKTM):DILOCKTM,1:3) Q:'$T K:HBHCXMT7]"" ^HBHC(633.2,"AC",HBHCXMT7,HBHCDFN)
S $P(^HBHC(633.2,HBHCDFN,12),U)="F",^HBHC(633.2,"AC","F",HBHCDFN)="",$P(^HBHC(633.2,HBHCDFN,12),U,2)=HBHCCDTS L -^HBHC(633.2,HBHCDFN,12)
Q
ERROR ; Set node in ^HBHC(634.7) if data is incomplete
L +^HBHC(634.7,0):$S($D(DILOCKTM):DILOCKTM,1:3) Q:'$T S HBHCNDX2=$P(^HBHC(634.7,0),U,3)+1,$P(^HBHC(634.7,0),U,3)=HBHCNDX2,$P(^HBHC(634.7,0),U,4)=$P(^HBHC(634.7,0),U,4)+1 L -^HBHC(634.7,0)
S ^HBHC(634.7,HBHCNDX2,0)=HBHCDFN,^HBHC(634.7,HBHCNDX2,1)=HBHCDR,^HBHC(634.7,"B",HBHCDFN,HBHCNDX2)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCXMM 5764 printed Sep 23, 2025@19:35:02 Page 2
HBHCXMM ; LR VAMC(IRMS)/MJT-HBHC Transmit Medical Foster Home Data to AITC; May 21, 2021@12:36
+1 ;;1.0;HOSPITAL BASED HOME CARE;**24,32**;NOV 01, 1993;Build 58
+2 ;
+3 ;Reference to:
+4 ; ^DG(40.8 supported by ICR #7024
+5 ; ^DIC(4 supported by ICR #10090
+6 ;
START ; Initialization
+1 WRITE !,"Processing Medical Foster Home Form 7 Data"
+2 NEW HBHCHOSPX
+3 SET HBHCFORM=7
SET $PIECE(HBHCSP4," ",5)=""
SET $PIECE(HBHCSP8," ",9)=""
SET $PIECE(HBHCS101," ",102)=""
SET HBHCLNTH=30
+4 DO HOSP^HBHCUTL1
LOOP ; Loop thru ^HBHC(633.2) "AC","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.7) => Medical Foster Home Error(s) file
+1 SET HBHCDFN=""
FOR
SET HBHCDFN=$ORDER(^HBHC(633.2,"AC","N",HBHCDFN))
if HBHCDFN=""
QUIT
SET HBHCFLG=1
DO SETNODE
IF HBHCFLG
if HBHCDR=""
DO TRANS
if HBHCDR]""
DO ERROR
EXIT ; Exit module
+1 KILL HBHCBEDM,HBHCCDOB,HBHCCDTS,HBHCCLOS,HBHCCNTY,HBHCDFN,HBHCDR,HBHCFLG,HBHCFORM,HBHCHOSP,HBHCIEN,HBHCINFO,HBHCLNTH,HBHCLREQ,HBHCLSDT,HBHCMFHN,HBHCMXPT,HBHCNDX1,HBHCNDX2,HBHCOPEN,HBHCREC,HBHCS101,HBHCSP4,HBHCSP8,HBHCST
+2 KILL HBHCX,HBHCXMT7,HBHCZIP,%
+3 QUIT
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.7) Medical Foster Home Error(s))
+1 SET HBHCINFO=^HBHC(633.2,HBHCDFN,0)
SET HBHCXMT7=$PIECE($GET(^HBHC(633.2,HBHCDFN,12)),U)
+2 ; HBHCLSDT set here to make routine freestanding if needed
+3 if '$DATA(HBHCLSDT)
SET HBHCLSDT=DT
+4 ; Quit if Opened Date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
+5 IF $PIECE(HBHCINFO,U,2)>HBHCLSDT
SET HBHCFLG=0
QUIT
+6 SET HBHCDR=""
+7 ;HBH*1.0*32 retrieve parent site
+8 DO PARENT
+9 SET HBHCMFHN=$PIECE(HBHCINFO,U)
if $LENGTH(HBHCMFHN)<HBHCLNTH
SET HBHCMFHN=HBHCMFHN_$JUSTIFY("",HBHCLNTH-$LENGTH(HBHCMFHN))
+10 SET HBHCST=$SELECT($PIECE(HBHCINFO,U,10)]"":$PIECE(^DIC(5,(+^HBHC(631.8,($PIECE(HBHCINFO,U,10)),0)),0),U,3),1:"")
if HBHCST=""
SET HBHCDR=HBHCDR_"9;"
+11 SET HBHCCNTY=""
if (($PIECE(HBHCINFO,U,10)]"")&($PIECE(HBHCINFO,U,15)]""))
SET HBHCCNTY=$PIECE($GET(^DIC(5,(+^HBHC(631.8,($PIECE(HBHCINFO,U,10)),0)),1,$PIECE(HBHCINFO,U,15),0)),U,3)
if HBHCCNTY=""
SET HBHCDR=HBHCDR_"25;"
+12 SET HBHCZIP=$SELECT($PIECE(HBHCINFO,U,11)]"":$PIECE(HBHCINFO,U,11),1:"")
if HBHCZIP=""
SET HBHCDR=HBHCDR_"10;"
+13 IF $PIECE(HBHCINFO,U,11)]""
if $LENGTH(HBHCZIP)'=9
SET HBHCZIP=HBHCZIP_HBHCSP4
+14 SET HBHCOPEN=$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)
if HBHCOPEN=HBHCSP8
SET HBHCDR=HBHCDR_"1;"
+15 SET HBHCCDOB=$SELECT($PIECE(HBHCINFO,U,16)]"":$EXTRACT($PIECE(HBHCINFO,U,16),4,5)_$EXTRACT($PIECE(HBHCINFO,U,16),6,7)_(1700+$EXTRACT($PIECE(HBHCINFO,U,16),1,3)),1:HBHCSP8)
if HBHCCDOB=HBHCSP8
SET HBHCDR=HBHCDR_"26;"
+16 SET HBHCMXPT=$SELECT($PIECE(HBHCINFO,U,4)]"":$PIECE(HBHCINFO,U,4),1:"")
if HBHCMXPT=""
SET HBHCDR=HBHCDR_"3;"
+17 SET HBHCBEDM=$SELECT($PIECE(HBHCINFO,U,5)]"":$PIECE(HBHCINFO,U,5),1:"")
if HBHCBEDM=""
SET HBHCDR=HBHCDR_"4;"
+18 SET HBHCLREQ=$SELECT($PIECE(HBHCINFO,U,12)]"":$PIECE(HBHCINFO,U,12),1:"")
if HBHCLREQ=""
SET HBHCDR=HBHCDR_"11;"
+19 ; HBHCCLOS represents MFH Closure Date; field may be blank
+20 SET HBHCCLOS=$SELECT($PIECE(HBHCINFO,U,6)]"":$EXTRACT($PIECE(HBHCINFO,U,6),4,5)_$EXTRACT($PIECE(HBHCINFO,U,6),6,7)_(1700+$EXTRACT($PIECE(HBHCINFO,U,6),1,3)),1:HBHCSP8)
+21 if HBHCDR]""
QUIT
+22 ; Pad HBHCDFN to length of 5, without changing HBHCDFN, since used in loop
+23 if $LENGTH(HBHCDFN)<5
SET HBHCIEN=HBHCDFN_$JUSTIFY("",5-$LENGTH(HBHCDFN))
+24 ; 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 ; "H" represents HBPC record origin (vs. e.g. SCI (Spinal Cord Injury) record origin)
+3 ;HBH*1.0*32 - replace HBHCHOSP with HBHCHOSPX in string below
+4 SET HBHCREC=HBHCFORM_HBHCHOSPX_HBHCMFHN_HBHCCDTS_"H"_HBHCIEN_HBHCST_HBHCCNTY_HBHCZIP_HBHCCDOB_HBHCMXPT_HBHCBEDM_HBHCLREQ_HBHCOPEN_HBHCCLOS_HBHCS101
+5 QUIT
+6 ;
PARENT ;
+1 ;HBH*1.0*32 retrieve parent site
+2 ;If a MFH is added/edited after the install of HBH*1.0*32,
+3 ;a parent site must be defined for the MFH.
+4 ;For multidivisional sites, if parent sites were added/edited
+5 ;between the time of last AITC transmission and install of
+6 ;HBH*1.0*32, the sites will generate HBHC Medical Foster Home Errors
+7 ;and will need to be edited to add a parent site.
+8 NEW HBHCPRNT
+9 SET HBHCHOSPX=""
+10 SET HBHCPRNT=$PIECE($GET(^HBHC(633.2,HBHCDFN,13)),"^")
+11 ;If site has only one parent site defined, use that site.
+12 IF HBHCPRNT=""
IF $PIECE(^HBHC(631.9,1,1,0),"^",4)=1
Begin DoDot:1
+13 SET HBHCPRNT=$ORDER(^HBHC(631.9,1,1,"B",""))
End DoDot:1
+14 IF HBHCPRNT]""
Begin DoDot:1
+15 ;retrieve institution file pointer for the division
+16 SET HBHCPRNT=$PIECE(^DG(40.8,HBHCPRNT,0),"^",7)
+17 ;retrieve station number
+18 SET HBHCHOSPX=$PIECE($GET(^DIC(4,+HBHCPRNT,99)),"^")
+19 IF HBHCHOSPX]""
IF $LENGTH(HBHCHOSPX)'=7
SET HBHCHOSPX=HBHCHOSPX_$EXTRACT(HBHCSP4,1,(7-($LENGTH(HBHCHOSPX))))
End DoDot:1
+20 ;If this is a multi-divisional site and the MFH does not have a parent site defined,
+21 ;generate error.
+22 IF HBHCHOSPX=""
SET HBHCDR=HBHCDR_"35;"
+23 ;end of HBH*1.0*32
+24 QUIT
+25 ;
TRANS ; Set node in ^HBHC(634) transmit file & flag record as 'F" (filed for transmit) in ^HBHC(633.2)
+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(633.2,HBHCDFN,12):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if '$TEST
QUIT
if HBHCXMT7]""
KILL ^HBHC(633.2,"AC",HBHCXMT7,HBHCDFN)
+4 SET $PIECE(^HBHC(633.2,HBHCDFN,12),U)="F"
SET ^HBHC(633.2,"AC","F",HBHCDFN)=""
SET $PIECE(^HBHC(633.2,HBHCDFN,12),U,2)=HBHCCDTS
LOCK -^HBHC(633.2,HBHCDFN,12)
+5 QUIT
ERROR ; Set node in ^HBHC(634.7) if data is incomplete
+1 LOCK +^HBHC(634.7,0):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if '$TEST
QUIT
SET HBHCNDX2=$PIECE(^HBHC(634.7,0),U,3)+1
SET $PIECE(^HBHC(634.7,0),U,3)=HBHCNDX2
SET $PIECE(^HBHC(634.7,0),U,4)=$PIECE(^HBHC(634.7,0),U,4)+1
LOCK -^HBHC(634.7,0)
+2 SET ^HBHC(634.7,HBHCNDX2,0)=HBHCDFN
SET ^HBHC(634.7,HBHCNDX2,1)=HBHCDR
SET ^HBHC(634.7,"B",HBHCDFN,HBHCNDX2)=""
+3 QUIT
