Routine: HBHCXMA

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

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

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

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

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

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)

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)

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

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

HBHCXMA.m