HBHCXMD ;LR VAMC(IRMS)/MJT - HBHC Discharge Transmissions; May 11, 2021@17:45
;;1.0;HOSPITAL BASED HOME CARE;**4,6,9,10,13,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^HBHCXMD1
LOOP ; Loop thru ^HBHC(631) "AF","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.3) => Discharge Error(s) file
S HBHCDFN="" F S HBHCDFN=$O(^HBHC(631,"AF","N",HBHCDFN)) Q:HBHCDFN="" S HBHCFLG=1,HBHCCONT=0 D SETNODE I HBHCFLG D:HBHCCONT TRANS D:'HBHCCONT ERROR
EXIT ; Exit module
D EXIT^HBHCXMD1
Q
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.3) (Discharge Error(s))
S HBHCNOD0=^HBHC(631,HBHCDFN,0),HBHCNOD1=$G(^HBHC(631,HBHCDFN,1)),HBHCXMT5=$P(HBHCNOD1,U,18)
; Quit if discharge date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
I $P(HBHCNOD0,U,40)>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 (HBHCDR1,HBHCDR2,HBHCDR3,HBHCDR4,HBHCDR5)=""
S HBHCTFLG=0 S:($P(HBHCNOD0,U,45)]"")!($P(HBHCNOD0,U,46)]"") HBHCTFLG=1
S HBHCDFLG=0 F HBHCL=47:1:55 Q:HBHCDFLG S:$P(HBHCNOD0,U,HBHCL)]"" HBHCDFLG=1
I HBHCNOD1]"" F HBHCM=1:1:10 Q:HBHCDFLG S:$P(HBHCNOD1,U,HBHCM)]"" HBHCDFLG=1
S HBHCADDT=$S($P(HBHCNOD0,U,18)]"":$E($P(HBHCNOD0,U,18),4,5)_$E($P(HBHCNOD0,U,18),6,7)_(1700+$E($P(HBHCNOD0,U,18),1,3)),$P(HBHCNOD0,U,2)]"":$E($P(HBHCNOD0,U,2),4,5)_$E($P(HBHCNOD0,U,2),6,7)_(1700+$E($P(HBHCNOD0,U,2),1,3)),1:"")
S HBHCDSDT=$S($P(HBHCNOD0,U,40)]"":$E($P(HBHCNOD0,U,40),4,5)_$E($P(HBHCNOD0,U,40),6,7)_(1700+$E($P(HBHCNOD0,U,40),1,3)),1:"")
K HBHCDDTA F HBHCI=1:1:4 S HBHCFLD=$P(HBHCFLD1,U,HBHCI) S:HBHCFLD]"" HBHCDDTA=1 S @HBHCFLD=$S($P(HBHCNOD0,U,HBHCI+40)]"":$P(HBHCNOD0,U,HBHCI+40),1:"") D:@HBHCFLD="" DFLT1^HBHCXMD1
S:((HBHCDSDT="")&((HBHCDFLG=1)!(HBHCTFLG=1)!($D(HBHCDDTA)))) HBHCDR1="39;"_HBHCDR1
Q:HBHCSTAT=""
I HBHCSTAT=4 I (HBHCDFLG)!(HBHCTFLG) S HBHCDR1=HBHCDR1_"43;" Q
I (HBHC359[(U_HBHCSTAT_U))&(HBHCTFLG) S HBHCDR1=HBHCDR1_"43;" Q
I HBHCNOD1]"" I ($P(HBHCNOD1,U,15)]"")&(HBHCSTAT'=4) S HBHCDR1=HBHCDR1_"43;" Q
S HBHCDEST=$S($P(HBHCNOD0,U,45)]"":$P(HBHCNOD0,U,45),1:HBHCSP1) S:(HBHC12[(U_HBHCSTAT_U))&(HBHCDEST=HBHCSP1) HBHCDR1=HBHCDR1_"44;"
S HBHCAGCY=$S($P(HBHCNOD0,U,46)]"":$P(HBHCNOD0,U,46),1:HBHCSP1) S:(HBHC12[(U_HBHCSTAT_U))&(HBHCAGCY=HBHCSP1) HBHCDR1=HBHCDR1_"45;"
I $P(HBHCNOD0,U,47)]"" D I 1
. N DXCODE
. S DXCODE=$$CODEC^ICDEX(80,$P(HBHCNOD0,U,47))
. S HBHCICDD=$P(DXCODE,".",1)_$P(DXCODE,".",2)
E S HBHCICDD=HBHCSP8
S:$L(HBHCICDD)<8 HBHCICDD=HBHCICDD_$J("",8-$L(HBHCICDD)) D:(HBHCSTAT'=4)&(HBHCICDD=HBHCSP8) ICDDFLT^HBHCXMD1
F HBHCJ=1:1:8 S HBHCFLD=$P(HBHCFLD2,U,HBHCJ) S @HBHCFLD=$S($P(HBHCNOD0,U,HBHCJ+47)]"":$P(HBHCNOD0,U,HBHCJ+47),1:HBHCSP1) D:(HBHCSTAT'=4)&(@HBHCFLD=HBHCSP1) DFLT2^HBHCXMD1
F HBHCK=1:1:10 S HBHCFLD=$P(HBHCFLD3,U,HBHCK) S @HBHCFLD=$S($P(HBHCNOD1,U,HBHCK)]"":$P(HBHCNOD1,U,HBHCK),1:HBHCSP1) D:(HBHCSTAT'=4)&(@HBHCFLD=HBHCSP1) DFLT3^HBHCXMD1
Q:(HBHCADDT="")!(HBHCDR1]"")!(HBHCDR2]"")!(HBHCDR3]"")!(HBHCDR4]"")!(HBHCDR5]"")
S HBHCCONT=1
S HBHCNAME=$E($P(^DPT($P(HBHCNOD0,U),0),U),1,5) S:$L(HBHCNAME)<HBHCLNTH HBHCNAME=HBHCNAME_$J("",HBHCLNTH-$L(HBHCNAME))
S HBHCSSN=$P(^DPT($P(HBHCNOD0,U),0),U,9)
;HBH*1.0*32: replace HBHCHOSP with HBHCHOSPX
S HBHCREC=HBHCFORM_HBHCHOSPX_HBHCSSN_HBHCDSDT_HBHCELGD_HBHCMARD_HBHCLIVD_HBHCSTAT_HBHCDEST_HBHCAGCY_HBHCADDT_HBHCNAME_HBHCICDD_HBHCVISD_HBHCHERD_HBHCEXCD_HBHCRECD_HBHCBTHD_HBHCDRSD_HBHCTLTD_HBHCTRND_HBHCEATD_HBHCWLKD_HBHCBWLD_HBHCBLDD
S HBHCREC=HBHCREC_HBHCMOBD_HBHCADTD_HBHCBHVD_HBHCDSOD_HBHCMODD_HBHCLMTD_HBHCS129
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:HBHCXMT5]"" ^HBHC(631,"AF",HBHCXMT5,HBHCDFN) S $P(^HBHC(631,HBHCDFN,1),U,18)="F",^HBHC(631,"AF","F",HBHCDFN)="",$P(^HBHC(631,HBHCDFN,1),U,22)=HBHCTDY L -^HBHC(631,HBHCDFN,1)
Q
ERROR ; Set node in ^HBHC(634.3) if data is incomplete or proper fields invalid for 'Discharge Status'
L +^HBHC(634.3,0):$S($D(DILOCKTM):DILOCKTM,1:3) Q:'$T S HBHCNDX2=$P(^HBHC(634.3,0),U,3)+1,$P(^HBHC(634.3,0),U,3)=HBHCNDX2,$P(^HBHC(634.3,0),U,4)=$P(^HBHC(634.3,0),U,4)+1 L -^HBHC(634.3,0)
S ^HBHC(634.3,HBHCNDX2,0)=$P(HBHCNOD0,U)_U_HBHCDFN
S:HBHCDR1]"" ^HBHC(634.3,HBHCNDX2,1)=HBHCDR1
S:HBHCDR2]"" ^HBHC(634.3,HBHCNDX2,2)=HBHCDR2
S:HBHCDR3]"" ^HBHC(634.3,HBHCNDX2,3)=HBHCDR3
S:HBHCDR4]"" ^HBHC(634.3,HBHCNDX2,4)=HBHCDR4
S:HBHCDR5]"" ^HBHC(634.3,HBHCNDX2,5)=HBHCDR5
S ^HBHC(634.3,"B",$P(HBHCNOD0,U),HBHCNDX2)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCXMD 5073 printed Dec 13, 2024@01:58:57 Page 2
HBHCXMD ;LR VAMC(IRMS)/MJT - HBHC Discharge Transmissions; May 11, 2021@17:45
+1 ;;1.0;HOSPITAL BASED HOME CARE;**4,6,9,10,13,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^HBHCXMD1
LOOP ; Loop thru ^HBHC(631) "AF","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.3) => Discharge Error(s) file
+1 SET HBHCDFN=""
FOR
SET HBHCDFN=$ORDER(^HBHC(631,"AF","N",HBHCDFN))
if HBHCDFN=""
QUIT
SET HBHCFLG=1
SET HBHCCONT=0
DO SETNODE
IF HBHCFLG
if HBHCCONT
DO TRANS
if 'HBHCCONT
DO ERROR
EXIT ; Exit module
+1 DO EXIT^HBHCXMD1
+2 QUIT
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.3) (Discharge Error(s))
+1 SET HBHCNOD0=^HBHC(631,HBHCDFN,0)
SET HBHCNOD1=$GET(^HBHC(631,HBHCDFN,1))
SET HBHCXMT5=$PIECE(HBHCNOD1,U,18)
+2 ; Quit if discharge date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
+3 IF $PIECE(HBHCNOD0,U,40)>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 (HBHCDR1,HBHCDR2,HBHCDR3,HBHCDR4,HBHCDR5)=""
+12 SET HBHCTFLG=0
if ($PIECE(HBHCNOD0,U,45)]"")!($PIECE(HBHCNOD0,U,46)]"")
SET HBHCTFLG=1
+13 SET HBHCDFLG=0
FOR HBHCL=47:1:55
if HBHCDFLG
QUIT
if $PIECE(HBHCNOD0,U,HBHCL)]""
SET HBHCDFLG=1
+14 IF HBHCNOD1]""
FOR HBHCM=1:1:10
if HBHCDFLG
QUIT
if $PIECE(HBHCNOD1,U,HBHCM)]""
SET HBHCDFLG=1
+15 SET HBHCADDT=$SELECT($PIECE(HBHCNOD0,U,18)]"":$EXTRACT($PIECE(HBHCNOD0,U,18),4,5)_$EXTRACT(...
... $PIECE(HBHCNOD0,U,18),6,7)_(1700+$EXTRACT($PIECE(HBHCNOD0,U,18),1,3)),$PIECE(HBHCNOD0,U,2)]"":$EXTRACT($PIECE(HBHCNOD0,U,2),4,5)_$EXTRACT($PIECE(HBHCNOD0,U,2),6,7)_(1700+$EXTRACT($PIECE(HBHCNOD0,U,2),1,3)),1:"")
+16 SET HBHCDSDT=$SELECT($PIECE(HBHCNOD0,U,40)]"":$EXTRACT($PIECE(HBHCNOD0,U,40),4,5)_$EXTRACT($PIECE(HBHCNOD0,U,40),6,7)_(1700+$EXTRACT($PIECE(HBHCNOD0,U,40),1,3)),1:"")
+17 KILL HBHCDDTA
FOR HBHCI=1:1:4
SET HBHCFLD=$PIECE(HBHCFLD1,U,HBHCI)
if HBHCFLD]""
SET HBHCDDTA=1
SET @HBHCFLD=$SELECT($PIECE(HBHCNOD0,U,HBHCI+40)]"":$PIECE(HBHCNOD0,U,HBHCI+40),1:"")
if @HBHCFLD=""
DO DFLT1^HBHCXMD1
+18 if ((HBHCDSDT="")&((HBHCDFLG=1)!(HBHCTFLG=1)!($DATA(HBHCDDTA))))
SET HBHCDR1="39;"_HBHCDR1
+19 if HBHCSTAT=""
QUIT
+20 IF HBHCSTAT=4
IF (HBHCDFLG)!(HBHCTFLG)
SET HBHCDR1=HBHCDR1_"43;"
QUIT
+21 IF (HBHC359[(U_HBHCSTAT_U))&(HBHCTFLG)
SET HBHCDR1=HBHCDR1_"43;"
QUIT
+22 IF HBHCNOD1]""
IF ($PIECE(HBHCNOD1,U,15)]"")&(HBHCSTAT'=4)
SET HBHCDR1=HBHCDR1_"43;"
QUIT
+23 SET HBHCDEST=$SELECT($PIECE(HBHCNOD0,U,45)]"":$PIECE(HBHCNOD0,U,45),1:HBHCSP1)
if (HBHC12[(U_HBHCSTAT_U))&(HBHCDEST=HBHCSP1)
SET HBHCDR1=HBHCDR1_"44;"
+24 SET HBHCAGCY=$SELECT($PIECE(HBHCNOD0,U,46)]"":$PIECE(HBHCNOD0,U,46),1:HBHCSP1)
if (HBHC12[(U_HBHCSTAT_U))&(HBHCAGCY=HBHCSP1)
SET HBHCDR1=HBHCDR1_"45;"
+25 IF $PIECE(HBHCNOD0,U,47)]""
Begin DoDot:1
+26 NEW DXCODE
+27 SET DXCODE=$$CODEC^ICDEX(80,$PIECE(HBHCNOD0,U,47))
+28 SET HBHCICDD=$PIECE(DXCODE,".",1)_$PIECE(DXCODE,".",2)
End DoDot:1
IF 1
+29 IF '$TEST
SET HBHCICDD=HBHCSP8
+30 if $LENGTH(HBHCICDD)<8
SET HBHCICDD=HBHCICDD_$JUSTIFY("",8-$LENGTH(HBHCICDD))
if (HBHCSTAT'=4)&(HBHCICDD=HBHCSP8)
DO ICDDFLT^HBHCXMD1
+31 FOR HBHCJ=1:1:8
SET HBHCFLD=$PIECE(HBHCFLD2,U,HBHCJ)
SET @HBHCFLD=$SELECT($PIECE(HBHCNOD0,U,HBHCJ+47)]"":$PIECE(HBHCNOD0,U,HBHCJ+47),1:HBHCSP1)
if (HBHCSTAT'=4)&(@HBHCFLD=HBHCSP1)
DO DFLT2^HBHCXMD1
+32 FOR HBHCK=1:1:10
SET HBHCFLD=$PIECE(HBHCFLD3,U,HBHCK)
SET @HBHCFLD=$SELECT($PIECE(HBHCNOD1,U,HBHCK)]"":$PIECE(HBHCNOD1,U,HBHCK),1:HBHCSP1)
if (HBHCSTAT'=4)&(@HBHCFLD=HBHCSP1)
DO DFLT3^HBHCXMD1
+33 if (HBHCADDT="")!(HBHCDR1]"")!(HBHCDR2]"")!(HBHCDR3]"")!(HBHCDR4]"")!(HBHCDR5]"")
QUIT
+34 SET HBHCCONT=1
+35 SET HBHCNAME=$EXTRACT($PIECE(^DPT($PIECE(HBHCNOD0,U),0),U),1,5)
if $LENGTH(HBHCNAME)<HBHCLNTH
SET HBHCNAME=HBHCNAME_$JUSTIFY("",HBHCLNTH-$LENGTH(HBHCNAME))
+36 SET HBHCSSN=$PIECE(^DPT($PIECE(HBHCNOD0,U),0),U,9)
+37 ;HBH*1.0*32: replace HBHCHOSP with HBHCHOSPX
+38 SET HBHCREC=HBHCFORM_HBHCHOSPX_HBHCSSN_HBHCDSDT_HBHCELGD_HBHCMARD_HBHCLIVD_HBHCSTAT_HBHCDEST_HBHCAGCY_HBHCADDT_HBHCNAME_HBHCICDD_HBHCVISD_HBHCHERD_HBHCEXCD_HBHCRECD_HBHCBTHD_HBHCDRSD_HBHCTLTD_HBHCTRND_HBHCEATD_HBHCWLKD_HBHCBWLD_HBHCBLDD
+39 SET HBHCREC=HBHCREC_HBHCMOBD_HBHCADTD_HBHCBHVD_HBHCDSOD_HBHCMODD_HBHCLMTD_HBHCS129
+40 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 HBHCXMT5]""
KILL ^HBHC(631,"AF",HBHCXMT5,HBHCDFN)
SET $PIECE(^HBHC(631,HBHCDFN,1),U,18)="F"
SET ^HBHC(631,"AF","F",HBHCDFN)=""
SET $PIECE(^HBHC(631,HBHCDFN,1),U,22)=HBHCTDY
LOCK -^HBHC(631,HBHCDFN,1)
+4 QUIT
ERROR ; Set node in ^HBHC(634.3) if data is incomplete or proper fields invalid for 'Discharge Status'
+1 LOCK +^HBHC(634.3,0):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if '$TEST
QUIT
SET HBHCNDX2=$PIECE(^HBHC(634.3,0),U,3)+1
SET $PIECE(^HBHC(634.3,0),U,3)=HBHCNDX2
SET $PIECE(^HBHC(634.3,0),U,4)=$PIECE(^HBHC(634.3,0),U,4)+1
LOCK -^HBHC(634.3,0)
+2 SET ^HBHC(634.3,HBHCNDX2,0)=$PIECE(HBHCNOD0,U)_U_HBHCDFN
+3 if HBHCDR1]""
SET ^HBHC(634.3,HBHCNDX2,1)=HBHCDR1
+4 if HBHCDR2]""
SET ^HBHC(634.3,HBHCNDX2,2)=HBHCDR2
+5 if HBHCDR3]""
SET ^HBHC(634.3,HBHCNDX2,3)=HBHCDR3
+6 if HBHCDR4]""
SET ^HBHC(634.3,HBHCNDX2,4)=HBHCDR4
+7 if HBHCDR5]""
SET ^HBHC(634.3,HBHCNDX2,5)=HBHCDR5
+8 SET ^HBHC(634.3,"B",$PIECE(HBHCNOD0,U),HBHCNDX2)=""
+9 QUIT
