BARRIDR ; IHS/SD/LSL - Inpatient Primary Diagnosis Report ;08/20/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**6,7,23,24,25**;OCT 26, 2005;Build 6
; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
; ITSC/SD/LSL - 03/17/03 - Routine created
;IHS/SD/POT MAR 2013 ADDED NEW VA billing- BAR*1.8*23
;IHS/SD/POT JUL 2013 P.OTTIS ADDED SUPPORT FOR ICD-10- BAR*1.8*23
;IHS/SD/POT HEAT150941 Allow ALL DX9/10
; if no DX selected: show ALL DX of ALL available coding systems 3/10/2014 - BAR*1.8*24
;IHS/SD/POT CR 4074 HEAT180276 ALLOW DX LENGTH 8 CHARACTERS - BAR*1.8*25
Q
; *********************************************************************
;
EN ; EP
K BARY,BAR
S BARP("RTN")="BARRIDR"
S BAR("PRIVACY")=1 ; Privacy act applies
D:'$D(BARUSR) INIT^BARUTL ; Set A/R basic variable
S BAR("LOC")="VISIT" ; Always visit location
D ^BARRSEL ; Select exclusion parameters
I $D(BARY("ALL")) S BARY("ALL")=$$CONVERT^BARRSL2(BARY("ALL"))
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q
S BAR("HD",0)=BARMENU
D ^BARRHD ; Report header
S BARQ("RC")="COMPUTE^BARRIDR" ; Compute routine
S BARQ("RP")="PRINT^BARRIDR" ; Print routine
S BARQ("NS")="BAR" ; Namespace for variables
S BARQ("RX")="POUT^BARRUTL" ; Clean-up routine
D ^BARDBQUE ; Double queuing
D PAZ^BARRUTL
Q
; *********************************************************************
;
COMPUTE ;
;
S BAR("SUBR")="BAR-IDR"
K ^TMP($J,"BAR-IDR")
S BARP("RTN")="BARRIDR" ; Routine used to get data if no parameters
S BARDUZ2=DUZ(2)
S DUZ(2)=0
F S DUZ(2)=$O(^BARBL(DUZ(2))) Q:'DUZ(2) D LOOP^BARRUTL
S DUZ(2)=BARDUZ2
Q
; *********************************************************************
;
DATA ; EP
; Called by BARRUTL
S BARDSCHG=$$GET1^DIQ(90050.01,BAR,23)
;I DUZ=838 I BARDSCHG="" W !,"BILL IEN: ",BAR," ",$P($G(^BARBL(DUZ(2),BAR,0)),U,1)," exluded: missing discharge service"
Q:BARDSCHG="" ; Must have discharge service
K BARDSCHG
;
S BARP("HIT")=0
D BILL^BARRCHK
Q:'BARP("HIT")
;
; Visit location
S BAR1=$$GET1^DIQ(9999999.06,BAR("L"),.01)
;
; Billing Entity/Allowance Category ; UPDATED
I $D(BARY("ALL")) D
. S BAR2="OTHER"
. S:BAR("ALL")="D"!(BAR("ALL")="K")!(BAR("ALL")="FPL") BAR2="MEDICAID" ;ADDED FPL
. S:BAR("ALL")="R"!(BAR("ALL")="MD")!(BAR("ALL")="MH")!(BAR("ALL")="MC")!(BAR("ALL")="MMC") BAR2="MEDICARE" ;
. S:BAR("ALL")="P"!(BAR("ALL")="F")!(BAR("ALL")="M")!(BAR("ALL")="H") BAR2="PRIVATE INSURANCE" ;TAKEN OUT 'T'
. S:BAR("ALL")="V" BAR2="VETERANS" ;NEW
E D
. I $L(BAR("BI"))=1 S BAR2=$P($T(@BAR("BI")),";;",2)
. E S BAR2=BAR("BI")
;
;I $D(BARY("ACCT")) S BAR2=$G(BARY("ACCT","NM")) ;
;
; Discharge Service
S BAR3=BAR("DS")
I BAR("DS")]"",BAR("DS")'=99999 S BAR3=$$GET1^DIQ(45.7,BAR("DS"),.01)
I BAR3=""!BAR3=99999 S BAR3="No Discharge Service"
;
; Covered days
S BARCDAY=""
S BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BAR)
I BAR3PLOC]"" D
. S BAR3PDUZ=$P(BAR3PLOC,",")
. S BAR3PIEN=$P(BAR3PLOC,",",2)
. S BARCDAY=$P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,7)),U,3)
S BARCDAY=+BARCDAY
;
K BARBAMT,BARPAID,BARCOPAY,BARDED,BARADJ,BARCODED,BARADJ2
S BARBAMT=$P($G(^BARBL(DUZ(2),BAR,0)),U,13) ; Bill Amount
S BARPAID=$$TRANS^BARDUTL(DUZ(2),BAR,"P") ; All $ for pay trans
S BARCOPAY=$$TRANS^BARDUTL(DUZ(2),BAR,"C") ; All $ for copay trans
S BARDED=$$TRANS^BARDUTL(DUZ(2),BAR,"D") ; All $ for deduct tran
S BARADJ=$$TRANS^BARDUTL(DUZ(2),BAR,"A") ; All $ for adjust tran
S BARCODED=BARCOPAY+BARDED
S BARADJ2=BARADJ-BARCODED
;
; Detail data (by diagnosis)
I $G(BAR("DX"))="" S BAR("DX")=" " ; - BAR*1.8*24
S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")))
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U)=$P(BARHOLD,U)+1
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,2)=$P(BARHOLD,U,2)+BARCDAY
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,3)=$P(BARHOLD,U,3)+BARBAMT
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,4)=$P(BARHOLD,U,4)+BARPAID
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,5)=$P(BARHOLD,U,5)+BARCODED
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,6)=$P(BARHOLD,U,6)+BARADJ2
;
; Total by Discharge Service
S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3))
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U)=$P(BARHOLD,U)+1
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,2)=$P(BARHOLD,U,2)+BARCDAY
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,3)=$P(BARHOLD,U,3)+BARBAMT
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,4)=$P(BARHOLD,U,4)+BARPAID
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,5)=$P(BARHOLD,U,5)+BARCODED
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,6)=$P(BARHOLD,U,6)+BARADJ2
;
; Total by Billing Entity/Allowance Category
S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1,BAR2))
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U)=$P(BARHOLD,U)+1
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,2)=$P(BARHOLD,U,2)+BARCDAY
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,3)=$P(BARHOLD,U,3)+BARBAMT
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,4)=$P(BARHOLD,U,4)+BARPAID
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,5)=$P(BARHOLD,U,5)+BARCODED
S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,6)=$P(BARHOLD,U,6)+BARADJ2
;
; Total by Visit Location
S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1))
S $P(^TMP($J,"BAR-IDR",BAR1),U)=$P(BARHOLD,U)+1
S $P(^TMP($J,"BAR-IDR",BAR1),U,2)=$P(BARHOLD,U,2)+BARCDAY
S $P(^TMP($J,"BAR-IDR",BAR1),U,3)=$P(BARHOLD,U,3)+BARBAMT
S $P(^TMP($J,"BAR-IDR",BAR1),U,4)=$P(BARHOLD,U,4)+BARPAID
S $P(^TMP($J,"BAR-IDR",BAR1),U,5)=$P(BARHOLD,U,5)+BARCODED
S $P(^TMP($J,"BAR-IDR",BAR1),U,6)=$P(BARHOLD,U,6)+BARADJ2
;
; Report Total
S BARHOLD=$G(^TMP($J,"BAR-IDR"))
S $P(^TMP($J,"BAR-IDR"),U)=$P(BARHOLD,U)+1
S $P(^TMP($J,"BAR-IDR"),U,2)=$P(BARHOLD,U,2)+BARCDAY
S $P(^TMP($J,"BAR-IDR"),U,3)=$P(BARHOLD,U,3)+BARBAMT
S $P(^TMP($J,"BAR-IDR"),U,4)=$P(BARHOLD,U,4)+BARPAID
S $P(^TMP($J,"BAR-IDR"),U,5)=$P(BARHOLD,U,5)+BARCODED
S $P(^TMP($J,"BAR-IDR"),U,6)=$P(BARHOLD,U,6)+BARADJ2
Q
; *********************************************************************
;
PRINT ; EP
; Print
K BAR1,BAR2,BAR3,BARHOLD,BARCDAY,BARBAMT,BARPAID,BARCODED,BARADJ
K BARADJ2,BAR3PLOC,BAR3PIEN,BAR3PDUZ
S BAR("PG")=0
S BAR("COL1")="W !?18,""COVERED"",?31,""AMOUNT"",?45,""AMOUNT"",?56,""COPAYS/"""
S BAR("COL2")="W !,""DIAGNOSIS BILLS"",?19,""DAYS"",?31,""BILLED"""
S BAR("COL2")=BAR("COL2")_",?46,""PAID"",?54,""DEDUCTIBLES"",?69,""ADJUSTMENTS"""
S BARDASH=" ----- ------- ------------ ------------ ------------ ------------"
S BAREQUAL=" ===== ======= ============ ============ ============ ============"
;
D HDB
I '$D(^TMP($J,"BAR-IDR")) D Q
. W !!!!!?25,"*** NO DATA TO PRINT ***"
;
S BARL=""
F S BARL=$O(^TMP($J,"BAR-IDR",BARL)) Q:BARL="" D LOC Q:$G(BAR("F1"))
D TOTAL
Q
; ********************************************************************
;
LOC ;
; For each location do...
W !,"VISIT LOCATION: ",BARL
S BAR2=""
F S BAR2=$O(^TMP($J,"BAR-IDR",BARL,BAR2)) Q:BAR2="" D ALLBI Q:$G(BAR("F1"))
D LOCTOT
Q
; ********************************************************************
;
ALLBI ;
; For each Billing entity / Allowance Category do...
I $D(BARY("ALL")) W !?3,"ALLOWANCE CATEGORY: "
E W !?3,"BILLING ENTITY: "
W BAR2
S BARDS=""
F S BARDS=$O(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS)) Q:BARDS="" D DSCH Q:$G(BAR("F1"))
D ALLBITOT
Q
; ********************************************************************
;
DSCH ;
; For each Discharge Service do...
W !?6,"DISCHARGE SERVICE: ",BARDS,!
S BARDX=""
F S BARDX=$O(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS,BARDX)) Q:BARDX="" D DX Q:$G(BAR("F1"))
D DSCHTOT
Q
; ********************************************************************
;
DX ;
; For each Diagnosis do...
I BARDX=" " Q ;NO DX
I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS,BARDX))
;old code W !?1,$E(BARDX,1,6) ; HEAT180276 - BAR*1.8*25
W !,$E(BARDX,1,8) ; BAR*1.8*25
D STNDLINE
Q
; ********************************************************************
;
STNDLINE ;
; Write standard line
W ?9,$J($P(BARHOLD,U),5) ; Bill Count
W ?16,$J($P(BARHOLD,U,2),7) ; Covered Days
W ?25,$J($FN($P(BARHOLD,U,3),",",2),12) ; Billed Amount
W ?39,$J($FN($P(BARHOLD,U,4),",",2),12) ; Paid Amount
W ?53,$J($FN($P(BARHOLD,U,5),",",2),12) ; co-pay/deductible Amount
W ?67,$J($FN($P(BARHOLD,U,6),",",2),12) ; Adjustment Amount
Q
;
DSCHTOT ;
; Discharge service subtotal
W !,BARDASH
W !," *DSVC"
S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS))
D STNDLINE
W !
Q
; ********************************************************************
;
ALLBITOT ;
; Billing Entity / Allowance Category subtotal
W BARDASH
I $D(BARY("ALL")) W !," **ALLOW"
E W !," **BILL"
S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL,BAR2))
D STNDLINE
W !
Q
; ********************************************************************
;
LOCTOT ;
; Location subtotal
W BARDASH
W !," ***V LOC"
S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL))
D STNDLINE
W !
Q
; ********************************************************************
;
TOTAL ;
; Report Total
W BAREQUAL
W !,"****TOTAL"
S BARHOLD=$G(^TMP($J,"BAR-IDR"))
D STNDLINE
Q
; ********************************************************************
;
HD ; EP
D PAZ^BARRUTL
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAR("F1")=1 Q
; -------------------------------
;
HDB ; EP
; Page and column header
S BAR("PG")=BAR("PG")+1
S BAR("I")=""
D WHD^BARRHD ; Report header
X BAR("COL1")
X BAR("COL2")
S $P(BAR("DASH"),"=",$S($D(BAR(133)):132,1:81))=""
W !,BAR("DASH"),!
Q
; ********************************************************************
;- BAR*1.8*23
;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
;AND MAPS INSURER TYPE CODE TO CATEGORY (IE: W --> OTHER)
H ;;PRIVATE INSURANCE;;HMO
M ;;PRIVATE INSURANCE;;MEDICARE SUPPL.
D ;;MEDICAID;;MEDICAID FI
R ;;MEDICARE;;MEDICARE FI
P ;;PRIVATE INSURANCE;;PRIVATE INSURANCE
W ;;OTHER;;WORKMEN'S COMP
C ;;OTHER;;CHAMPUS
N ;;OTHER;;NON-BENEFICIARY (NON-INDIAN)
I ;;OTHER;;INDIAN PATIENT
K ;;MEDICAID;;CHIP (KIDSCARE)
T ;;OTHER;;THIRD PARTY LIABILITY
G ;;OTHER;;GUARANTOR
MC ;;MEDICARE;;MCR PART C
MD ;;MEDICARE;;MCR PART D
MH ;;MEDICARE;;MEDICARE HMO
MMC ;;MEDICARE;;MCR MANAGED CARE
TSI ;;OTHER;;TRIBAL SELF INSURED
SEP ;;OTHER;;STATE EXCHANGE PLAN
FPL ;;MEDICAID;;FPL 133 PERCENT
F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
V ;;VETERAN;;VETERANS MEDICAL BENEFITS
;;***END OF TABLE**
BARRIDR ; IHS/SD/LSL - Inpatient Primary Diagnosis Report ;08/20/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**6,7,23,24,25**;OCT 26, 2005;Build 6
+2 ; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
+3 ; ITSC/SD/LSL - 03/17/03 - Routine created
+4 ;IHS/SD/POT MAR 2013 ADDED NEW VA billing- BAR*1.8*23
+5 ;IHS/SD/POT JUL 2013 P.OTTIS ADDED SUPPORT FOR ICD-10- BAR*1.8*23
+6 ;IHS/SD/POT HEAT150941 Allow ALL DX9/10
+7 ; if no DX selected: show ALL DX of ALL available coding systems 3/10/2014 - BAR*1.8*24
+8 ;IHS/SD/POT CR 4074 HEAT180276 ALLOW DX LENGTH 8 CHARACTERS - BAR*1.8*25
+9 QUIT
+10 ; *********************************************************************
+11 ;
EN ; EP
+1 KILL BARY,BAR
+2 SET BARP("RTN")="BARRIDR"
+3 ; Privacy act applies
SET BAR("PRIVACY")=1
+4 ; Set A/R basic variable
IF '$DATA(BARUSR)
DO INIT^BARUTL
+5 ; Always visit location
SET BAR("LOC")="VISIT"
+6 ; Select exclusion parameters
DO ^BARRSEL
+7 IF $DATA(BARY("ALL"))
SET BARY("ALL")=$$CONVERT^BARRSL2(BARY("ALL"))
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+9 SET BAR("HD",0)=BARMENU
+10 ; Report header
DO ^BARRHD
+11 ; Compute routine
SET BARQ("RC")="COMPUTE^BARRIDR"
+12 ; Print routine
SET BARQ("RP")="PRINT^BARRIDR"
+13 ; Namespace for variables
SET BARQ("NS")="BAR"
+14 ; Clean-up routine
SET BARQ("RX")="POUT^BARRUTL"
+15 ; Double queuing
DO ^BARDBQUE
+16 DO PAZ^BARRUTL
+17 QUIT
+18 ; *********************************************************************
+19 ;
COMPUTE ;
+1 ;
+2 SET BAR("SUBR")="BAR-IDR"
+3 KILL ^TMP($JOB,"BAR-IDR")
+4 ; Routine used to get data if no parameters
SET BARP("RTN")="BARRIDR"
+5 SET BARDUZ2=DUZ(2)
+6 SET DUZ(2)=0
+7 FOR
SET DUZ(2)=$ORDER(^BARBL(DUZ(2)))
IF 'DUZ(2)
QUIT
DO LOOP^BARRUTL
+8 SET DUZ(2)=BARDUZ2
+9 QUIT
+10 ; *********************************************************************
+11 ;
DATA ; EP
+1 ; Called by BARRUTL
+2 SET BARDSCHG=$$GET1^DIQ(90050.01,BAR,23)
+3 ;I DUZ=838 I BARDSCHG="" W !,"BILL IEN: ",BAR," ",$P($G(^BARBL(DUZ(2),BAR,0)),U,1)," exluded: missing discharge service"
+4 ; Must have discharge service
IF BARDSCHG=""
QUIT
+5 KILL BARDSCHG
+6 ;
+7 SET BARP("HIT")=0
+8 DO BILL^BARRCHK
+9 IF 'BARP("HIT")
QUIT
+10 ;
+11 ; Visit location
+12 SET BAR1=$$GET1^DIQ(9999999.06,BAR("L"),.01)
+13 ;
+14 ; Billing Entity/Allowance Category ; UPDATED
+15 IF $DATA(BARY("ALL"))
Begin DoDot:1
+16 SET BAR2="OTHER"
+17 ;ADDED FPL
IF BAR("ALL")="D"!(BAR("ALL")="K")!(BAR("ALL")="FPL")
SET BAR2="MEDICAID"
+18 ;
IF BAR("ALL")="R"!(BAR("ALL")="MD")!(BAR("ALL")="MH")!(BAR("ALL")="MC")!(BAR("ALL")="MMC")
SET BAR2="MEDICARE"
+19 ;TAKEN OUT 'T'
IF BAR("ALL")="P"!(BAR("ALL")="F")!(BAR("ALL")="M")!(BAR("ALL")="H")
SET BAR2="PRIVATE INSURANCE"
+20 ;NEW
IF BAR("ALL")="V"
SET BAR2="VETERANS"
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 IF $LENGTH(BAR("BI"))=1
SET BAR2=$PIECE($TEXT(@BAR("BI")),";;",2)
+23 IF '$TEST
SET BAR2=BAR("BI")
End DoDot:1
+24 ;
+25 ;I $D(BARY("ACCT")) S BAR2=$G(BARY("ACCT","NM")) ;
+26 ;
+27 ; Discharge Service
+28 SET BAR3=BAR("DS")
+29 IF BAR("DS")]""
IF BAR("DS")'=99999
SET BAR3=$$GET1^DIQ(45.7,BAR("DS"),.01)
+30 IF BAR3=""!BAR3=99999
SET BAR3="No Discharge Service"
+31 ;
+32 ; Covered days
+33 SET BARCDAY=""
+34 SET BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BAR)
+35 IF BAR3PLOC]""
Begin DoDot:1
+36 SET BAR3PDUZ=$PIECE(BAR3PLOC,",")
+37 SET BAR3PIEN=$PIECE(BAR3PLOC,",",2)
+38 SET BARCDAY=$PIECE($GET(^ABMDBILL(BAR3PDUZ,BAR3PIEN,7)),U,3)
End DoDot:1
+39 SET BARCDAY=+BARCDAY
+40 ;
+41 KILL BARBAMT,BARPAID,BARCOPAY,BARDED,BARADJ,BARCODED,BARADJ2
+42 ; Bill Amount
SET BARBAMT=$PIECE($GET(^BARBL(DUZ(2),BAR,0)),U,13)
+43 ; All $ for pay trans
SET BARPAID=$$TRANS^BARDUTL(DUZ(2),BAR,"P")
+44 ; All $ for copay trans
SET BARCOPAY=$$TRANS^BARDUTL(DUZ(2),BAR,"C")
+45 ; All $ for deduct tran
SET BARDED=$$TRANS^BARDUTL(DUZ(2),BAR,"D")
+46 ; All $ for adjust tran
SET BARADJ=$$TRANS^BARDUTL(DUZ(2),BAR,"A")
+47 SET BARCODED=BARCOPAY+BARDED
+48 SET BARADJ2=BARADJ-BARCODED
+49 ;
+50 ; Detail data (by diagnosis)
+51 ; - BAR*1.8*24
IF $GET(BAR("DX"))=""
SET BAR("DX")=" "
+52 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")))
+53 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U)=$PIECE(BARHOLD,U)+1
+54 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,2)=$PIECE(BARHOLD,U,2)+BARCDAY
+55 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,3)=$PIECE(BARHOLD,U,3)+BARBAMT
+56 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,4)=$PIECE(BARHOLD,U,4)+BARPAID
+57 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,5)=$PIECE(BARHOLD,U,5)+BARCODED
+58 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,6)=$PIECE(BARHOLD,U,6)+BARADJ2
+59 ;
+60 ; Total by Discharge Service
+61 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3))
+62 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3),U)=$PIECE(BARHOLD,U)+1
+63 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3),U,2)=$PIECE(BARHOLD,U,2)+BARCDAY
+64 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3),U,3)=$PIECE(BARHOLD,U,3)+BARBAMT
+65 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3),U,4)=$PIECE(BARHOLD,U,4)+BARPAID
+66 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3),U,5)=$PIECE(BARHOLD,U,5)+BARCODED
+67 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2,BAR3),U,6)=$PIECE(BARHOLD,U,6)+BARADJ2
+68 ;
+69 ; Total by Billing Entity/Allowance Category
+70 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BAR1,BAR2))
+71 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2),U)=$PIECE(BARHOLD,U)+1
+72 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2),U,2)=$PIECE(BARHOLD,U,2)+BARCDAY
+73 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2),U,3)=$PIECE(BARHOLD,U,3)+BARBAMT
+74 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2),U,4)=$PIECE(BARHOLD,U,4)+BARPAID
+75 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2),U,5)=$PIECE(BARHOLD,U,5)+BARCODED
+76 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1,BAR2),U,6)=$PIECE(BARHOLD,U,6)+BARADJ2
+77 ;
+78 ; Total by Visit Location
+79 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BAR1))
+80 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1),U)=$PIECE(BARHOLD,U)+1
+81 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1),U,2)=$PIECE(BARHOLD,U,2)+BARCDAY
+82 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1),U,3)=$PIECE(BARHOLD,U,3)+BARBAMT
+83 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1),U,4)=$PIECE(BARHOLD,U,4)+BARPAID
+84 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1),U,5)=$PIECE(BARHOLD,U,5)+BARCODED
+85 SET $PIECE(^TMP($JOB,"BAR-IDR",BAR1),U,6)=$PIECE(BARHOLD,U,6)+BARADJ2
+86 ;
+87 ; Report Total
+88 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR"))
+89 SET $PIECE(^TMP($JOB,"BAR-IDR"),U)=$PIECE(BARHOLD,U)+1
+90 SET $PIECE(^TMP($JOB,"BAR-IDR"),U,2)=$PIECE(BARHOLD,U,2)+BARCDAY
+91 SET $PIECE(^TMP($JOB,"BAR-IDR"),U,3)=$PIECE(BARHOLD,U,3)+BARBAMT
+92 SET $PIECE(^TMP($JOB,"BAR-IDR"),U,4)=$PIECE(BARHOLD,U,4)+BARPAID
+93 SET $PIECE(^TMP($JOB,"BAR-IDR"),U,5)=$PIECE(BARHOLD,U,5)+BARCODED
+94 SET $PIECE(^TMP($JOB,"BAR-IDR"),U,6)=$PIECE(BARHOLD,U,6)+BARADJ2
+95 QUIT
+96 ; *********************************************************************
+97 ;
PRINT ; EP
+1 ; Print
+2 KILL BAR1,BAR2,BAR3,BARHOLD,BARCDAY,BARBAMT,BARPAID,BARCODED,BARADJ
+3 KILL BARADJ2,BAR3PLOC,BAR3PIEN,BAR3PDUZ
+4 SET BAR("PG")=0
+5 SET BAR("COL1")="W !?18,""COVERED"",?31,""AMOUNT"",?45,""AMOUNT"",?56,""COPAYS/"""
+6 SET BAR("COL2")="W !,""DIAGNOSIS BILLS"",?19,""DAYS"",?31,""BILLED"""
+7 SET BAR("COL2")=BAR("COL2")_",?46,""PAID"",?54,""DEDUCTIBLES"",?69,""ADJUSTMENTS"""
+8 SET BARDASH=" ----- ------- ------------ ------------ ------------ ------------"
+9 SET BAREQUAL=" ===== ======= ============ ============ ============ ============"
+10 ;
+11 DO HDB
+12 IF '$DATA(^TMP($JOB,"BAR-IDR"))
Begin DoDot:1
+13 WRITE !!!!!?25,"*** NO DATA TO PRINT ***"
End DoDot:1
QUIT
+14 ;
+15 SET BARL=""
+16 FOR
SET BARL=$ORDER(^TMP($JOB,"BAR-IDR",BARL))
IF BARL=""
QUIT
DO LOC
IF $GET(BAR("F1"))
QUIT
+17 DO TOTAL
+18 QUIT
+19 ; ********************************************************************
+20 ;
LOC ;
+1 ; For each location do...
+2 WRITE !,"VISIT LOCATION: ",BARL
+3 SET BAR2=""
+4 FOR
SET BAR2=$ORDER(^TMP($JOB,"BAR-IDR",BARL,BAR2))
IF BAR2=""
QUIT
DO ALLBI
IF $GET(BAR("F1"))
QUIT
+5 DO LOCTOT
+6 QUIT
+7 ; ********************************************************************
+8 ;
ALLBI ;
+1 ; For each Billing entity / Allowance Category do...
+2 IF $DATA(BARY("ALL"))
WRITE !?3,"ALLOWANCE CATEGORY: "
+3 IF '$TEST
WRITE !?3,"BILLING ENTITY: "
+4 WRITE BAR2
+5 SET BARDS=""
+6 FOR
SET BARDS=$ORDER(^TMP($JOB,"BAR-IDR",BARL,BAR2,BARDS))
IF BARDS=""
QUIT
DO DSCH
IF $GET(BAR("F1"))
QUIT
+7 DO ALLBITOT
+8 QUIT
+9 ; ********************************************************************
+10 ;
DSCH ;
+1 ; For each Discharge Service do...
+2 WRITE !?6,"DISCHARGE SERVICE: ",BARDS,!
+3 SET BARDX=""
+4 FOR
SET BARDX=$ORDER(^TMP($JOB,"BAR-IDR",BARL,BAR2,BARDS,BARDX))
IF BARDX=""
QUIT
DO DX
IF $GET(BAR("F1"))
QUIT
+5 DO DSCHTOT
+6 QUIT
+7 ; ********************************************************************
+8 ;
DX ;
+1 ; For each Diagnosis do...
+2 ;NO DX
IF BARDX=" "
QUIT
+3 IF $Y>(IOSL-5)
DO HD
IF $GET(BAR("F1"))
QUIT
+4 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BARL,BAR2,BARDS,BARDX))
+5 ;old code W !?1,$E(BARDX,1,6) ; HEAT180276 - BAR*1.8*25
+6 ; BAR*1.8*25
WRITE !,$EXTRACT(BARDX,1,8)
+7 DO STNDLINE
+8 QUIT
+9 ; ********************************************************************
+10 ;
STNDLINE ;
+1 ; Write standard line
+2 ; Bill Count
WRITE ?9,$JUSTIFY($PIECE(BARHOLD,U),5)
+3 ; Covered Days
WRITE ?16,$JUSTIFY($PIECE(BARHOLD,U,2),7)
+4 ; Billed Amount
WRITE ?25,$JUSTIFY($FNUMBER($PIECE(BARHOLD,U,3),",",2),12)
+5 ; Paid Amount
WRITE ?39,$JUSTIFY($FNUMBER($PIECE(BARHOLD,U,4),",",2),12)
+6 ; co-pay/deductible Amount
WRITE ?53,$JUSTIFY($FNUMBER($PIECE(BARHOLD,U,5),",",2),12)
+7 ; Adjustment Amount
WRITE ?67,$JUSTIFY($FNUMBER($PIECE(BARHOLD,U,6),",",2),12)
+8 QUIT
+9 ;
DSCHTOT ;
+1 ; Discharge service subtotal
+2 WRITE !,BARDASH
+3 WRITE !," *DSVC"
+4 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BARL,BAR2,BARDS))
+5 DO STNDLINE
+6 WRITE !
+7 QUIT
+8 ; ********************************************************************
+9 ;
ALLBITOT ;
+1 ; Billing Entity / Allowance Category subtotal
+2 WRITE BARDASH
+3 IF $DATA(BARY("ALL"))
WRITE !," **ALLOW"
+4 IF '$TEST
WRITE !," **BILL"
+5 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BARL,BAR2))
+6 DO STNDLINE
+7 WRITE !
+8 QUIT
+9 ; ********************************************************************
+10 ;
LOCTOT ;
+1 ; Location subtotal
+2 WRITE BARDASH
+3 WRITE !," ***V LOC"
+4 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR",BARL))
+5 DO STNDLINE
+6 WRITE !
+7 QUIT
+8 ; ********************************************************************
+9 ;
TOTAL ;
+1 ; Report Total
+2 WRITE BAREQUAL
+3 WRITE !,"****TOTAL"
+4 SET BARHOLD=$GET(^TMP($JOB,"BAR-IDR"))
+5 DO STNDLINE
+6 QUIT
+7 ; ********************************************************************
+8 ;
HD ; EP
+1 DO PAZ^BARRUTL
+2 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET BAR("F1")=1
QUIT
+3 ; -------------------------------
+4 ;
HDB ; EP
+1 ; Page and column header
+2 SET BAR("PG")=BAR("PG")+1
+3 SET BAR("I")=""
+4 ; Report header
DO WHD^BARRHD
+5 XECUTE BAR("COL1")
+6 XECUTE BAR("COL2")
+7 SET $PIECE(BAR("DASH"),"=",$SELECT($DATA(BAR(133)):132,1:81))=""
+8 WRITE !,BAR("DASH"),!
+9 QUIT
+10 ; ********************************************************************
+11 ;- BAR*1.8*23
+12 ;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
+13 ;AND MAPS INSURER TYPE CODE TO CATEGORY (IE: W --> OTHER)
H ;;PRIVATE INSURANCE;;HMO
M ;;PRIVATE INSURANCE;;MEDICARE SUPPL.
D ;;MEDICAID;;MEDICAID FI
R ;;MEDICARE;;MEDICARE FI
P ;;PRIVATE INSURANCE;;PRIVATE INSURANCE
W ;;OTHER;;WORKMEN'S COMP
C ;;OTHER;;CHAMPUS
N ;;OTHER;;NON-BENEFICIARY (NON-INDIAN)
I ;;OTHER;;INDIAN PATIENT
K ;;MEDICAID;;CHIP (KIDSCARE)
T ;;OTHER;;THIRD PARTY LIABILITY
G ;;OTHER;;GUARANTOR
MC ;;MEDICARE;;MCR PART C
MD ;;MEDICARE;;MCR PART D
MH ;;MEDICARE;;MEDICARE HMO
MMC ;;MEDICARE;;MCR MANAGED CARE
TSI ;;OTHER;;TRIBAL SELF INSURED
SEP ;;OTHER;;STATE EXCHANGE PLAN
FPL ;;MEDICAID;;FPL 133 PERCENT
F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
V ;;VETERAN;;VETERANS MEDICAL BENEFITS
+1 ;;***END OF TABLE**
