Routine: HBHCR19A

HBHCR19A ;LR VAMC(IRMS)/MJT - HBHC file 632 rpt, DX info by date range, sorted by DX category, then pt name, includes: name, last four, DX (code & text), w/category subtotals & grand total, calls HBHCR19B & DX^HBHCUTL3 ;12/21/05 3:39pm

 ;;1.0;HOSPITAL BASED HOME CARE;**8,14,22,25**;NOV 01, 1993;Build 45

 ; This routine references the following supported ICRs:

 ; 5747    $$CODEC^ICDEX

 ; 5747    $$CSI^ICDEX

 ; 5681    $$CODELIST^LEX10CS

 ; 5679    $$IMPDATE^LEXU

 ;******************************************************************************

 ;******************************************************************************

 ;                       --- ROUTINE MODIFICATION LOG ---

 ;PKG/PATCH    DATE        DEVELOPER    MODIFICATION

 ;-----------  ----------  -----------  ----------------------------------------

 ;HBH*1.0*25   FEB  2012   K GUPTA      Support for ICD-10 Coding System

 ;******************************************************************************

 ;******************************************************************************

 D START^HBHCUTL

 G:(HBHCBEG1=-1)!(HBHCEND1=-1) EXIT

 K ^TMP($J)

PROMPT1 ; Prompt user for whether to include all ICD Diagnosis Codes

 K DD,D0 W !!,"Do you wish to include ALL ICD Diagnosis Codes on the report" S %=2 D YN^DICN

 G:(%=-1) EXIT

 I %=1 S HBHCFLAG=1 G START2

 I %=0 W !!,"A 'Yes' response will include ALL ICD Diagnosis Codes.  A 'No' response will",!,"prompt for an individual ICD Diagnosis Code." G PROMPT1

PROMPT2 ; Prompt user for individual ICD9 Diagnosis Code

W !

 K DIR S DIR(0)="PO^80:AEMQ"

 ;filter dx codes belonging to a particular coding system based on report date range

 S DIR("S")="I ("""_$$ICDCSYS^HBHCUTL3(HBHCBEG1,HBHCEND1)_""")[("",""_$$CSI^ICDEX(80,Y)_"","")"

 D ^DIR

 G:($D(DTOUT))!($D(DUOUT)) EXIT

 G:(Y=-1) START1

 S HBHCTMP=Y

PROMPT3 ; Prompt user for whether ICD9 category is to be considered a range (e.g.  Diabetes ICD9 codes range from 250 to 250.93 (as of 8/97))

 W !!,"Do you wish to include ALL codes within category "_$P($P(HBHCTMP,U,2),".") S %=1 D YN^DICN

 G:(%=-1) START1

 I %=0 W !!,"A 'Yes' response will include ALL ICD Diagnosis Codes withing the category.",!,"A 'No' response selects the specific ICD9 Diagnosis Code." G PROMPT3

 S HBHCCAT=$P($P(HBHCTMP,U,2),".")

 N HBHCDXIEN,HBHCDXCODE,HBHCDXCSYS

 S HBHCDXIEN=$P(HBHCTMP,U,1)

 S HBHCDXCSYS=$$CSI^ICDEX("80",HBHCDXIEN)

 I %=2 D  I 1

 . S ^TMP($J,HBHCCAT,$P(HBHCTMP,U,2))=""

 . S HBHCDXCODE=$$CODEC^ICDEX(80,HBHCDXIEN)

 . Q:+HBHCDXCODE<0

 . S ^TMP($J,"B",HBHCDXCODE)=""

 E  I %=1 D  I 1  ; Setup ^TMP($J array with range of Dx

 . K ^TMP("HBHCLEXDATA",$J)

 . I +$$CODELIST^LEX10CS2(HBHCDXCSYS,HBHCCAT_".*","HBHCLEXDATA",$$IMPDATE^LEXU(HBHCDXCSYS))>0 D

 . . F I=1:1:+$G(^TMP("HBHCLEXDATA",$J,0)) D

 . . . S HBHCCATB=$G(^TMP("HBHCLEXDATA",$J,I))

 . . . Q:HBHCCATB=""

 . . . S ^TMP($J,HBHCCAT,HBHCCATB)=""

 . . . S ^TMP($J,"B",HBHCCATB)=""

 G PROMPT2

START1 ; Initialization 1

 G:'$D(^TMP($J)) EXIT

START2 ; Initialization 2

 S %ZIS="Q",HBHCCC=0 K IOP,ZTIO,ZTSAVE D ^%ZIS G:POP EXIT

 I $D(IO("Q")) S ZTRTN="DQ^HBHCR19A",ZTDESC="HBPC ICD Code/Text Report",ZTSAVE("HBHC*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD G EXIT

DQ ; De-queue

 U IO

 D INITIAL^HBHCR19B,TODAY^HBHCUTL D:IO'=IO(0)!($D(IO("S"))) HDRRANGE^HBHCUTL

 I '$D(IO("S")),(IO=IO(0)) S HBHCCC=HBHCCC+1 W @IOF D HDRRANGE^HBHCUTL

LOOP ; Loop thru ^HBHC(632,"C" (appointment date) cross-ref to build report

 S X1=HBHCBEG1,X2=-1 D C^%DTC S HBHCAPDT=X_.9999

 F  S HBHCAPDT=$O(^HBHC(632,"C",HBHCAPDT)) Q:(HBHCAPDT="")!($P(HBHCAPDT,".")>HBHCEND1)  S HBHCDFN="" F  S HBHCDFN=$O(^HBHC(632,"C",HBHCAPDT,HBHCDFN)) Q:HBHCDFN=""  S HBHCNOD0=^HBHC(632,HBHCDFN,0) D:$P(HBHCNOD0,U,7)="" PROCESS

 W:'$D(^TMP("HBHC",$J)) !!,"No data found for Date Range selected."

 I $D(^TMP("HBHC",$J)) D PRTLOOP^HBHCR19B W !!,HBHCZ,!,$$ICDTEXT^HBHCUTL3(HBHCBEG1,HBHCEND1)_" Diagnosis Categories Total:  ",HBHCTOT,!,HBHCZ

 D ENDRPT^HBHCUTL1

EXIT ; Exit module

 D EXIT^HBHCR19B

 ;SETTMP ; Set ^TMP($J

 ;S ^TMP($J,HBHCCAT,HBHCCATB)="",^TMP($J,"B",$P(^ICD9(HBHCICDP,0),U))=""

;Q

PROCESS ; Process record & build ^TMP("HBHC",$J) global

 S HBHCDPT0=^DPT($P(HBHCNOD0,U),0)

DX ; Process Diagnosis (DX), HBHCDFN must be defined prior to call, returns code plus text in local array HBHCDX

 D DX^HBHCUTL3

 S HBHCI=0 F  S HBHCI=$O(HBHCDX(HBHCI)) Q:HBHCI'>0  S HBHCDX="HBHCDX("_HBHCI_")" D:$D(HBHCFLAG) SET I '$D(HBHCFLAG) D:$D(^TMP($J,"B",$P(@HBHCDX,HBHCSP2))) SET

SET ; Set ^TMP node

 ; HBH*1*22 shortens SSN to Last 4 only for display; following full SSN left intact since used as subscript

 S ^TMP("HBHC",$J,$P(@HBHCDX,"."),$E($P(HBHCDPT0,U),1,24),$E($P(HBHCDPT0,U,9),1,3)_"-"_$E($P(HBHCDPT0,U,9),4,5)_"-"_$E($P(HBHCDPT0,U,9),6,9),@HBHCDX)=""

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

HBHCR19A  ;LR VAMC(IRMS)/MJT - HBHC file 632 rpt, DX info by date range, sorted by DX category, then pt name, includes: name, last four, DX (code & text), w/category subtotals & grand total, calls HBHCR19B & DX^HBHCUTL3 ;12/21/05 3:39pm

 +1       ;;1.0;HOSPITAL BASED HOME CARE;**8,14,22,25**;NOV 01, 1993;Build 45

 +2       ;

 +3       ; This routine references the following supported ICRs:

 +4       ; 5747    $$CODEC^ICDEX

 +5       ; 5747    $$CSI^ICDEX

 +6       ; 5681    $$CODELIST^LEX10CS

 +7       ; 5679    $$IMPDATE^LEXU

 +8       ;

 +9       ;******************************************************************************

 +10      ;******************************************************************************

 +11      ;                       --- ROUTINE MODIFICATION LOG ---

 +12      ;

 +13      ;PKG/PATCH    DATE        DEVELOPER    MODIFICATION

 +14      ;-----------  ----------  -----------  ----------------------------------------

 +15      ;HBH*1.0*25   FEB  2012   K GUPTA      Support for ICD-10 Coding System

 +16      ;******************************************************************************

 +17      ;******************************************************************************

 +18      ;

 +19       DO START^HBHCUTL

 +20       if (HBHCBEG1=-1)!(HBHCEND1=-1)

               GOTO EXIT

 +21       KILL ^TMP($JOB)

PROMPT1   ; Prompt user for whether to include all ICD Diagnosis Codes

 +1        KILL DD,D0

           WRITE !!,"Do you wish to include ALL ICD Diagnosis Codes on the report"

           SET %=2

           DO YN^DICN

 +2        if (%=-1)

               GOTO EXIT

 +3        IF %=1

               SET HBHCFLAG=1

               GOTO START2

 +4        IF %=0

               WRITE !!,"A 'Yes' response will include ALL ICD Diagnosis Codes.  A 'No' response will",!,"prompt for an individual ICD Diagnosis Code."

               GOTO PROMPT1

PROMPT2   ; Prompt user for individual ICD9 Diagnosis Code

 +1        WRITE !

 +2        KILL DIR

           SET DIR(0)="PO^80:AEMQ"

 +3       ;filter dx codes belonging to a particular coding system based on report date range

 +4        SET DIR("S")="I ("""_$$ICDCSYS^HBHCUTL3(HBHCBEG1,HBHCEND1)_""")[("",""_$$CSI^ICDEX(80,Y)_"","")"

 +5        DO ^DIR

 +6        if ($DATA(DTOUT))!($DATA(DUOUT))

               GOTO EXIT

 +7        if (Y=-1)

               GOTO START1

 +8        SET HBHCTMP=Y

PROMPT3   ; Prompt user for whether ICD9 category is to be considered a range (e.g.  Diabetes ICD9 codes range from 250 to 250.93 (as of 8/97))

 +1        WRITE !!,"Do you wish to include ALL codes within category "_$PIECE($PIECE(HBHCTMP,U,2),".")

           SET %=1

           DO YN^DICN

 +2        if (%=-1)

               GOTO START1

 +3        IF %=0

               WRITE !!,"A 'Yes' response will include ALL ICD Diagnosis Codes withing the category.",!,"A 'No' response selects the specific ICD9 Diagnosis Code."

               GOTO PROMPT3

 +4        SET HBHCCAT=$PIECE($PIECE(HBHCTMP,U,2),".")

 +5        NEW HBHCDXIEN,HBHCDXCODE,HBHCDXCSYS

 +6        SET HBHCDXIEN=$PIECE(HBHCTMP,U,1)

 +7        SET HBHCDXCSYS=$$CSI^ICDEX("80",HBHCDXIEN)

 +8        IF %=2

               Begin DoDot:1

 +9                SET ^TMP($JOB,HBHCCAT,$PIECE(HBHCTMP,U,2))=""

 +10               SET HBHCDXCODE=$$CODEC^ICDEX(80,HBHCDXIEN)

 +11               if +HBHCDXCODE<0

                       QUIT

 +12               SET ^TMP($JOB,"B",HBHCDXCODE)=""

               End DoDot:1

               IF 1

 +13      ; Setup ^TMP($J array with range of Dx

          IF '$TEST

               IF %=1

                   Begin DoDot:1

 +14                   KILL ^TMP("HBHCLEXDATA",$JOB)

 +15                   IF +$$CODELIST^LEX10CS2(HBHCDXCSYS,HBHCCAT_".*","HBHCLEXDATA",$$IMPDATE^LEXU(HBHCDXCSYS))>0

                           Begin DoDot:2

 +16                           FOR I=1:1:+$GET(^TMP("HBHCLEXDATA",$JOB,0))

                                   Begin DoDot:3

 +17                                   SET HBHCCATB=$GET(^TMP("HBHCLEXDATA",$JOB,I))

 +18                                   if HBHCCATB=""

                                           QUIT

 +19                                   SET ^TMP($JOB,HBHCCAT,HBHCCATB)=""

 +20                                   SET ^TMP($JOB,"B",HBHCCATB)=""

                                   End DoDot:3

                           End DoDot:2

                   End DoDot:1

                   IF 1

 +21       GOTO PROMPT2

START1    ; Initialization 1

 +1        if '$DATA(^TMP($JOB))

               GOTO EXIT

START2    ; Initialization 2

 +1        SET %ZIS="Q"

           SET HBHCCC=0

           KILL IOP,ZTIO,ZTSAVE

           DO ^%ZIS

           if POP

               GOTO EXIT

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

               SET ZTRTN="DQ^HBHCR19A"

               SET ZTDESC="HBPC ICD Code/Text Report"

               SET ZTSAVE("HBHC*")=""

               SET ZTSAVE("^TMP($J,")=""

               DO ^%ZTLOAD

               GOTO EXIT

DQ        ; De-queue

 +1        USE IO

 +2        DO INITIAL^HBHCR19B

           DO TODAY^HBHCUTL

           if IO'=IO(0)!($DATA(IO("S")))

               DO HDRRANGE^HBHCUTL

 +3        IF '$DATA(IO("S"))

               IF (IO=IO(0))

                   SET HBHCCC=HBHCCC+1

                   WRITE @IOF

                   DO HDRRANGE^HBHCUTL

LOOP      ; Loop thru ^HBHC(632,"C" (appointment date) cross-ref to build report

 +1        SET X1=HBHCBEG1

           SET X2=-1

           DO C^%DTC

           SET HBHCAPDT=X_.9999

 +2        FOR

               SET HBHCAPDT=$ORDER(^HBHC(632,"C",HBHCAPDT))

               if (HBHCAPDT="")!($PIECE(HBHCAPDT,".")>HBHCEND1)

                   QUIT

               SET HBHCDFN=""

FOR

                   SET HBHCDFN=$ORDER(^HBHC(632,"C",HBHCAPDT,HBHCDFN))

                   if HBHCDFN=""

                       QUIT

                   SET HBHCNOD0=^HBHC(632,HBHCDFN,0)

                   if $PIECE(HBHCNOD0,U,7)=""

                       DO PROCESS

 +3        if '$DATA(^TMP("HBHC",$JOB))

               WRITE !!,"No data found for Date Range selected."

 +4        IF $DATA(^TMP("HBHC",$JOB))

               DO PRTLOOP^HBHCR19B

               WRITE !!,HBHCZ,!,$$ICDTEXT^HBHCUTL3(HBHCBEG1,HBHCEND1)_" Diagnosis Categories Total:  ",HBHCTOT,!,HBHCZ

 +5        DO ENDRPT^HBHCUTL1

EXIT      ; Exit module

 +1        DO EXIT^HBHCR19B

 +2        QUIT

 +3       ;SETTMP ; Set ^TMP($J

 +4       ;S ^TMP($J,HBHCCAT,HBHCCATB)="",^TMP($J,"B",$P(^ICD9(HBHCICDP,0),U))=""

 +5       ;Q

PROCESS   ; Process record & build ^TMP("HBHC",$J) global

 +1        SET HBHCDPT0=^DPT($PIECE(HBHCNOD0,U),0)

DX        ; Process Diagnosis (DX), HBHCDFN must be defined prior to call, returns code plus text in local array HBHCDX

 +1        DO DX^HBHCUTL3

 +2        SET HBHCI=0

FOR

               SET HBHCI=$ORDER(HBHCDX(HBHCI))

               if HBHCI'>0

                   QUIT

               SET HBHCDX="HBHCDX("_HBHCI_")"

               if $DATA(HBHCFLAG)

                   DO SET

               IF '$DATA(HBHCFLAG)

                   if $DATA(^TMP($JOB,"B",$PIECE(@HBHCDX,HBHCSP2)))

                       DO SET

 +3        QUIT

SET       ; Set ^TMP node

 +1       ; HBH*1*22 shortens SSN to Last 4 only for display; following full SSN left intact since used as subscript

 +2        SET ^TMP("HBHC",$JOB,$PIECE(@HBHCDX,"."),$EXTRACT($PIECE(HBHCDPT0,U),1,24),$EXTRACT($PIECE(HBHCDPT0,U,9),1,3)_"-"_$EXTRACT($PIECE(HBHCDPT0,U,9),4,5)_"-"_$EXTRACT($PIECE(HBHCDPT0,U,9),6,9),@HBHCDX)=""

 +3        QUIT

HBHCR19A.m