Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BARRIDR

BARRIDR.m

Go to the documentation of this file. 
  1. 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
  1.  ; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
  1.  ; ITSC/SD/LSL - 03/17/03 - Routine created
  1.  ;IHS/SD/POT MAR 2013 ADDED NEW VA billing- BAR*1.8*23
  1.  ;IHS/SD/POT JUL 2013 P.OTTIS ADDED SUPPORT FOR ICD-10- BAR*1.8*23
  1.  ;IHS/SD/POT HEAT150941 Allow ALL DX9/10
  1.  ;                     if no DX selected: show ALL DX of ALL available coding systems 3/10/2014 - BAR*1.8*24
  1.  ;IHS/SD/POT CR 4074 HEAT180276 ALLOW DX LENGTH 8 CHARACTERS - BAR*1.8*25
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EN ; EP
  1.  K BARY,BAR
  1.  S BARP("RTN")="BARRIDR"
  1.  S BAR("PRIVACY")=1                ; Privacy act applies
  1.  D:'$D(BARUSR) INIT^BARUTL         ; Set A/R basic variable
  1.  S BAR("LOC")="VISIT"              ; Always visit location
  1.  D ^BARRSEL                        ; Select exclusion parameters
  1.  I $D(BARY("ALL")) S BARY("ALL")=$$CONVERT^BARRSL2(BARY("ALL"))
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q
  1.  S BAR("HD",0)=BARMENU
  1.  D ^BARRHD                         ; Report header
  1.  S BARQ("RC")="COMPUTE^BARRIDR"    ; Compute routine
  1.  S BARQ("RP")="PRINT^BARRIDR"      ; Print routine
  1.  S BARQ("NS")="BAR"                ; Namespace for variables
  1.  S BARQ("RX")="POUT^BARRUTL"       ; Clean-up routine
  1.  D ^BARDBQUE                       ; Double queuing
  1.  D PAZ^BARRUTL
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. COMPUTE ;
  1.  ;
  1.  S BAR("SUBR")="BAR-IDR"
  1.  K ^TMP($J,"BAR-IDR")
  1.  S BARP("RTN")="BARRIDR"     ; Routine used to get data if no parameters
  1.  S BARDUZ2=DUZ(2)
  1.  S DUZ(2)=0
  1.  F  S DUZ(2)=$O(^BARBL(DUZ(2))) Q:'DUZ(2)  D LOOP^BARRUTL
  1.  S DUZ(2)=BARDUZ2
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. DATA ; EP
  1.  ; Called by BARRUTL
  1.  S BARDSCHG=$$GET1^DIQ(90050.01,BAR,23)
  1.  ;I DUZ=838 I BARDSCHG="" W !,"BILL IEN: ",BAR," ",$P($G(^BARBL(DUZ(2),BAR,0)),U,1)," exluded: missing discharge service"
  1.  Q:BARDSCHG=""  ; Must have discharge service
  1.  K BARDSCHG
  1.  ;
  1.  S BARP("HIT")=0
  1.  D BILL^BARRCHK
  1.  Q:'BARP("HIT")
  1.  ;
  1.  ; Visit location
  1.  S BAR1=$$GET1^DIQ(9999999.06,BAR("L"),.01)
  1.  ;
  1.  ; Billing Entity/Allowance Category ; UPDATED
  1.  I $D(BARY("ALL")) D
  1.  . S BAR2="OTHER"
  1.  . S:BAR("ALL")="D"!(BAR("ALL")="K")!(BAR("ALL")="FPL") BAR2="MEDICAID"  ;ADDED FPL
  1.  . S:BAR("ALL")="R"!(BAR("ALL")="MD")!(BAR("ALL")="MH")!(BAR("ALL")="MC")!(BAR("ALL")="MMC") BAR2="MEDICARE"  ;
  1.  . S:BAR("ALL")="P"!(BAR("ALL")="F")!(BAR("ALL")="M")!(BAR("ALL")="H") BAR2="PRIVATE INSURANCE"  ;TAKEN OUT 'T'
  1.  . S:BAR("ALL")="V" BAR2="VETERANS" ;NEW
  1.  E  D
  1.  . I $L(BAR("BI"))=1 S BAR2=$P($T(@BAR("BI")),";;",2)
  1.  . E  S BAR2=BAR("BI")
  1.  ;
  1.  ;I $D(BARY("ACCT")) S BAR2=$G(BARY("ACCT","NM")) ;
  1.  ;
  1.  ; Discharge Service
  1.  S BAR3=BAR("DS")
  1.  I BAR("DS")]"",BAR("DS")'=99999 S BAR3=$$GET1^DIQ(45.7,BAR("DS"),.01)
  1.  I BAR3=""!BAR3=99999 S BAR3="No Discharge Service"
  1.  ;
  1.  ; Covered days
  1.  S BARCDAY=""
  1.  S BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BAR)
  1.  I BAR3PLOC]"" D
  1.  . S BAR3PDUZ=$P(BAR3PLOC,",")
  1.  . S BAR3PIEN=$P(BAR3PLOC,",",2)
  1.  . S BARCDAY=$P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,7)),U,3)
  1.  S BARCDAY=+BARCDAY
  1.  ;
  1.  K BARBAMT,BARPAID,BARCOPAY,BARDED,BARADJ,BARCODED,BARADJ2
  1.  S BARBAMT=$P($G(^BARBL(DUZ(2),BAR,0)),U,13)    ; Bill Amount
  1.  S BARPAID=$$TRANS^BARDUTL(DUZ(2),BAR,"P")       ; All $ for pay trans
  1.  S BARCOPAY=$$TRANS^BARDUTL(DUZ(2),BAR,"C")     ; All $ for copay trans
  1.  S BARDED=$$TRANS^BARDUTL(DUZ(2),BAR,"D")       ; All $ for deduct tran
  1.  S BARADJ=$$TRANS^BARDUTL(DUZ(2),BAR,"A")       ; All $ for adjust tran
  1.  S BARCODED=BARCOPAY+BARDED
  1.  S BARADJ2=BARADJ-BARCODED
  1.  ;
  1.  ; Detail data (by diagnosis)
  1.  I $G(BAR("DX"))="" S BAR("DX")=" " ; - BAR*1.8*24
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")))
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U)=$P(BARHOLD,U)+1
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,2)=$P(BARHOLD,U,2)+BARCDAY
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,3)=$P(BARHOLD,U,3)+BARBAMT
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,4)=$P(BARHOLD,U,4)+BARPAID
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,5)=$P(BARHOLD,U,5)+BARCODED
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3,BAR("DX")),U,6)=$P(BARHOLD,U,6)+BARADJ2
  1.  ;
  1.  ; Total by Discharge Service
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3))
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U)=$P(BARHOLD,U)+1
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,2)=$P(BARHOLD,U,2)+BARCDAY
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,3)=$P(BARHOLD,U,3)+BARBAMT
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,4)=$P(BARHOLD,U,4)+BARPAID
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,5)=$P(BARHOLD,U,5)+BARCODED
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2,BAR3),U,6)=$P(BARHOLD,U,6)+BARADJ2
  1.  ;
  1.  ; Total by Billing Entity/Allowance Category
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1,BAR2))
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U)=$P(BARHOLD,U)+1
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,2)=$P(BARHOLD,U,2)+BARCDAY
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,3)=$P(BARHOLD,U,3)+BARBAMT
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,4)=$P(BARHOLD,U,4)+BARPAID
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,5)=$P(BARHOLD,U,5)+BARCODED
  1.  S $P(^TMP($J,"BAR-IDR",BAR1,BAR2),U,6)=$P(BARHOLD,U,6)+BARADJ2
  1.  ;
  1.  ; Total by Visit Location
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BAR1))
  1.  S $P(^TMP($J,"BAR-IDR",BAR1),U)=$P(BARHOLD,U)+1
  1.  S $P(^TMP($J,"BAR-IDR",BAR1),U,2)=$P(BARHOLD,U,2)+BARCDAY
  1.  S $P(^TMP($J,"BAR-IDR",BAR1),U,3)=$P(BARHOLD,U,3)+BARBAMT
  1.  S $P(^TMP($J,"BAR-IDR",BAR1),U,4)=$P(BARHOLD,U,4)+BARPAID
  1.  S $P(^TMP($J,"BAR-IDR",BAR1),U,5)=$P(BARHOLD,U,5)+BARCODED
  1.  S $P(^TMP($J,"BAR-IDR",BAR1),U,6)=$P(BARHOLD,U,6)+BARADJ2
  1.  ;
  1.  ; Report Total
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR"))
  1.  S $P(^TMP($J,"BAR-IDR"),U)=$P(BARHOLD,U)+1
  1.  S $P(^TMP($J,"BAR-IDR"),U,2)=$P(BARHOLD,U,2)+BARCDAY
  1.  S $P(^TMP($J,"BAR-IDR"),U,3)=$P(BARHOLD,U,3)+BARBAMT
  1.  S $P(^TMP($J,"BAR-IDR"),U,4)=$P(BARHOLD,U,4)+BARPAID
  1.  S $P(^TMP($J,"BAR-IDR"),U,5)=$P(BARHOLD,U,5)+BARCODED
  1.  S $P(^TMP($J,"BAR-IDR"),U,6)=$P(BARHOLD,U,6)+BARADJ2
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. PRINT ; EP
  1.  ; Print
  1.  K BAR1,BAR2,BAR3,BARHOLD,BARCDAY,BARBAMT,BARPAID,BARCODED,BARADJ
  1.  K BARADJ2,BAR3PLOC,BAR3PIEN,BAR3PDUZ
  1.  S BAR("PG")=0
  1.  S BAR("COL1")="W !?18,""COVERED"",?31,""AMOUNT"",?45,""AMOUNT"",?56,""COPAYS/"""
  1.  S BAR("COL2")="W !,""DIAGNOSIS BILLS"",?19,""DAYS"",?31,""BILLED"""
  1.  S BAR("COL2")=BAR("COL2")_",?46,""PAID"",?54,""DEDUCTIBLES"",?69,""ADJUSTMENTS"""
  1.  S BARDASH="         -----  -------  ------------  ------------  ------------  ------------"
  1.  S BAREQUAL="         =====  =======  ============  ============  ============  ============"
  1.  ;
  1.  D HDB
  1.  I '$D(^TMP($J,"BAR-IDR")) D  Q
  1.  . W !!!!!?25,"*** NO DATA TO PRINT ***"
  1.  ;
  1.  S BARL=""
  1.  F  S BARL=$O(^TMP($J,"BAR-IDR",BARL)) Q:BARL=""  D LOC  Q:$G(BAR("F1"))
  1.  D TOTAL
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. LOC ;
  1.  ; For each location do...
  1.  W !,"VISIT LOCATION:  ",BARL
  1.  S BAR2=""
  1.  F  S BAR2=$O(^TMP($J,"BAR-IDR",BARL,BAR2)) Q:BAR2=""  D ALLBI  Q:$G(BAR("F1"))
  1.  D LOCTOT
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. ALLBI ;
  1.  ; For each Billing entity / Allowance Category do...
  1.  I $D(BARY("ALL")) W !?3,"ALLOWANCE CATEGORY:  "
  1.  E  W !?3,"BILLING ENTITY:  "
  1.  W BAR2
  1.  S BARDS=""
  1.  F  S BARDS=$O(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS)) Q:BARDS=""  D DSCH Q:$G(BAR("F1"))
  1.  D ALLBITOT
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. DSCH ;
  1.  ; For each Discharge Service do...
  1.  W !?6,"DISCHARGE SERVICE:  ",BARDS,!
  1.  S BARDX=""
  1.  F  S BARDX=$O(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS,BARDX)) Q:BARDX=""  D DX Q:$G(BAR("F1"))
  1.  D DSCHTOT
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. DX ;
  1.  ; For each Diagnosis do...
  1.  I BARDX=" " Q  ;NO DX
  1.  I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS,BARDX))
  1.  ;old code W !?1,$E(BARDX,1,6)           ; HEAT180276  - BAR*1.8*25
  1.  W !,$E(BARDX,1,8)                       ; BAR*1.8*25
  1.  D STNDLINE
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. STNDLINE ;
  1.  ; Write standard line
  1.  W ?9,$J($P(BARHOLD,U),5)                 ; Bill Count
  1.  W ?16,$J($P(BARHOLD,U,2),7)              ; Covered Days
  1.  W ?25,$J($FN($P(BARHOLD,U,3),",",2),12)   ; Billed Amount
  1.  W ?39,$J($FN($P(BARHOLD,U,4),",",2),12)   ; Paid Amount
  1.  W ?53,$J($FN($P(BARHOLD,U,5),",",2),12)   ; co-pay/deductible Amount
  1.  W ?67,$J($FN($P(BARHOLD,U,6),",",2),12)   ; Adjustment Amount
  1.  Q
  1.  ;
  1. DSCHTOT ;
  1.  ; Discharge service subtotal
  1.  W !,BARDASH
  1.  W !,"   *DSVC"
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL,BAR2,BARDS))
  1.  D STNDLINE
  1.  W !
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. ALLBITOT ;
  1.  ; Billing Entity / Allowance Category subtotal
  1.  W BARDASH
  1.  I $D(BARY("ALL")) W !,"  **ALLOW"
  1.  E  W !,"  **BILL"
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL,BAR2))
  1.  D STNDLINE
  1.  W !
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. LOCTOT ;
  1.  ; Location subtotal
  1.  W BARDASH
  1.  W !," ***V LOC"
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR",BARL))
  1.  D STNDLINE
  1.  W !
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. TOTAL ;
  1.  ; Report Total
  1.  W BAREQUAL
  1.  W !,"****TOTAL"
  1.  S BARHOLD=$G(^TMP($J,"BAR-IDR"))
  1.  D STNDLINE
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. HD ; EP
  1.  D PAZ^BARRUTL
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAR("F1")=1 Q
  1.  ; -------------------------------
  1.  ;
  1. HDB ; EP
  1.  ; Page and column header
  1.  S BAR("PG")=BAR("PG")+1
  1.  S BAR("I")=""
  1.  D WHD^BARRHD                   ; Report header
  1.  X BAR("COL1")
  1.  X BAR("COL2")
  1.  S $P(BAR("DASH"),"=",$S($D(BAR(133)):132,1:81))=""
  1.  W !,BAR("DASH"),!
  1.  Q
  1.  ; ********************************************************************
  1.  ;- BAR*1.8*23
  1.  ;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
  1.  ;AND MAPS INSURER TYPE CODE TO CATEGORY (IE: W --> OTHER)
  1. H ;;PRIVATE INSURANCE;;HMO
  1. M ;;PRIVATE INSURANCE;;MEDICARE SUPPL.
  1. D ;;MEDICAID;;MEDICAID FI
  1. R ;;MEDICARE;;MEDICARE FI
  1. P ;;PRIVATE INSURANCE;;PRIVATE INSURANCE
  1. W ;;OTHER;;WORKMEN'S COMP
  1. C ;;OTHER;;CHAMPUS
  1. N ;;OTHER;;NON-BENEFICIARY (NON-INDIAN)
  1. I ;;OTHER;;INDIAN PATIENT
  1. K ;;MEDICAID;;CHIP (KIDSCARE)
  1. T ;;OTHER;;THIRD PARTY LIABILITY 
  1. G ;;OTHER;;GUARANTOR
  1. MC ;;MEDICARE;;MCR PART C
  1. MD ;;MEDICARE;;MCR PART D
  1. MH ;;MEDICARE;;MEDICARE HMO
  1. MMC ;;MEDICARE;;MCR MANAGED CARE
  1. TSI ;;OTHER;;TRIBAL SELF INSURED
  1. SEP ;;OTHER;;STATE EXCHANGE PLAN
  1. FPL ;;MEDICAID;;FPL 133 PERCENT
  1. F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
  1. V ;;VETERAN;;VETERANS MEDICAL BENEFITS
  1.   ;;***END OF TABLE**