Routine: HBHCXMD

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

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

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)

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)=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCXMD   5073     printed  Feb 18, 2025@23:25:21                                                                                                                                                                                                     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

HBHCXMD.m