BARTRNS3 ; IHS/SD/SDR - Transaction Summary/Detail Report OVERFLOW CODE; 03/10/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**28**;OCT 26, 2005;Build 92
;IHS/SD/POT - 1.8*28 - CR8397 HEAT155084 - OVERFLOW CODE OF BARTRNS2 NEW ROUTINE CLONED FROM BARTRNS1
Q
TRANS ;EP Loop thru Trans File
; for checking Trans File data parms
S BARTR(0)=$G(^BARTR(DUZ(2),BARTR,0)) ;A/R Trans 0 node
S BARTR(1)=$G(^BARTR(DUZ(2),BARTR,1)) ;A/R Trans 1 node
S BARTR("TTYP")=$P(BARTR(1),U) ;Trans type
S BARTR("ADJ CAT")=$P(BARTR(1),U,2) ;Adj Cat
S BARTR("ADJ TYPE")=$$GET1^DIQ(90052.02,$P(BARTR(1),U,3),.01) ;Adj Type
;PKD 1.8*19 include ADJ TYPE IEN on rpt -> BARTR("ADJ TYPIEN")
S BARTR("ADJ TYPIEN")=$P(BARTR(1),U,3)
S:BARTR("ADJ CAT")="" BARTR("ADJ CAT")="NULL"
;1.8*19 Use space if ADJ TYP IEN is null to prevent subscript error
;S:(BARTR("ADJ TYPE")="") BARTR("ADJ TYPE")="NULL"
I BARTR("ADJ TYPE")="" S BARTR("ADJ TYPE")="NULL",BARTR("ADJ TYPIEN")=" "
ADJTY I $D(BARY("ADJ TYP")) Q:'$D(BARY("ADJ TYP",BARTR("ADJ TYPIEN"))) ;PKD 1.8*20 Check for Inclusion ADJ TYPE
S BARTR("DT")=$P(BARTR(0),U) ;Trans date/time
S BARTR("TAMT")=$$GET1^DIQ(90050.03,BARTR,3.5)
S BARTR("INS")=$P(BAR(0),U,3) ;A/R Acct
I BARTR("INS")]"" D
.S D0=BARTR("INS")
.S BARTR("ITYP")=$$VALI^BARVPM(8) ;Ins Type CODE
I BARY("RTYP")=1 D SUMMARY
I BARY("RTYP")=2 D DETAIL
Q
SUMMARY ;left of the "=" - LOC^INS TYPE^INSURER
;right of the "=" - BILL COUNT^TOTAL BILL AMT^TOTAL PYMTS^ADJ TYPE^TOTAL ADJS
; ***PKD 1.8*19 adding "ADJ TYPIEN" before ADJ TYPE for sort
; ***& splitting long lines for SAC and clarity in reading
; update: bill count; total bill amount ;total pymts
; 1.8*19 Lines too long w/out change - Line body must not exceed 245 characters
I BARTR("TTYP")=40 D
.S $P(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=+$P($G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)+$G(BARTR("TAMT"))
I BARTR("TTYP")=43!(BARTR("TTYP")=993) D ;bar*1.8*20
.I +$P($G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)=0 S $P(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=0
.N NODE
.S NODE=$G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPIEN"),BARTR("ADJ TYPE"))) ;total adjs bar*1.8*20
.S $P(NODE,U)=$P(NODE,U)+$G(BARTR("TAMT"))
.S $P(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPIEN"),BARTR("ADJ TYPE")),U)=NODE ;bar*1.8*20
Q
I BARTR("TTYP")=40 D
.S $P(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=+$P($G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)+$G(BARTR("TAMT"))
;total adjs
I BARTR("TTYP")=43 D
.I +$P($G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)=0 S $P(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=0
.S $P(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPE")),U)=+$P($G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPE"))),U)+$G(BARTR("TAMT")) ;total adjs
Q
;
DETAIL ;left of the "=" - LOC^ALLOW CAT^INS TYPE^INSURER^BILL
;right of the "=" - DOS^APPROVAL DT^TOTAL BILL AMT^TOTAL PYMTS^# DAYS (DOS-APPR.DT)
; if adj
;right of the "=" - ADJ DT^ADJ TYPE^ADJ AMT^#DAYS (APPR.DT-ADJ.DT)
S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U)=$$SDT^BARDUTL(BAR("DOS"))
S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,2)=$$CDT^BARDUTL(BAR("APPDT"))
S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,3)=BAR("BAMT")
;# of days between appr. date & DOS
S X1=BAR("APPDT")
S X2=BAR("DOS")
D ^%DTC
S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,5)=X
;
I BARTR("TTYP")=40 D
.S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,4)=$P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,4)+BARTR("TAMT")
I BARTR("TTYP")=43!(BARTR("TTYP")=993) D ;bar*1.8*20
.S BAR(BARBILL)=+$G(BAR(BARBILL))+1
.;# of days between appr. date & adj date
.S X1=+BARTR("DT")
.S X2=BAR("APPDT")
.D ^%DTC
.N NODE
.S $P(NODE,U)=$$CDT^BARDUTL(BARTR("DT"))
.S $P(NODE,U,2)=BARTR("ADJ TYPIEN") ;adj type
.S $P(NODE,U,3)=BARTR("ADJ CAT")
.S $P(NODE,U,4)=BARTR("ADJ TYPE") ;adj category
.S $P(NODE,U,5)=BARTR("TAMT") ;adj amt
.S $P(NODE,U,6)=X ;# days
.S ^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",+$G(BAR(BARBILL)))=NODE
Q
PRINT ;
D HDB
I '$D(^TMP($J,"BAR-TRANST"))&(BARY("RTYP")=1) D Q
.W !!!!!?25,"*** NO DATA TO PRINT ***"
.D EOP^BARUTL(0)
;summary lines
I $D(^TMP($J,"BAR-TRANST")) W !,"LOCATION^ALLOWANCE CAT^INSURER TYPE^INSURER^BILL COUNT^TOTAL BILL AMOUNT^TOTAL PAYMENTS^ADJ TYPE IEN^ADJUSTMENT TYPE^TOTAL ADJUSTMENTS"
S BAR("LOC")=0
F S BAR("LOC")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"))) Q:'BAR("LOC") D
.S BAR("ITYP")=""
.F S BAR("ITYP")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"))) Q:BAR("ITYP")="" D
.. I BAR("ITYP")="No Billing Entity" QUIT ;P.OTTIS HEAT #74599
..S BAR("INS")=""
..F S BAR("INS")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))) Q:BAR("INS")'?1N.N D
...S BARO("LOC")=$P($G(^AUTTLOC(BAR("LOC"),0)),U,2)
...S BARO("ALLC")=$P($T(@BAR("ITYP")),";;",2)
...S BARO("ITYP")=$P($T(@BAR("ITYP")),";;",3)
...I BAR("INS")'=0 S BARO("INS")=$$GET1^DIQ(90050.02,BAR("INS")_",",.01) I 1
...E S BARO("INS")="No A/R Account"
...S BARREC=BARO("LOC")_U_BARO("ALLC")_U_BARO("ITYP")_U_BARO("INS")_U
...W !,BARREC_$G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")))
...I $D(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS")) D
....S (BAR("ADJ"),BAR("ADJIEN"))="" ;only one AdjType per AdjTypeIEN
....S BARACNT=0
....F S BAR("ADJIEN")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"))) Q:BAR("ADJIEN")="" D
.....S BAR("ADJ")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"),"")) ;bar*1.8*20
.....S BAR("ADJ TYP")=""
.....F S BAR("ADJ TYP")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"),BAR("ADJ TYP"))) Q:BAR("ADJ TYP")="" D
......I BARACNT'=0 W !,BARREC_U_U
......W U_BAR("ADJIEN")_U_BAR("ADJ")_U_$G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"),BAR("ADJ TYP"))) ;bar*1.8*20
......S BARACNT=1
.....;end new NOHEAT
;detail lines
I '$D(^TMP($J,"BAR-TRANS"))&(BARY("RTYP")=2) D Q
.W !!!!!?25,"*** NO DATA TO PRINT ***"
.D EOP^BARUTL(0)
I $D(^TMP($J,"BAR-TRANS")) D
.W !,"LOCATION^ALLOWANCE CAT^INSURER TYPE^INSURER^BILL^DOS^APPROVAL DT^TOTAL BILL AMT^TOTAL PAYMENTS^#DAYS (DOS-APPR.DT)^ADJUSTMENT DT^ADJUSTMENT TYPE^ADJUSTMENT CATEGORY IEN^ADJUSTMENT CATEGORY^ADJUSTMENT AMOUNT^#DAYS (APPR.DT-ADJ.DT)"
S BAR("LOC")=0
F S BAR("LOC")=$O(^TMP($J,"BAR-TRANS",BAR("LOC"))) Q:'BAR("LOC") D
.S BAR("ITYP")=""
.F S BAR("ITYP")=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"))) Q:BAR("ITYP")="" D
.. I BAR("ITYP")="No Billing Entity" QUIT ;P.OTTIS HEAT #74599
..S BAR("INS")=""
..F S BAR("INS")=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"))) Q:BAR("INS")'?1N.N D
...S BARBILL=""
...F S BARBILL=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL)) Q:BARBILL="" D
....S BARO("LOC")=$P($G(^AUTTLOC(BAR("LOC"),0)),U,2)
....S BARO("ALLC")=$P($T(@BAR("ITYP")),";;",2)
....S BARO("ITYP")=$P($T(@BAR("ITYP")),";;",3)
....I BAR("INS")'=0 S BARO("INS")=$$GET1^DIQ(90050.02,BAR("INS")_",",.01) I 1
....E S BARO("INS")="No A/R Account"
....S BARREC=BARO("LOC")_U_BARO("ALLC")_U_BARO("ITYP")_U_BARO("INS")_U_BARBILL_U
....S BARDTAIL=$G(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL))
....W !,BARREC_BARDTAIL
....I $D(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS")) D
.....S BARACNT=0
.....F S BARACNT=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",BARACNT)) Q:'BARACNT D
......I BARACNT>1 D
.......I BARDET D W !,BARREC_BARDTAIL
.......E W !,BARREC_U_U_U_U
......W U_$G(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",BARACNT))
Q
HDB ; EP
; Page & column hdr
;EP for writing Rpt Hdr
W $$EN^BARVDF("IOF"),!
I $D(BAR("PRIVACY")) W ?($S($D(BAR(132)):34,$D(BAR(180)):68,1:8)),"WARNING: Confidential Patient Information, Privacy Act Applies",!
K BAR("LINE")
S $P(BAR("LINE"),"=",$S($D(BAR(133)):132,$D(BAR(180)):181,1:81))=""
W BAR("LINE"),!
W BAR("HD",0),?$S($D(BAR(132)):102,$D(BAR(180)):150,1:51)
D NOW^%DTC
S Y=%
X ^DD("DD")
W $P(Y,":",1,2)
S BAR("TMPLVL")=0
F S BAR("TMPLVL")=$O(BAR("HD",BAR("TMPLVL"))) Q:'BAR("TMPLVL")&(BAR("TMPLVL")'=0) W:$G(BAR("HD",BAR("TMPLVL")))]"" !,BAR("HD",BAR("TMPLVL"))
W !,BAR("LINE")
K BAR("LINE")
Q
;
; ********************************************************************
;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
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
MC ;;MEDICARE;;MCR PART C
F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
V ;;VETERAN;;VETERANS MEDICAL BENEFITS
;;***END OF TABLE**
;EOR - IHS/DIT/CPC 1.8*28
BARTRNS3 ; IHS/SD/SDR - Transaction Summary/Detail Report OVERFLOW CODE; 03/10/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**28**;OCT 26, 2005;Build 92
+2 ;IHS/SD/POT - 1.8*28 - CR8397 HEAT155084 - OVERFLOW CODE OF BARTRNS2 NEW ROUTINE CLONED FROM BARTRNS1
+3 QUIT
TRANS ;EP Loop thru Trans File
+1 ; for checking Trans File data parms
+2 ;A/R Trans 0 node
SET BARTR(0)=$GET(^BARTR(DUZ(2),BARTR,0))
+3 ;A/R Trans 1 node
SET BARTR(1)=$GET(^BARTR(DUZ(2),BARTR,1))
+4 ;Trans type
SET BARTR("TTYP")=$PIECE(BARTR(1),U)
+5 ;Adj Cat
SET BARTR("ADJ CAT")=$PIECE(BARTR(1),U,2)
+6 ;Adj Type
SET BARTR("ADJ TYPE")=$$GET1^DIQ(90052.02,$PIECE(BARTR(1),U,3),.01)
+7 ;PKD 1.8*19 include ADJ TYPE IEN on rpt -> BARTR("ADJ TYPIEN")
+8 SET BARTR("ADJ TYPIEN")=$PIECE(BARTR(1),U,3)
+9 IF BARTR("ADJ CAT")=""
SET BARTR("ADJ CAT")="NULL"
+10 ;1.8*19 Use space if ADJ TYP IEN is null to prevent subscript error
+11 ;S:(BARTR("ADJ TYPE")="") BARTR("ADJ TYPE")="NULL"
+12 IF BARTR("ADJ TYPE")=""
SET BARTR("ADJ TYPE")="NULL"
SET BARTR("ADJ TYPIEN")=" "
ADJTY ;PKD 1.8*20 Check for Inclusion ADJ TYPE
IF $DATA(BARY("ADJ TYP"))
IF '$DATA(BARY("ADJ TYP",BARTR("ADJ TYPIEN")))
QUIT
+1 ;Trans date/time
SET BARTR("DT")=$PIECE(BARTR(0),U)
+2 SET BARTR("TAMT")=$$GET1^DIQ(90050.03,BARTR,3.5)
+3 ;A/R Acct
SET BARTR("INS")=$PIECE(BAR(0),U,3)
+4 IF BARTR("INS")]""
Begin DoDot:1
+5 SET D0=BARTR("INS")
+6 ;Ins Type CODE
SET BARTR("ITYP")=$$VALI^BARVPM(8)
End DoDot:1
+7 IF BARY("RTYP")=1
DO SUMMARY
+8 IF BARY("RTYP")=2
DO DETAIL
+9 QUIT
SUMMARY ;left of the "=" - LOC^INS TYPE^INSURER
+1 ;right of the "=" - BILL COUNT^TOTAL BILL AMT^TOTAL PYMTS^ADJ TYPE^TOTAL ADJS
+2 ; ***PKD 1.8*19 adding "ADJ TYPIEN" before ADJ TYPE for sort
+3 ; ***& splitting long lines for SAC and clarity in reading
+4 ; update: bill count; total bill amount ;total pymts
+5 ; 1.8*19 Lines too long w/out change - Line body must not exceed 245 characters
+6 IF BARTR("TTYP")=40
Begin DoDot:1
+7 SET $PIECE(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=+$PIECE($GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)+$GET(BARTR("TAMT"))
End DoDot:1
+8 ;bar*1.8*20
IF BARTR("TTYP")=43!(BARTR("TTYP")=993)
Begin DoDot:1
+9 IF +$PIECE($GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)=0
SET $PIECE(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=0
+10 NEW NODE
+11 ;total adjs bar*1.8*20
SET NODE=$GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPIEN"),BARTR("ADJ TYPE")))
+12 SET $PIECE(NODE,U)=$PIECE(NODE,U)+$GET(BARTR("TAMT"))
+13 ;bar*1.8*20
SET $PIECE(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPIEN"),BARTR("ADJ TYPE")),U)=NODE
End DoDot:1
+14 QUIT
+15 IF BARTR("TTYP")=40
Begin DoDot:1
+16 SET $PIECE(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=+$PIECE($GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)+$GET(BARTR("TAMT"))
End DoDot:1
+17 ;total adjs
+18 IF BARTR("TTYP")=43
Begin DoDot:1
+19 IF +$PIECE($GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))),U,3)=0
SET $PIECE(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")),U,3)=0
+20 ;total adjs
SET $PIECE(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPE")),U)=+$PIECE($GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BARTR("ADJ TYPE"))),U)+$GET(BARTR("TAMT"))
End DoDot:1
+21 QUIT
+22 ;
DETAIL ;left of the "=" - LOC^ALLOW CAT^INS TYPE^INSURER^BILL
+1 ;right of the "=" - DOS^APPROVAL DT^TOTAL BILL AMT^TOTAL PYMTS^# DAYS (DOS-APPR.DT)
+2 ; if adj
+3 ;right of the "=" - ADJ DT^ADJ TYPE^ADJ AMT^#DAYS (APPR.DT-ADJ.DT)
+4 SET $PIECE(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U)=$$SDT^BARDUTL(BAR("DOS"))
+5 SET $PIECE(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,2)=$$CDT^BARDUTL(BAR("APPDT"))
+6 SET $PIECE(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,3)=BAR("BAMT")
+7 ;# of days between appr. date & DOS
+8 SET X1=BAR("APPDT")
+9 SET X2=BAR("DOS")
+10 DO ^%DTC
+11 SET $PIECE(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,5)=X
+12 ;
+13 IF BARTR("TTYP")=40
Begin DoDot:1
+14 SET $PIECE(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,4)=$PIECE(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,4)+BARTR("TAMT")
End DoDot:1
+15 ;bar*1.8*20
IF BARTR("TTYP")=43!(BARTR("TTYP")=993)
Begin DoDot:1
+16 SET BAR(BARBILL)=+$GET(BAR(BARBILL))+1
+17 ;# of days between appr. date & adj date
+18 SET X1=+BARTR("DT")
+19 SET X2=BAR("APPDT")
+20 DO ^%DTC
+21 NEW NODE
+22 SET $PIECE(NODE,U)=$$CDT^BARDUTL(BARTR("DT"))
+23 ;adj type
SET $PIECE(NODE,U,2)=BARTR("ADJ TYPIEN")
+24 SET $PIECE(NODE,U,3)=BARTR("ADJ CAT")
+25 ;adj category
SET $PIECE(NODE,U,4)=BARTR("ADJ TYPE")
+26 ;adj amt
SET $PIECE(NODE,U,5)=BARTR("TAMT")
+27 ;# days
SET $PIECE(NODE,U,6)=X
+28 SET ^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",+$GET(BAR(BARBILL)))=NODE
End DoDot:1
+29 QUIT
PRINT ;
+1 DO HDB
+2 IF '$DATA(^TMP($JOB,"BAR-TRANST"))&(BARY("RTYP")=1)
Begin DoDot:1
+3 WRITE !!!!!?25,"*** NO DATA TO PRINT ***"
+4 DO EOP^BARUTL(0)
End DoDot:1
QUIT
+5 ;summary lines
+6 IF $DATA(^TMP($JOB,"BAR-TRANST"))
WRITE !,"LOCATION^ALLOWANCE CAT^INSURER TYPE^INSURER^BILL COUNT^TOTAL BILL AMOUNT^TOTAL PAYMENTS^ADJ TYPE IEN^ADJUSTMENT TYPE^TOTAL ADJUSTMENTS"
+7 SET BAR("LOC")=0
+8 FOR
SET BAR("LOC")=$ORDER(^TMP($JOB,"BAR-TRANST",BAR("LOC")))
IF 'BAR("LOC")
QUIT
Begin DoDot:1
+9 SET BAR("ITYP")=""
+10 FOR
SET BAR("ITYP")=$ORDER(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP")))
IF BAR("ITYP")=""
QUIT
Begin DoDot:2
+11 ;P.OTTIS HEAT #74599
IF BAR("ITYP")="No Billing Entity"
QUIT
+12 SET BAR("INS")=""
+13 FOR
SET BAR("INS")=$ORDER(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")))
IF BAR("INS")'?1N.N
QUIT
Begin DoDot:3
+14 SET BARO("LOC")=$PIECE($GET(^AUTTLOC(BAR("LOC"),0)),U,2)
+15 SET BARO("ALLC")=$PIECE($TEXT(@BAR("ITYP")),";;",2)
+16 SET BARO("ITYP")=$PIECE($TEXT(@BAR("ITYP")),";;",3)
+17 IF BAR("INS")'=0
SET BARO("INS")=$$GET1^DIQ(90050.02,BAR("INS")_",",.01)
IF 1
+18 IF '$TEST
SET BARO("INS")="No A/R Account"
+19 SET BARREC=BARO("LOC")_U_BARO("ALLC")_U_BARO("ITYP")_U_BARO("INS")_U
+20 WRITE !,BARREC_$GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")))
+21 IF $DATA(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS"))
Begin DoDot:4
+22 ;only one AdjType per AdjTypeIEN
SET (BAR("ADJ"),BAR("ADJIEN"))=""
+23 SET BARACNT=0
+24 FOR
SET BAR("ADJIEN")=$ORDER(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN")))
IF BAR("ADJIEN")=""
QUIT
Begin DoDot:5
+25 ;bar*1.8*20
SET BAR("ADJ")=$ORDER(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"),""))
+26 SET BAR("ADJ TYP")=""
+27 FOR
SET BAR("ADJ TYP")=$ORDER(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"),BAR("ADJ TYP")))
IF BAR("ADJ TYP")=""
QUIT
Begin DoDot:6
+28 IF BARACNT'=0
WRITE !,BARREC_U_U
+29 ;bar*1.8*20
WRITE U_BAR("ADJIEN")_U_BAR("ADJ")_U_$GET(^TMP($JOB,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"),BAR("ADJ TYP")))
+30 SET BARACNT=1
End DoDot:6
+31 ;end new NOHEAT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;detail lines
+33 IF '$DATA(^TMP($JOB,"BAR-TRANS"))&(BARY("RTYP")=2)
Begin DoDot:1
+34 WRITE !!!!!?25,"*** NO DATA TO PRINT ***"
+35 DO EOP^BARUTL(0)
End DoDot:1
QUIT
+36 IF $DATA(^TMP($JOB,"BAR-TRANS"))
Begin DoDot:1
+37 WRITE !,"LOCATION^ALLOWANCE CAT^INSURER TYPE^INSURER^BILL^DOS^APPROVAL DT^TOTAL BILL AMT^TOTAL PAYMENTS^#DAYS (DOS-APPR.DT)^ADJUSTMENT DT^ADJUSTMENT TYPE^ADJUSTMENT CATEGORY IEN^ADJUSTMENT CATEGORY^ADJUSTMENT AMOUNT^#DAYS (APPR.DT-ADJ.D
T)"
End DoDot:1
+38 SET BAR("LOC")=0
+39 FOR
SET BAR("LOC")=$ORDER(^TMP($JOB,"BAR-TRANS",BAR("LOC")))
IF 'BAR("LOC")
QUIT
Begin DoDot:1
+40 SET BAR("ITYP")=""
+41 FOR
SET BAR("ITYP")=$ORDER(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP")))
IF BAR("ITYP")=""
QUIT
Begin DoDot:2
+42 ;P.OTTIS HEAT #74599
IF BAR("ITYP")="No Billing Entity"
QUIT
+43 SET BAR("INS")=""
+44 FOR
SET BAR("INS")=$ORDER(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS")))
IF BAR("INS")'?1N.N
QUIT
Begin DoDot:3
+45 SET BARBILL=""
+46 FOR
SET BARBILL=$ORDER(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL))
IF BARBILL=""
QUIT
Begin DoDot:4
+47 SET BARO("LOC")=$PIECE($GET(^AUTTLOC(BAR("LOC"),0)),U,2)
+48 SET BARO("ALLC")=$PIECE($TEXT(@BAR("ITYP")),";;",2)
+49 SET BARO("ITYP")=$PIECE($TEXT(@BAR("ITYP")),";;",3)
+50 IF BAR("INS")'=0
SET BARO("INS")=$$GET1^DIQ(90050.02,BAR("INS")_",",.01)
IF 1
+51 IF '$TEST
SET BARO("INS")="No A/R Account"
+52 SET BARREC=BARO("LOC")_U_BARO("ALLC")_U_BARO("ITYP")_U_BARO("INS")_U_BARBILL_U
+53 SET BARDTAIL=$GET(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL))
+54 WRITE !,BARREC_BARDTAIL
+55 IF $DATA(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS"))
Begin DoDot:5
+56 SET BARACNT=0
+57 FOR
SET BARACNT=$ORDER(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",BARACNT))
IF 'BARACNT
QUIT
Begin DoDot:6
+58 IF BARACNT>1
Begin DoDot:7
+59 IF BARDET
Begin DoDot:8
End DoDot:8
WRITE !,BARREC_BARDTAIL
+60 IF '$TEST
WRITE !,BARREC_U_U_U_U
End DoDot:7
+61 WRITE U_$GET(^TMP($JOB,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",BARACNT))
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+62 QUIT
HDB ; EP
+1 ; Page & column hdr
+2 ;EP for writing Rpt Hdr
+3 WRITE $$EN^BARVDF("IOF"),!
+4 IF $DATA(BAR("PRIVACY"))
WRITE ?($SELECT($DATA(BAR(132)):34,$DATA(BAR(180)):68,1:8)),"WARNING: Confidential Patient Information, Privacy Act Applies",!
+5 KILL BAR("LINE")
+6 SET $PIECE(BAR("LINE"),"=",$SELECT($DATA(BAR(133)):132,$DATA(BAR(180)):181,1:81))=""
+7 WRITE BAR("LINE"),!
+8 WRITE BAR("HD",0),?$SELECT($DATA(BAR(132)):102,$DATA(BAR(180)):150,1:51)
+9 DO NOW^%DTC
+10 SET Y=%
+11 XECUTE ^DD("DD")
+12 WRITE $PIECE(Y,":",1,2)
+13 SET BAR("TMPLVL")=0
+14 FOR
SET BAR("TMPLVL")=$ORDER(BAR("HD",BAR("TMPLVL")))
IF 'BAR("TMPLVL")&(BAR("TMPLVL")'=0)
QUIT
IF $GET(BAR("HD",BAR("TMPLVL")))]""
WRITE !,BAR("HD",BAR("TMPLVL"))
+15 WRITE !,BAR("LINE")
+16 KILL BAR("LINE")
+17 QUIT
+18 ;
+19 ; ********************************************************************
+20 ;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
+21 ;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
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
MC ;;MEDICARE;;MCR PART C
F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
V ;;VETERAN;;VETERANS MEDICAL BENEFITS
+1 ;;***END OF TABLE**
+2 ;EOR - IHS/DIT/CPC 1.8*28
