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
Q
;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
Q
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)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCR19A 4829 printed Nov 22, 2024@17:08:22 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
