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

BARRPPS.m

Go to the documentation of this file. 
  1. BARRPPS ; IHS/SD/SDR - Patient Payment Summary ;08/20/2008
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**28**;OCT 26, 2005;Build 92
  1.  ;IHS/SD/SDR 1.8*28 CR9580 HEAT303780 Routine created
  1.  Q
  1.  ; ***************************************
  1. EN ;EP
  1.  K ^TMP($J,"BAR-PPS"),BAREND
  1.  D ACCTS  ;select A/R Account
  1.  D:'$D(BAREND) DT  ;select A/R Collection Batch date range
  1.  D:'$D(BAREND) COMMENTS  ;Y/N if commments from item should print on report or not
  1.  G:$D(BAREND) CLEANUP
  1. SEL ;Select device
  1.  S %ZIS="Q"
  1.  S %ZIS("A")="Enter DEVICE: "
  1.  D ^%ZIS Q:POP
  1.  I IO'=IO(0) D QUE,HOME^%ZIS S DIR(0)="E" D ^DIR K DIR Q
  1.  S IOP=ION D ^%ZIS
  1.  D PRINT
  1.  Q
  1. QUE ;EP
  1.  K IO("Q")
  1.  S ZTRTN="PRINT^BARRPPS",ZTDESC="Patient Payment Summary"
  1.  S ZTSAVE("BAR*")=""
  1.  D ^%ZTLOAD
  1.  D ^%ZISC
  1.  I $D(ZTSK)[0 W !!?5,"REPORT CANCELLED!"
  1.  E  W !!?5,"REQUEST QUEUED AS TASK # "_ZTSK_" !",!
  1.  Q
  1. ACCTS ;EP
  1.  ; Select A/R Accounts to sort by
  1.  K BARY("ACCT")
  1.  D ^XBFMK
  1.  S DIC="^BARAC(DUZ(2),"
  1.  S DIC(0)="AEMQ"
  1.  S DIC("S")="I $P(^BARAC(DUZ(2),Y,0),U)[""AUPNPAT"""
  1.  S DIC("A")="Select A/R Account: "
  1.  F  D  Q:+Y<0
  1.  .I $D(BARY("ACCT")) S DIC("A")="Select Another A/R Account: "
  1.  .D ^DIC
  1.  .I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAREND=1 Q
  1.  .Q:+Y<0
  1.  .S BARY("ACCT",+Y)=""
  1.  I '$D(BARY("ACCT")),('$D(BAREND)) W !!,"At least one A/R account is required. Enter '^' to exit",! K DIC G ACCTS  ;IHS/DIT/CPC - 20170427 CR9580 BAR*1.8*28
  1.  K DIC
  1.  Q
  1. DT ;EP
  1.  D ^XBFMK
  1.  W !!," ============ Entry of A/R Collection Batch Range =============",!
  1.  S DIR("A")="Enter A/R Collection Batch STARTING DATE for the Report"
  1.  S DIR(0)="DOE"
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAREND=1 Q
  1.  G DT:$D(DIRUT)
  1.  S BARY("DT",1)=Y
  1.  W !
  1.  S DIR("A")="Enter ENDING DATE for the Report"
  1.  S DIR(0)="DOE"
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAREND=1 Q
  1.  G DT:$D(DIRUT)
  1.  S BARY("DT",2)=Y
  1.  I BARY("DT",1)>BARY("DT",2) W !!,*7,"INPUT ERROR: Start Date is Greater than the End Date, TRY AGAIN!",!! G DT
  1.  Q
  1. COMMENTS ;EP
  1.  D ^XBFMK
  1.  W !
  1.  S DIR("A")="Print Collection Batch Comments (if Present)"
  1.  S DIR("B")="No"
  1.  S DIR(0)="Y"
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAREND=1 Q
  1.  S BARY("COMM",1)=Y
  1.  K DIR
  1.  Q
  1.  ;
  1. PRINT ; EP
  1.  ;Gather data for each patient and print summary
  1.  S BARACCTI=0
  1.  F  S BARACCTI=$O(BARY("ACCT",BARACCTI))  Q:'BARACCTI  D
  1.  .K ^TMP($J,"BAR-PPS")
  1.  .S BAR("PG")=1
  1.  .D GATHER  ;gather data
  1.  .D CALC  ;goes through found data and creates totals
  1.  .D SUMMARY  ;print summary
  1.  Q
  1.  ; ***************************************
  1. GATHER ;EP
  1.  S BARSDT=BARY("DT",1)-.1
  1.  S BAREDT=BARY("DT",2)+.999999
  1.  F  S BARSDT=$O(^BARCOL(DUZ(2),"C",BARSDT)) Q:'BARSDT!(BARSDT>BAREDT)  D
  1.  .S BARCOL=0
  1.  .F  S BARCOL=$O(^BARCOL(DUZ(2),"C",BARSDT,BARCOL)) Q:'BARCOL  D
  1.  ..S BARITEM=0
  1.  ..F  S BARITEM=$O(^BARCOL(DUZ(2),BARCOL,1,BARITEM)) Q:'BARITEM  D
  1.  ...I $P($G(^BARCOL(DUZ(2),BARCOL,1,BARITEM,0)),U,7)'=BARACCTI Q  ;not our A/R Account
  1.  ...S BARPTYP=$$GET1^DIQ(90052.02,$P($G(^BARCOL(DUZ(2),BARCOL,1,BARITEM,0)),U,2),6)
  1.  ...I "^CA^CC^CK^GL^"'[("^"_BARPTYP_"^") Q  ;only want Cash, Credit Card, Check, and General Ledger
  1.  ...S BARCCRDT=$P($G(^BARCOL(DUZ(2),BARCOL,1,BARITEM,1)),U)
  1.  ...S BARCDBT=$P($G(^BARCOL(DUZ(2),BARCOL,1,BARITEM,1)),U,2)
  1.  ...S BARRCPT=$$GET1^DIQ(90050.06,$P($G(^BARCOL(DUZ(2),BARCOL,1,BARITEM,0)),U,23),".01")
  1.  ...S ^TMP($J,"BAR-PPS",BARSDT,BARCOL,BARITEM)=BARPTYP_U_(BARCCRDT-BARCDBT)_U_BARRCPT
  1.  Q
  1. CALC ;EP
  1.  Q:'$D(^TMP($J,"BAR-PPS"))  ;no data found for A/R Account
  1.  S BARPCNT=0
  1.  S BARSDT=0
  1.  F  S BARSDT=$O(^TMP($J,"BAR-PPS",BARSDT)) Q:'BARSDT  D
  1.  .S BARCOL=0
  1.  .F  S BARCOL=$O(^TMP($J,"BAR-PPS",BARSDT,BARCOL)) Q:'BARCOL  D
  1.  ..S BARITEM=0
  1.  ..F  S BARITEM=$O(^TMP($J,"BAR-PPS",BARSDT,BARCOL,BARITEM)) Q:'BARITEM  D
  1.  ...S $P(^TMP($J,"BAR-PPS","TOT"),U)=+$P(+$G(^TMP($J,"BAR-PPS","TOT")),U)+$P($G(^TMP($J,"BAR-PPS",BARSDT,BARCOL,BARITEM)),U,2)  ;total amount batched
  1.  ...;look through transactions for payments posted; this is posted amount
  1.  ...S BARTRANS=0
  1.  ...F  S BARTRANS=$O(^BARTR(DUZ(2),"ACB",BARCOL,BARITEM,40,BARTRANS)) Q:'BARTRANS  D
  1.  ....S $P(^TMP($J,"BAR-PPS","TOT"),U,2)=(+$P($G(^TMP($J,"BAR-PPS","TOT")),U,2)+($$GET1^DIQ(90050.03,BARTRANS,"3.5")))  ;total amount posted
  1.  ....S BARPCNT=+$G(BARPCNT)+1
  1.  S $P(^TMP($J,"BAR-PPS","TOT"),U,3)=(($P($G(^TMP($J,"BAR-PPS","TOT")),U))-($P($G(^TMP($J,"BAR-PPS","TOT")),U,2)))  ;total to be posted
  1.  S $P(^TMP($J,"BAR-PPS","TOT"),U,4)=+BARPCNT  ;Payment Count
  1.  Q
  1.  ; ***************************************
  1.  ;
  1. SUMMARY ;
  1.  ; Print report if user selected SORT CRITERIA Billing Entity or
  1.  ; Allowance Category and Report Type w/o payers
  1.  ;
  1.  S BAR("PG")=0
  1.  D HDB                             ; Page and column header
  1.  I '$D(^TMP($J,"BAR-PPS")) D  Q           ; No data - quit
  1.  .W !!!!!?25,"*** NO DATA TO PRINT ***"
  1.  .D EOP^BARUTL(0)
  1.  S BARSDT=0
  1.  F  S BARSDT=$O(^TMP($J,"BAR-PPS",BARSDT)) Q:'BARSDT  D  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  .S BARCLIEN=0
  1.  .F  S BARCLIEN=$O(^TMP($J,"BAR-PPS",BARSDT,BARCLIEN)) Q:'BARCLIEN  D  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  ..S BARITEM=0
  1.  ..F  S BARITEM=$O(^TMP($J,"BAR-PPS",BARSDT,BARCLIEN,BARITEM)) Q:'BARITEM  D  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  ...I $Y>(IOSL-5) D HD Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  ...W !,$E($P($G(^BARCOL(DUZ(2),BARCLIEN,0)),U),1,26) ;COLLECTION BATCH
  1.  ...W ?27,BARITEM  ;COLLECTION BATCH ITEM #
  1.  ...W ?30,$P($G(^TMP($J,"BAR-PPS",BARSDT,BARCLIEN,BARITEM)),U,3) ;RECEIPT #
  1.  ...W ?43,$P($G(^TMP($J,"BAR-PPS",BARSDT,BARCLIEN,BARITEM)),U)  ;TYPE OF PAYMENT
  1.  ...W ?49,$J($FN($P($G(^TMP($J,"BAR-PPS",BARSDT,BARCLIEN,BARITEM)),U,2),",",2),8) ;BATCH ITEM AMOUNT
  1.  ...D WRTBILL
  1.  ...I +$G(BARY("COMM",1))=1 D WRTCOMM
  1.  W !,?47,"__________",?68,"__________"  ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  W !,?45,$J($FN(+$P($G(^TMP($J,"BAR-PPS","TOT")),U),",",2),12),?66,$J($FN(+$P($G(^TMP($J,"BAR-PPS","TOT")),U,2),",",2),12),! ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  W !!,"REPORT COMPLETE FOR "_$$GET1^DIQ(90050.02,BARACCTI,".01","E")
  1.  D EOP^BARUTL(0)
  1.  Q
  1. WRTBILL ;EP
  1.  S BARTRANS=0,BARHASTR=0
  1.  F  S BARTRANS=$O(^BARTR(DUZ(2),"ACB",BARCLIEN,BARITEM,40,BARTRANS)) Q:'BARTRANS  D
  1.  .W ?58,$E($$GET1^DIQ(90050.01,$P($G(^BARTR(DUZ(2),BARTRANS,0)),U,4),".01","E"),1,10)  ;BILL NUMBER ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  .W ?70,$J($FN($$GET1^DIQ(90050.03,BARTRANS,"3.5","E"),",",2),8),! ;AMOUNT POSTED TO BILL ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  .S BARHASTR=1
  1.  Q
  1. WRTCOMM ;EP
  1.  I BARHASTR=0 W !  ;make sure comment starts on separate line
  1.  K BARCOM
  1.  S IENS=BARITEM_","_BARCLIEN_","
  1.  D GETS^DIQ(90051.1101,IENS,"301","","BARCOM")
  1.  I $G(BARCOM(90051.1101,IENS,301,1))="" Q  ;quit if no comment on item
  1.  W ?2,"Comment: "
  1.  S BARCNT=0
  1.  F  S BARCNT=$O(BARCOM(90051.1101,IENS,301,BARCNT)) Q:'BARCNT  D
  1.  .W !?4,$G(BARCOM(90051.1101,IENS,301,BARCNT))
  1.  Q
  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.  W $$EN^BARVDF("IOF"),!
  1.  D CENTER("Patient Payment Summary")
  1.  W !
  1.  D CENTER($P($G(^DIC(4,DUZ(2),0)),U))
  1.  W !
  1.  D NOW^%DTC
  1.  S Y=%
  1.  X ^DD("DD")
  1.  W $P(Y,":",1,2),?72,"Page ",BAR("PG")
  1.  S $P(BAR("DASH"),"-",$S($D(BAR(132)):132,1:80))=""
  1.  W !,BAR("DASH"),!
  1.  ;
  1.  W ?3,"Patient Name: ",$$GET1^DIQ(90050.02,BARACCTI,".01","E")
  1.  W ?50,"HRN: ",$P($G(^AUPNPAT($P($$GET1^DIQ(90050.02,BARACCTI,".01","I"),";"),41,DUZ(2),0)),U,2),!!
  1.  W "Total Amount Batched: ",$J($FN(+$P($G(^TMP($J,"BAR-PPS","TOT")),U),",",2),12)
  1.  W ?50,"Num of Pymts Posted: ",+$P($G(^TMP($J,"BAR-PPS","TOT")),U,4),!
  1.  W ?7,"Amount Posted: ",$J($FN(+$P($G(^TMP($J,"BAR-PPS","TOT")),U,2),",",2),12),!
  1.  W ?8,"To Be Posted: ",$J($FN(+$P($G(^TMP($J,"BAR-PPS","TOT")),U,3),",",2),12),!
  1.  W BAR("DASH"),!
  1.  W ?50,"Batched",?60,"Bill",?72,"Posted",!  ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  W "Collection Batch",?25,"Item",?30,"Receipt#",?42,"Type",?51,"Amount",?60,"Number",?72,"Amount",! ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  W BAR("DASH"),!
  1.  Q
  1. CENTER(X) ;EP
  1.  ;S CENTER=IOM/2  ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  S CENTER=$S($D(BAR(132)):132,1:80)/2  ;IHS/DIT/CPC - 20180427 CR9580 BAR*1.8*28
  1.  W ?CENTER-($L(X)/2),X
  1.  Q
  1. CLEANUP ;CLEAN VARIABLES
  1.  K BAREND,DIC,DIR
  1.  Q
  1.  ;EOR - IHS/DIT/CPC 1.8*28