Routine: HBHCR15A

HBHCR15A ;LR VAMC(IRMS)/MJT-HBHC rpt using file 634.6, user selects date/forms from last 12 transmit batchs, fields: form#, pat name, last 4, form date, + action on form 3, prov #, & prov name on visits, & Adm or D/C on form 6 ;2/5/98

 ;;1.0;HOSPITAL BASED HOME CARE;**6,8,9,13,15,24**;NOV 01, 1993;Build 201

 ; Medical Foster Home (MFH) recs are only included if MFH Site; sorted alphabetically by MFH Name & includes Form # & Opened Date

 ; Calls HBHCR15B

 ; Report can also be generated by Transmit File option [HBHCXMT] if default printer is defined in sys param (631.9).  If no printer defined, no report.  User selects forms to include, date is transmit date

 ; HBHCXMT calls entry points:  PROMPT2^HBHCR15B & DQ^HBHCR15A

 I '$D(^HBHC(634.6,"C")) W $C(7),!,"No transmit history data on file." H 3 Q

 I $P(^HBHC(631.9,1,0),U,6)]"" W $C(7),!,"Transmission in progress; history data being updated.  Please try again later." H 3 Q

 D PROMPT1^HBHCR15B

 G:$D(DIRUT) EXIT

 S %ZIS="Q" D ^%ZIS G:POP EXIT

 I $D(IO("Q")) S ZTRTN="DQ^HBHCR15A",ZTDESC="HBPC Transmit History Report",ZTSAVE("HBHC*")="" D ^%ZTLOAD G EXIT

DQ ; De-queue

 U IO

 S (HBHCPAGE,HBHCCNTA,HBHCCNTR,HBHCCNT4,HBHCCNT5,HBHCCNT6,HBHCCNT7)=0,$P(HBHCY,"-",81)="",HBHCCOLM=(80-(30+$L(HBHCHEAD))\2) S:HBHCCOLM'>0 HBHCCOLM=1

 S HBHCHDR=$S(HBHCDIR="S":"W ?36,""Summary""",1:"W ?31,""Last"",!?4,""#"",?8,""Patient Name"",?31,""Four"",?38,""Date""")

LOOP ; Loop thru HBHC(634.6,"C" (transmit date) cross-ref to build report

 S HBHCIEN=0 F  S HBHCIEN=$O(^HBHC(634.6,"C",HBHCXMDT,HBHCIEN)) Q:HBHCIEN'>0  S HBHCINFO=$P(^HBHC(634.6,HBHCIEN,0),U) D PROCESS

 D END^HBHCR15B

EXIT ; Exit module

 D ^%ZISC

 K DIR,DIRUT,HBHC,HBHCACTN,HBHCCC,HBHCCNT,HBHCCNTA,HBHCCNTR,HBHCCNT4,HBHCCNT5,HBHCCNT6,HBHCCNT7,HBHCCOLM,HBHCDATE,HBHCDFN,HBHCDIR,HBHCDSDT,HBHCFLG,HBHCFORM,HBHCHEAD,HBHCHDR,HBHCI,HBHCIEN,HBHCINFO,HBHCIOP,HBHCLST4,HBHCMFHS

 K HBHCNAME,HBHCPAGE,HBHCPIEN,HBHCPRV,HBHCPRVN,HBHCTDY,HBHCTIME,HBHCTYPE,HBHCXMDT,HBHCY,HBHCY0,HBHCZ,X,Y,TMP,^TMP("HBHC",$J),^TMP($J)

PROCESS ; Process records

 S (HBHCACTN,HBHCPRV)="Z",(HBHCPRVN,HBHCTIME,HBHCTYPE)=""

 D:($E(HBHCINFO)=3)&((HBHCDIR=3)!(HBHCDIR="A")!(HBHCDIR="S")) FORM3

 D:($E(HBHCINFO)=4)&((HBHCDIR=4)!(HBHCDIR="A")!(HBHCDIR="S")) FORM4

 D:($E(HBHCINFO)=5)&((HBHCDIR=5)!(HBHCDIR="A")!(HBHCDIR="S")) FORM5

 D:($E(HBHCINFO)=6)&((HBHCDIR=6)!(HBHCDIR="A")!(HBHCDIR="S")) FORM6

 I $D(HBHCMFHS) D:($E(HBHCINFO)=7)&((HBHCDIR=7)!(HBHCDIR="A")!(HBHCDIR="S")) FORM7

FORM3 ; Process Form 3 (Admission) records

 S HBHCDATE=$E(HBHCINFO,18,25)

 S:$E(HBHCINFO,55)=1 HBHCCNTA=HBHCCNTA+1,HBHCACTN="Admit"

 S:$E(HBHCINFO,55)=2 HBHCCNTR=HBHCCNTR+1,HBHCACTN="Reject"

 Q:HBHCDIR="S"

 S HBHCFORM="A"

 S HBHCDFN="" F  S HBHCDFN=$O(^DPT("SSN",$E(HBHCINFO,9,17),HBHCDFN)) Q:HBHCDFN=""  S HBHCNAME=$E($P(^DPT(HBHCDFN,0),U),1,20)

 S HBHCLST4=$E(HBHCINFO,14,17)

 D SET

FORM4 ; Process Form 4 (Visit) records

 S HBHCCNT4=HBHCCNT4+1

 S HBHCFORM="V"

 S HBHCDFN="" F  S HBHCDFN=$O(^DPT("SSN",$E(HBHCINFO,9,17),HBHCDFN)) Q:HBHCDFN=""  S HBHCNAME=$E($P(^DPT(HBHCDFN,0),U),1,20)

 S HBHCLST4=$E(HBHCINFO,14,17)

 S HBHCDATE=$E(HBHCINFO,18,25)

 S HBHCTIME=$E(HBHCINFO,26,27)_":"_$E(HBHCINFO,28,29)

 S HBHCPRVN=+$E(HBHCINFO,30,33)

 S (HBHCFLG,HBHCPIEN)=0 F  S HBHCPIEN=$O(^HBHC(631.4,"B",HBHCPRVN,HBHCPIEN)) Q:HBHCPIEN'>0  D NAME

 D SET

NAME ; Form 4 Name

 I HBHCFLG=1 S HBHCPRV="**  Duplicate Prov #" Q

 S HBHCFLG=1,HBHCPRV=$E($P(^VA(200,$P(^HBHC(631.4,HBHCPIEN,0),U,2),0),U),1,20)

FORM5 ; Process Form 5 (Discharge) records

 S HBHCCNT5=HBHCCNT5+1

 Q:HBHCDIR="S"

 S HBHCFORM="D"

 S HBHCDFN="" F  S HBHCDFN=$O(^DPT("SSN",$E(HBHCINFO,9,17),HBHCDFN)) Q:HBHCDFN=""  S HBHCNAME=$E($P(^DPT(HBHCDFN,0),U),1,20)

 S HBHCLST4=$E(HBHCINFO,14,17)

 S HBHCDATE=$E(HBHCINFO,18,25)

 D SET

FORM6 ; Process Form 6 (Correction) records

 S HBHCCNT6=HBHCCNT6+1

 Q:HBHCDIR="S"

 S HBHCFORM=6

 S HBHCDFN="" F  S HBHCDFN=$O(^DPT("SSN",$E(HBHCINFO,9,17),HBHCDFN)) Q:HBHCDFN=""  S HBHCNAME=$E($P(^DPT(HBHCDFN,0),U),1,20)

 S HBHCLST4=$E(HBHCINFO,14,17)

 S HBHCDSDT=$TR($E(HBHCINFO,56,63)," ","")

 ; Use Discharge date if exists, otherwise use Admission date

 S HBHCDATE=$S(HBHCDSDT]"":HBHCDSDT,1:$E(HBHCINFO,18,25))

 S HBHCTYPE=$S(HBHCDSDT]"":"Discharge",1:"Evaluation/Admission")

 D SET

FORM7 ; Process Form 7 Medical Foster Home (MFH) records

 S HBHCCNT7=HBHCCNT7+1

 Q:HBHCDIR="S"

 S HBHCFORM="Z"

 S HBHCNAME=$E(HBHCINFO,9,38)

 S HBHCDATE=$E(HBHCINFO,84,91)

 S HBHCLST4=9999

 D SET

SET ; Set TMP node

 ; By design, records are processed/printed in the following order by form number:  6, 3 (A), 5 (D), 4 (V), & 7 (Z)

 S:HBHCDIR'="S" ^TMP("HBHC",$J,HBHCFORM,HBHCACTN,HBHCNAME,HBHCLST4,HBHCDATE,HBHCPRV,HBHCIEN)=HBHCPRVN_U_HBHCTYPE_U_HBHCTIME

 S:HBHCFORM="V" ^TMP($J,HBHCNAME,HBHCLST4,HBHCDATE_HBHCTIME,HBHCPRV)=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCR15A   4859     printed  Mar 13, 2025@21:03:01                                                                                                                                                                                                    Page 2

HBHCR15A  ;LR VAMC(IRMS)/MJT-HBHC rpt using file 634.6, user selects date/forms from last 12 transmit batchs, fields: form#, pat name, last 4, form date, + action on form 3, prov #, & prov name on visits, & Adm or D/C on form 6 ;2/5/98

 +1       ;;1.0;HOSPITAL BASED HOME CARE;**6,8,9,13,15,24**;NOV 01, 1993;Build 201

 +2       ; Medical Foster Home (MFH) recs are only included if MFH Site; sorted alphabetically by MFH Name & includes Form # & Opened Date

 +3       ; Calls HBHCR15B

 +4       ; Report can also be generated by Transmit File option [HBHCXMT] if default printer is defined in sys param (631.9).  If no printer defined, no report.  User selects forms to include, date is transmit date

 +5       ; HBHCXMT calls entry points:  PROMPT2^HBHCR15B & DQ^HBHCR15A

 +6        IF '$DATA(^HBHC(634.6,"C"))

               WRITE $CHAR(7),!,"No transmit history data on file."

               HANG 3

               QUIT

 +7        IF $PIECE(^HBHC(631.9,1,0),U,6)]""

               WRITE $CHAR(7),!,"Transmission in progress; history data being updated.  Please try again later."

               HANG 3

               QUIT

 +8        DO PROMPT1^HBHCR15B

 +9        if $DATA(DIRUT)

               GOTO EXIT

 +10       SET %ZIS="Q"

           DO ^%ZIS

           if POP

               GOTO EXIT

 +11       IF $DATA(IO("Q"))

               SET ZTRTN="DQ^HBHCR15A"

               SET ZTDESC="HBPC Transmit History Report"

               SET ZTSAVE("HBHC*")=""

               DO ^%ZTLOAD

               GOTO EXIT

DQ        ; De-queue

 +1        USE IO

 +2        SET (HBHCPAGE,HBHCCNTA,HBHCCNTR,HBHCCNT4,HBHCCNT5,HBHCCNT6,HBHCCNT7)=0

           SET $PIECE(HBHCY,"-",81)=""

           SET HBHCCOLM=(80-(30+$LENGTH(HBHCHEAD))\2)

           if HBHCCOLM'>0

               SET HBHCCOLM=1

 +3        SET HBHCHDR=$SELECT(HBHCDIR="S":"W ?36,""Summary""",1:"W ?31,""Last"",!?4,""#"",?8,""Patient Name"",?31,""Four"",?38,""Date""")

LOOP      ; Loop thru HBHC(634.6,"C" (transmit date) cross-ref to build report

 +1        SET HBHCIEN=0

FOR

               SET HBHCIEN=$ORDER(^HBHC(634.6,"C",HBHCXMDT,HBHCIEN))

               if HBHCIEN'>0

                   QUIT

               SET HBHCINFO=$PIECE(^HBHC(634.6,HBHCIEN,0),U)

               DO PROCESS

 +2        DO END^HBHCR15B

EXIT      ; Exit module

 +1        DO ^%ZISC

 +2        KILL DIR,DIRUT,HBHC,HBHCACTN,HBHCCC,HBHCCNT,HBHCCNTA,HBHCCNTR,HBHCCNT4,HBHCCNT5,HBHCCNT6,HBHCCNT7,HBHCCOLM,HBHCDATE,HBHCDFN,HBHCDIR,HBHCDSDT,HBHCFLG,HBHCFORM,HBHCHEAD,HBHCHDR,HBHCI,HBHCIEN,HBHCINFO,HBHCIOP,HBHCLST4,HBHCMFHS

 +3        KILL HBHCNAME,HBHCPAGE,HBHCPIEN,HBHCPRV,HBHCPRVN,HBHCTDY,HBHCTIME,HBHCTYPE,HBHCXMDT,HBHCY,HBHCY0,HBHCZ,X,Y,TMP,^TMP("HBHC",$JOB),^TMP($JOB)

 +4        QUIT

PROCESS   ; Process records

 +1        SET (HBHCACTN,HBHCPRV)="Z"

           SET (HBHCPRVN,HBHCTIME,HBHCTYPE)=""

 +2        if ($EXTRACT(HBHCINFO)=3)&((HBHCDIR=3)!(HBHCDIR="A")!(HBHCDIR="S"))

               DO FORM3

 +3        if ($EXTRACT(HBHCINFO)=4)&((HBHCDIR=4)!(HBHCDIR="A")!(HBHCDIR="S"))

               DO FORM4

 +4        if ($EXTRACT(HBHCINFO)=5)&((HBHCDIR=5)!(HBHCDIR="A")!(HBHCDIR="S"))

               DO FORM5

 +5        if ($EXTRACT(HBHCINFO)=6)&((HBHCDIR=6)!(HBHCDIR="A")!(HBHCDIR="S"))

               DO FORM6

 +6        IF $DATA(HBHCMFHS)

               if ($EXTRACT(HBHCINFO)=7)&((HBHCDIR=7)!(HBHCDIR="A")!(HBHCDIR="S"))

                   DO FORM7

 +7        QUIT

FORM3     ; Process Form 3 (Admission) records

 +1        SET HBHCDATE=$EXTRACT(HBHCINFO,18,25)

 +2        if $EXTRACT(HBHCINFO,55)=1

               SET HBHCCNTA=HBHCCNTA+1

               SET HBHCACTN="Admit"

 +3        if $EXTRACT(HBHCINFO,55)=2

               SET HBHCCNTR=HBHCCNTR+1

               SET HBHCACTN="Reject"

 +4        if HBHCDIR="S"

               QUIT

 +5        SET HBHCFORM="A"

 +6        SET HBHCDFN=""

FOR

               SET HBHCDFN=$ORDER(^DPT("SSN",$EXTRACT(HBHCINFO,9,17),HBHCDFN))

               if HBHCDFN=""

                   QUIT

               SET HBHCNAME=$EXTRACT($PIECE(^DPT(HBHCDFN,0),U),1,20)

 +7        SET HBHCLST4=$EXTRACT(HBHCINFO,14,17)

 +8        DO SET

 +9        QUIT

FORM4     ; Process Form 4 (Visit) records

 +1        SET HBHCCNT4=HBHCCNT4+1

 +2        SET HBHCFORM="V"

 +3        SET HBHCDFN=""

FOR

               SET HBHCDFN=$ORDER(^DPT("SSN",$EXTRACT(HBHCINFO,9,17),HBHCDFN))

               if HBHCDFN=""

                   QUIT

               SET HBHCNAME=$EXTRACT($PIECE(^DPT(HBHCDFN,0),U),1,20)

 +4        SET HBHCLST4=$EXTRACT(HBHCINFO,14,17)

 +5        SET HBHCDATE=$EXTRACT(HBHCINFO,18,25)

 +6        SET HBHCTIME=$EXTRACT(HBHCINFO,26,27)_":"_$EXTRACT(HBHCINFO,28,29)

 +7        SET HBHCPRVN=+$EXTRACT(HBHCINFO,30,33)

 +8        SET (HBHCFLG,HBHCPIEN)=0

FOR

               SET HBHCPIEN=$ORDER(^HBHC(631.4,"B",HBHCPRVN,HBHCPIEN))

               if HBHCPIEN'>0

                   QUIT

               DO NAME

 +9        DO SET

 +10       QUIT

NAME      ; Form 4 Name

 +1        IF HBHCFLG=1

               SET HBHCPRV="**  Duplicate Prov #"

               QUIT

 +2        SET HBHCFLG=1

           SET HBHCPRV=$EXTRACT($PIECE(^VA(200,$PIECE(^HBHC(631.4,HBHCPIEN,0),U,2),0),U),1,20)

 +3        QUIT

FORM5     ; Process Form 5 (Discharge) records

 +1        SET HBHCCNT5=HBHCCNT5+1

 +2        if HBHCDIR="S"

               QUIT

 +3        SET HBHCFORM="D"

 +4        SET HBHCDFN=""

FOR

               SET HBHCDFN=$ORDER(^DPT("SSN",$EXTRACT(HBHCINFO,9,17),HBHCDFN))

               if HBHCDFN=""

                   QUIT

               SET HBHCNAME=$EXTRACT($PIECE(^DPT(HBHCDFN,0),U),1,20)

 +5        SET HBHCLST4=$EXTRACT(HBHCINFO,14,17)

 +6        SET HBHCDATE=$EXTRACT(HBHCINFO,18,25)

 +7        DO SET

 +8        QUIT

FORM6     ; Process Form 6 (Correction) records

 +1        SET HBHCCNT6=HBHCCNT6+1

 +2        if HBHCDIR="S"

               QUIT

 +3        SET HBHCFORM=6

 +4        SET HBHCDFN=""

FOR

               SET HBHCDFN=$ORDER(^DPT("SSN",$EXTRACT(HBHCINFO,9,17),HBHCDFN))

               if HBHCDFN=""

                   QUIT

               SET HBHCNAME=$EXTRACT($PIECE(^DPT(HBHCDFN,0),U),1,20)

 +5        SET HBHCLST4=$EXTRACT(HBHCINFO,14,17)

 +6        SET HBHCDSDT=$TRANSLATE($EXTRACT(HBHCINFO,56,63)," ","")

 +7       ; Use Discharge date if exists, otherwise use Admission date

 +8        SET HBHCDATE=$SELECT(HBHCDSDT]"":HBHCDSDT,1:$EXTRACT(HBHCINFO,18,25))

 +9        SET HBHCTYPE=$SELECT(HBHCDSDT]"":"Discharge",1:"Evaluation/Admission")

 +10       DO SET

 +11       QUIT

FORM7     ; Process Form 7 Medical Foster Home (MFH) records

 +1        SET HBHCCNT7=HBHCCNT7+1

 +2        if HBHCDIR="S"

               QUIT

 +3        SET HBHCFORM="Z"

 +4        SET HBHCNAME=$EXTRACT(HBHCINFO,9,38)

 +5        SET HBHCDATE=$EXTRACT(HBHCINFO,84,91)

 +6        SET HBHCLST4=9999

 +7        DO SET

 +8        QUIT

SET       ; Set TMP node

 +1       ; By design, records are processed/printed in the following order by form number:  6, 3 (A), 5 (D), 4 (V), & 7 (Z)

 +2        if HBHCDIR'="S"

               SET ^TMP("HBHC",$JOB,HBHCFORM,HBHCACTN,HBHCNAME,HBHCLST4,HBHCDATE,HBHCPRV,HBHCIEN)=HBHCPRVN_U_HBHCTYPE_U_HBHCTIME

 +3        if HBHCFORM="V"

               SET ^TMP($JOB,HBHCNAME,HBHCLST4,HBHCDATE_HBHCTIME,HBHCPRV)=""

 +4        QUIT

HBHCR15A.m