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

BARTRNS3.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/SD/POT - 1.8*28 - CR8397 HEAT155084 - OVERFLOW CODE OF BARTRNS2 NEW ROUTINE CLONED FROM BARTRNS1
  1.  Q
  1. TRANS ;EP Loop thru Trans File
  1.  ; for checking Trans File data parms
  1.  S BARTR(0)=$G(^BARTR(DUZ(2),BARTR,0))  ;A/R Trans 0 node
  1.  S BARTR(1)=$G(^BARTR(DUZ(2),BARTR,1))  ;A/R Trans 1 node
  1.  S BARTR("TTYP")=$P(BARTR(1),U)  ;Trans type
  1.  S BARTR("ADJ CAT")=$P(BARTR(1),U,2)  ;Adj Cat
  1.  S BARTR("ADJ TYPE")=$$GET1^DIQ(90052.02,$P(BARTR(1),U,3),.01)  ;Adj Type
  1.  ;PKD 1.8*19 include ADJ TYPE IEN on rpt -> BARTR("ADJ TYPIEN")
  1.  S BARTR("ADJ TYPIEN")=$P(BARTR(1),U,3)
  1.  S:BARTR("ADJ CAT")="" BARTR("ADJ CAT")="NULL"
  1.  ;1.8*19 Use space if ADJ TYP IEN is null to prevent subscript error
  1.  ;S:(BARTR("ADJ TYPE")="") BARTR("ADJ TYPE")="NULL"
  1.  I BARTR("ADJ TYPE")="" S BARTR("ADJ TYPE")="NULL",BARTR("ADJ TYPIEN")=" "
  1. ADJTY I $D(BARY("ADJ TYP")) Q:'$D(BARY("ADJ TYP",BARTR("ADJ TYPIEN")))  ;PKD 1.8*20 Check for Inclusion ADJ TYPE
  1.  S BARTR("DT")=$P(BARTR(0),U)  ;Trans date/time
  1.  S BARTR("TAMT")=$$GET1^DIQ(90050.03,BARTR,3.5)
  1.  S BARTR("INS")=$P(BAR(0),U,3)  ;A/R Acct
  1.  I BARTR("INS")]"" D
  1.  .S D0=BARTR("INS")
  1.  .S BARTR("ITYP")=$$VALI^BARVPM(8)  ;Ins Type CODE
  1.  I BARY("RTYP")=1 D SUMMARY
  1.  I BARY("RTYP")=2 D DETAIL
  1.  Q
  1. SUMMARY ;left of the "=" - LOC^INS TYPE^INSURER
  1.  ;right of the "=" - BILL COUNT^TOTAL BILL AMT^TOTAL PYMTS^ADJ TYPE^TOTAL ADJS
  1.  ;  ***PKD 1.8*19 adding "ADJ TYPIEN" before ADJ TYPE for sort 
  1.  ;  ***& splitting long lines for SAC and clarity in reading
  1.  ; update: bill count; total bill amount ;total pymts
  1.  ; 1.8*19 Lines too long w/out change - Line body must not exceed 245 characters
  1.  I BARTR("TTYP")=40 D
  1.  .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"))
  1.  I BARTR("TTYP")=43!(BARTR("TTYP")=993) D  ;bar*1.8*20
  1.  .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
  1.  .N NODE
  1.  .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
  1.  .S $P(NODE,U)=$P(NODE,U)+$G(BARTR("TAMT"))
  1.  .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
  1.  Q
  1.  I BARTR("TTYP")=40 D
  1.  .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"))
  1.  ;total adjs
  1.  I BARTR("TTYP")=43 D
  1.  .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
  1.  .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
  1.  Q
  1.  ;
  1. 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)
  1.  ; if adj
  1.  ;right of the "=" - ADJ DT^ADJ TYPE^ADJ AMT^#DAYS (APPR.DT-ADJ.DT)
  1.  S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U)=$$SDT^BARDUTL(BAR("DOS"))
  1.  S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,2)=$$CDT^BARDUTL(BAR("APPDT"))
  1.  S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,3)=BAR("BAMT")
  1.  ;# of days between appr. date & DOS
  1.  S X1=BAR("APPDT")
  1.  S X2=BAR("DOS")
  1.  D ^%DTC
  1.  S $P(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL),U,5)=X
  1.  ;
  1.  I BARTR("TTYP")=40 D
  1.  .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")
  1.  I BARTR("TTYP")=43!(BARTR("TTYP")=993) D  ;bar*1.8*20
  1.  .S BAR(BARBILL)=+$G(BAR(BARBILL))+1
  1.  .;# of days between appr. date & adj date
  1.  .S X1=+BARTR("DT")
  1.  .S X2=BAR("APPDT")
  1.  .D ^%DTC
  1.  .N NODE
  1.  .S $P(NODE,U)=$$CDT^BARDUTL(BARTR("DT"))
  1.  .S $P(NODE,U,2)=BARTR("ADJ TYPIEN")  ;adj type
  1.  .S $P(NODE,U,3)=BARTR("ADJ CAT")
  1.  .S $P(NODE,U,4)=BARTR("ADJ TYPE")  ;adj category
  1.  .S $P(NODE,U,5)=BARTR("TAMT")  ;adj amt
  1.  .S $P(NODE,U,6)=X  ;# days
  1.  .S ^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",+$G(BAR(BARBILL)))=NODE
  1.  Q
  1. PRINT ;
  1.  D HDB
  1.  I '$D(^TMP($J,"BAR-TRANST"))&(BARY("RTYP")=1) D  Q
  1.  .W !!!!!?25,"*** NO DATA TO PRINT ***"
  1.  .D EOP^BARUTL(0)
  1.  ;summary lines
  1.  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"
  1.  S BAR("LOC")=0
  1.  F  S BAR("LOC")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"))) Q:'BAR("LOC")  D
  1.  .S BAR("ITYP")=""
  1.  .F  S BAR("ITYP")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"))) Q:BAR("ITYP")=""  D
  1.  .. I BAR("ITYP")="No Billing Entity" QUIT  ;P.OTTIS HEAT #74599 
  1.  ..S BAR("INS")=""
  1.  ..F  S BAR("INS")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"))) Q:BAR("INS")'?1N.N  D
  1.  ...S BARO("LOC")=$P($G(^AUTTLOC(BAR("LOC"),0)),U,2)
  1.  ...S BARO("ALLC")=$P($T(@BAR("ITYP")),";;",2)
  1.  ...S BARO("ITYP")=$P($T(@BAR("ITYP")),";;",3)
  1.  ...I BAR("INS")'=0 S BARO("INS")=$$GET1^DIQ(90050.02,BAR("INS")_",",.01) I 1
  1.  ...E  S BARO("INS")="No A/R Account"
  1.  ...S BARREC=BARO("LOC")_U_BARO("ALLC")_U_BARO("ITYP")_U_BARO("INS")_U
  1.  ...W !,BARREC_$G(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS")))
  1.  ...I $D(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS")) D
  1.  ....S (BAR("ADJ"),BAR("ADJIEN"))=""  ;only one AdjType per AdjTypeIEN
  1.  ....S BARACNT=0
  1.  ....F  S BAR("ADJIEN")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"))) Q:BAR("ADJIEN")=""  D
  1.  .....S BAR("ADJ")=$O(^TMP($J,"BAR-TRANST",BAR("LOC"),BAR("ITYP"),BAR("INS"),"ADJS",BAR("ADJIEN"),""))  ;bar*1.8*20
  1.  .....S BAR("ADJ TYP")=""
  1.  .....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
  1.  ......I BARACNT'=0 W !,BARREC_U_U
  1.  ......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
  1.  ......S BARACNT=1
  1.  .....;end new NOHEAT
  1.  ;detail lines
  1.  I '$D(^TMP($J,"BAR-TRANS"))&(BARY("RTYP")=2) D  Q
  1.  .W !!!!!?25,"*** NO DATA TO PRINT ***"
  1.  .D EOP^BARUTL(0)
  1.  I $D(^TMP($J,"BAR-TRANS")) D
  1.  .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)"
  1.  S BAR("LOC")=0
  1.  F  S BAR("LOC")=$O(^TMP($J,"BAR-TRANS",BAR("LOC"))) Q:'BAR("LOC")  D
  1.  .S BAR("ITYP")=""
  1.  .F  S BAR("ITYP")=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"))) Q:BAR("ITYP")=""  D
  1.  .. I BAR("ITYP")="No Billing Entity" QUIT  ;P.OTTIS HEAT #74599 
  1.  ..S BAR("INS")=""
  1.  ..F  S BAR("INS")=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"))) Q:BAR("INS")'?1N.N  D
  1.  ...S BARBILL=""
  1.  ...F  S BARBILL=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL)) Q:BARBILL=""  D
  1.  ....S BARO("LOC")=$P($G(^AUTTLOC(BAR("LOC"),0)),U,2)
  1.  ....S BARO("ALLC")=$P($T(@BAR("ITYP")),";;",2)
  1.  ....S BARO("ITYP")=$P($T(@BAR("ITYP")),";;",3)
  1.  ....I BAR("INS")'=0 S BARO("INS")=$$GET1^DIQ(90050.02,BAR("INS")_",",.01) I 1
  1.  ....E  S BARO("INS")="No A/R Account"
  1.  ....S BARREC=BARO("LOC")_U_BARO("ALLC")_U_BARO("ITYP")_U_BARO("INS")_U_BARBILL_U
  1.  ....S BARDTAIL=$G(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL))
  1.  ....W !,BARREC_BARDTAIL
  1.  ....I $D(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS")) D
  1.  .....S BARACNT=0
  1.  .....F  S BARACNT=$O(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",BARACNT)) Q:'BARACNT  D
  1.  ......I BARACNT>1 D
  1.  .......I BARDET D  W !,BARREC_BARDTAIL
  1.  .......E  W !,BARREC_U_U_U_U
  1.  ......W U_$G(^TMP($J,"BAR-TRANS",BAR("LOC"),BAR("ITYP"),BAR("INS"),BARBILL,"ADJS",BARACNT))
  1.  Q
  1. HDB ; EP
  1.  ; Page & column hdr
  1.  ;EP for writing Rpt Hdr
  1.  W $$EN^BARVDF("IOF"),!
  1.  I $D(BAR("PRIVACY")) W ?($S($D(BAR(132)):34,$D(BAR(180)):68,1:8)),"WARNING: Confidential Patient Information, Privacy Act Applies",!
  1.  K BAR("LINE")
  1.  S $P(BAR("LINE"),"=",$S($D(BAR(133)):132,$D(BAR(180)):181,1:81))=""
  1.  W BAR("LINE"),!
  1.  W BAR("HD",0),?$S($D(BAR(132)):102,$D(BAR(180)):150,1:51)
  1.  D NOW^%DTC
  1.  S Y=%
  1.  X ^DD("DD")
  1.  W $P(Y,":",1,2)
  1.  S BAR("TMPLVL")=0
  1.  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"))
  1.  W !,BAR("LINE")
  1.  K BAR("LINE")
  1.  Q
  1.  ;
  1.  ; ********************************************************************
  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. 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. MC ;;MEDICARE;;MCR PART C
  1. F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
  1. V ;;VETERAN;;VETERANS MEDICAL BENEFITS
  1.   ;;***END OF TABLE**
  1.  ;EOR - IHS/DIT/CPC 1.8*28