BARRPAY.m

BARRPAY ; IHS/SD/PKD - TOP PAYERS REPORT ; 07/2/2010

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**19,23,24**;OCT 26, 2005;Build 69

 ; New Reports - Top Payers - PKD 

 ; IHS/SD/POTT 03/13ADDED NEW VA billing -BAR*1.8*23

 ; IHS/SD/POTT 07/13 ADDED SUPPORT FOR ICD-10 -BAR*1.8*23

 ; IHS/SD/POTT HEAT143222 01/14 FIX USER EXIT AFTER D MOREQ  - BAR*1.8*24

 Q

 ; *******************************

 ;

EN ; EP

 K BARY,BAR,PKD

 D:'$D(BARUSR) INIT^BARUTL  ;Setup basic A/R variables

 S BARP("RTN")="BARRPAY"  ; Routine used to get data

 S BAR("LOC")="BILLING"  ; Financial Reports - verify w/ Adrian/Gina -pkd

 D ^BARRSEL  ; Select exclusion parameters

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q

 D MOREQ  ; Additional Questions: Sort by; include CXL's; how many to top payers

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q  ;HEAT143222 BAR*1.8*24

 ;

HD S BAR("HD",0)=BARMENU

 D ^BARRHD  ; Report header

 ; Add additional Selection Criteria to the Headers

 I $D(BARY("DX"))!$D(BARY("DX9"))!$D(BARY("DX10")) D DX^BARRHD ;P.OTT -BAR*1.8*23

 ;

 I $D(BARY("CLIN")) D HDCLIN

 I $D(BARY("APPR")) D HDAPPR

 I $D(BARY("ADJTYP")) D HDRADJ

 D HDRSORT

 N SORT,SORTNM,SUBNM,T,TMP,TRIEN,VISITLOC,COUNT,ADJTYP

 S BARQ("RC")="COMPUTE^BARRPAY"  ; Compute routine

 S BARQ("RP")="PRINT^BARRPAY2"  ; Print routine

 S BARQ("NS")="BAR"  ; Namespace for variables

 S BARQ("RX")="POUT^BARRUTL"  ; Clean-up routine

 K ^TMP($J,"BAR-PAY"), ^TMP($J,"BAR-PAYS"), ^TMP($J,"BAR-PAYS1")

 D ^BARDBQUE  ; Double queuing

 ;D PAZ^BARRUTL

 Q

 ;*************

COMPUTE ;

 ;

 S BAR("SUBR")="BAR-PAY"

 K ^TMP($J,"BAR-PAY"),^TMP($J,"BAR-PAYS"),^TMP($J,"BAR-PAYS1")

 S COUNT=0  ; Total transactions counted

 I "VAX"[BARY("DT") D LOOP^BARRUTL,SHOWERR Q  ;visit / approved / transmit date sort

 I BARY("DT")="T" D TRANS^BARRUTL,SHOWERR Q  ; transaction date sort

 I BARY("DT")="B" D BATCHDT,SHOWERR Q  ; batch date sort 

 Q

SHOWERR Q

 Q

 N BARTMP

 I $D(^TMP($J,"BAR-PAY","ERR")) D

 . W !,"List of rejected entries from PAY report #1"

 . S BARTMP=$NA(^TMP($J,"BAR-PAY","ERR"))

 . F  S BARTMP=$Q(@BARTMP) Q:BARTMP=""  Q:$QS(BARTMP,2)'="BAR-PAY"  Q:$QS(BARTMP,3)'="ERR"  D

 . . W !,BARTMP," = ",$G(@BARTMP)

 ; 

 I $D(^TMP($J,"BAR-BAR-PAY")) D

 . W !,"List of rejected entries from PAY report #2"

 . S BARTMP=$NA(^TMP($J,"BAR-BAR-PAY","ERR"))

 . F  S BARTMP=$Q(@BARTMP) Q:BARTMP=""  Q:$QS(BARTMP,2)'="BAR-BAR-PAY"  D

 . . W !,BARTMP," = ",$G(@BARTMP)

 Q

BATCHDT  ; Sort by Collection Batch Date, get transactions

 S BARP("DT")=BARY("DT",1)-.5

 F  S BARP("DT")=$O(^BARCOL(DUZ(2),"C",BARP("DT"))) Q:'BARP("DT")!(BARP("DT")>(BARY("DT",2)+.5))  D

 . S BARP("BATCH")=0  F  S BARP("BATCH")=$O(^BARCOL(DUZ(2),"C",BARP("DT"),BARP("BATCH"))) Q:'BARP("BATCH")  D

 . . I '$D(^BARTR(DUZ(2),"AD",BARP("BATCH"))) S ^TMP($J,"BAR-PAY","ERR","COL-BATCH",BARP("BATCH"))="NO TRIENS" Q

 . . S TRIEN=""  F  S TRIEN=$O(^BARTR(DUZ(2),"AD",BARP("BATCH"),TRIEN)) Q:TRIEN=""  D

 . . .  S BARTR=TRIEN D DATA

 Q

 ; ***************

 ;

DATA ; EP

 ; "T" - transaction Date returns BARTR = BARTR IEN

 ; Called by BARRUTL if no parameters

 ;  BAR - ^BARBL IEN

 S BARP("HIT")=0

 I BARY("DT")="T"!(BARY("DT")="B") D  Q:'BARP("HIT")

 . N T S T=$P($G(^BARTR(DUZ(2),BARTR,1)),U) Q:'T

 . Q:T'=43&(T'=40)  ; Adjustments and Payments only

 . S TRIEN=BARTR

 . S BAR=$P(^BARTR(DUZ(2),TRIEN,0),U,4)  ; BAR = BILL IEN

 . Q:'BAR

 . S BARP("HIT")=1

1 S BARP("HIT")=0

 ; LOOP^BARRUTL returns the BILL NUMBER - need the TR-IEN to check parms 

 D BILL^BARRCHK  ; BARP("HIT")=1 if all selected parameters pass

4 Q:'BARP("HIT")

3 S BAR("3P LOC")=$$FIND3PB^BARUTL(DUZ(2),BAR)

 I BAR("3P LOC")=""  D  Q  ; Bill not found 3PB

 . ;I DUZ=838 W "  BILL NOT FND IN 3PB"

 S (BAR3PDUZ,VISITLOC)=$P(BAR("3P LOC"),",")  ; Save VisitLoc for Sort

 S BAR3PIEN=$P(BAR("3P LOC"),",",2)

 ; 

 S BARB3PB0=$G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,0))

 S BARBSTAT=$P(BARB3PB0,U,4)  ; Bill Status - X=Cancelled

2 I BARY("CXL")=0&(BARBSTAT="X") D  Q  ; No cancellations

 . ;I DUZ=838 W "  THIS IS A CANECLLATION"

 S SORT(1)="NO ADDED SORT",SORT=BARY("BARSORTX")  ; primary sort after LOC

 ;1:PROVIDER;2:CLINIC;3:APPROVING OFFICIAL;4:PRIMARY DIAGNOSIS;5:ADJUSTMENT TYPE;6:ALLOWANCE CATEGORY"

 I SORT=1 S SORT(1)=$P(BAR(1),U,13)  ;PRV

 I SORT=2 S SORT(1)=$P(BAR(1),U,8)  ;Clinic

 I SORT=3 S SORT(1)=$P($G(^BARBL(DUZ(2),BAR,2)),U,15) D  ;APPRV OFCL

 . I SORT(1)="" S SORT(1)=0

 S BARP("HIT")=0

TRIEN N TT,BARTEST,HIT,BARTRANC,PMTCRD,PAIDAMT

 I BARY("DT")'="T"&(BARY("DT")'="B") S TRIEN="" D  Q

 . F  S TRIEN=$O(^BARTR(DUZ(2),"AC",BAR,TRIEN)) Q:'TRIEN  D TRCHK

 ; 

TRCHK S (PAIDAMT,PMTCRD)=0

 I '$D(^BARTR(DUZ(2),TRIEN))  D  Q  ; quit if no transaction

 . ;I DUZ=838 W "  NO TRANSACTION"

 ;

 S BARTRANC=$P($G(^BARTR(DUZ(2),TRIEN,1)),U)

 Q:BARTRANC=""  ;No amounts

 Q:BARTRANC'=40&(BARTRANC'=43)

 S BARTEST=$P($G(^BARTR(DUZ(2),TRIEN,1)),U,2) ; ADJ CAT

 Q:BARTEST=21!(BARTEST=22)  ; Pending & Gen'l Info don't affect totals

 I BARTRANC=43 Q:BARTEST'=13&(BARTEST'=14)  ; See Allowable Amt calc in ^BARBLCLC

 ; Only Co-Pays and Deductible Adjustments are included in Allowable Amount

 S ADJTYP=$P($G(^BARTR(DUZ(2),TRIEN,1)),U,3)  ; ADJ TYPE

 I $G(BARY("ADJTYP"))]"" Q:ADJTYP'=BARY("ADJTYP")  ; comment out unless they really want it. ****

 S HIT=0

 S BARPAYER=$P(^BARTR(DUZ(2),TRIEN,0),U,6)

 ;I DUZ=838 I BARPAYER'=BAR("I") D  

 . W !,"*** PROBLEM: ACCNT# in ^BARTR(",DUZ(2),",",TRIEN," ->(",BARPAYER

 . W ") is different from ACCNT# in ^BARBL(",DUZ(2),",",BAR," ->(",BAR("I"),") WILL USE ",BAR("I")

 S BARPAYER=BAR("I")

 I BARPAYER="" D  Q  ; A/R ACCT aka PAYER

 . S ^TMP($J,"BAR-PAY","ERR","-NO PAYER",TRIEN)=""

 I $G(^BARAC(DUZ(2),BARPAYER,0))="" D  Q

 . S ^TMP($J,"BAR-PAY","ERR","-NO BARAC ENTRY",TRIEN,BARAC)=""

 S BARAC=+$P(^BARAC(DUZ(2),BARPAYER,0),U)  ;

 I $P(^BARAC(DUZ(2),BARPAYER,0),";",2)'["AUTNINS"  Q  ; Quit if Payer is not Insurance Co

 ;S BARPYALL=$P(^AUTNINS(BARAC,2),U)  ; ALLOWANCE OLD PTR

 S D0=BARPAYER ;S D0=BARAC

 S BARPYALL=$$VALI^BARVPM(8) ;GETS FLD # .211 P.OTT 

 S BAR("ALL")=BARPYALL ;

 I $D(BARY("ALL")) Q:BARY("ALL","CODES")'[BAR("ALL")_" "  ; ALLOWANCE CAT

 S BARPYNM=$P(^AUTNINS(BARAC,0),U) ;NAME

 S T=$G(^BARTR(DUZ(2),TRIEN,0))

 I BARTRANC=40 S PAIDAMT=$P(T,U,2)

 I BARTRANC=43 S PMTCRD=$P(T,"^",2)-$P(T,"^",3)  ; aka ALLOWANCE AMOUNT

 ; Add credits / deduct debits for adjustments

 S TMP=$G(^TMP($J,"BAR-PAY","ARACT",VISITLOC,BARPAYER))

 D SETSORT

 S ^TMP($J,"BAR-PAY","ARACT",VISITLOC,BARPAYER)=TMP

 I SORT(1)'="" D

 . S X=BARY("BARSORTX")

 . S BARTAG=$S(X=1:"PRV",X=2:"CLIN",X=3:"CSHR",X=4:"DX",X=5:"ADJTY",X=6:"ALLOWCAT",1:"NOSORT")

 . I BARTAG="NOSORT" S SORT(1)=BARTAG,SORTNM=" "

 . E  D @BARTAG

 . S TMP=$G(^TMP($J,"BAR-PAY",BARTAG,VISITLOC,SORT(1),BARPAYER))

 . D SETSORT

 . S ^TMP($J,"BAR-PAY",BARTAG,VISITLOC,SORT(1),BARPAYER)=TMP

 ; will re-sort before printing

 ;S ^TMP($J,"BAR-PAY",BAR)=""

 S COUNT=COUNT+1

 Q

SETSORT  ;

 S $P(TMP,U)=$P(TMP,U)+1  ; TRANSACTION COUNT

 S $P(TMP,U,2)=$P(TMP,U,2)+PAIDAMT  ; AMOUNT PAID

 S $P(TMP,U,3)=$P(TMP,U,3)+PMTCRD  ; ALLOWANCE AMT per TRANSACTION

 Q

 ; *******************************

PRV  ; Provider Name

 S SUBNM="PROVIDER:  "

 S SORT=$P($G(BAR(1)),U,13)

 I SORT="" S SORT(1)="No Provider Listed" Q

 S SORT(1)=$P(^VA(200,SORT,0),U,1)

 Q

 ; . S BARTAG=$S(X=1:"PRV",X=2:"CLIN",X=3:"CSHR",X=4:"DX",X=5:"ADJTY",X=6:"ALLOWCAT",1:"NOSORT")

CLIN  ;  Visit Location Name

 S SUBNM="CLINIC: "

 S SORT=$P(BAR(1),U,12)

 I SORT="" S SORT=DUZ(2)  ; If not a satellite, use the Parent Location as 

 S SORT(1)=$P(^DIC(40.7,SORT,0),U,1)

 Q

CSHR  ;

 S SUBNM="APPROVING OFFICIAL: "

 ; not finding it in ^BARBL(DUZ(2),BILLIEN,2) so

 ; looking ^ABMDBILL(DUZ(2),3PBIEN,1)

 ; S SORT=$P($G(BAR(2)),U,15)

 S SORT=$P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,1)),U,4)

 I SORT="" S SORT(1)="No Approving Official" Q

 S SORT(1)=$P(^VA(200,SORT,0),U,1)

 Q

DX  ; ^ICD9(547,0)=202.04^LC^NODULAR LYMPHOMA AXILLA^^17^^^^

 S SUBNM="Primary DX: "

 S SORT=BAR("DX",1)_" "  ; set in ^BARRCHK

 I BAR("DX",1)="No DX" S SORT(1)="No DX entered" Q

 I BAR("DX",1)=" " S SORT(1)="No DX entered" Q  ;3/12/2014

 S SORT=$O(^ICD9("AB",SORT,""))  ; get IEN

 S SORT(1)=BAR("DX",1)_" "_$P(^ICD9(SORT,0),U,3)

 Q

ADJTY  ;

 S SUBNM=("ADJUSTMENT TYPE: ")

 I BARTRANC=40 S SORT(1)="Payment, not Adjustment" Q

 S SORT=$G(ADJTYP) I ADJTYP="" S SORT(1)="No Adj Type" Q

 S SORT(1)=$P(^BARTBL(SORT,0),U)

 Q

ALLOWCAT  ;

 S SUBNM="ALLOWANCE CATEGORY: "

 S SORT=BARALL(BARPYALL)  ; Allowance Category (set in tag: MOREQ)

 S SORT(1)=SORT  ; 

 Q

NOSORT  ;

 S SORT(1)="",SUBNM=" "

 Q

 ; *************************************

MOREQ  ; Additional Questions

 ; Set-up Allowance Code Grid

 K BARALL ;P.OTT

 F X="R","MH","MD","MC","MMC" S BARALL(X)="MEDICARE (INS TYPES R MH MD MC MMC)"

 F X="D","K","FPL" S BARALL(X)="MEDICAID (INS TYPES D K FPL)"

 F X="P","H","F","M" S BARALL(X)="PRIVATE INSURANCE (INS TYPES P H F M)"

 F X="W","C","N","I","G","T","SEP","TSI" S BARALL(X)="OTHER (INS TYPES W C N I G T SEP TSI)"

 F X="V" S BARALL(X)="VETERANS (INS TYPES V)"

 ; Select Sort from all available parameters

 I $D(BARY("ALL")) D  ; Get the ALLOWANCE CATEGORIES to include

 . N ALL

 . S ALL=$P(BARY("ALL","NM"),"(INS TYPES ",2)

 . S BARY("ALL","CODES")=$E(ALL,1,$L(ALL)-1)_" "

 K DIR

 S DIR(0)="SO^1:PROVIDER;2:CLINIC;3:APPROVING OFFICIAL;4:PRIMARY DIAGNOSIS;5:ADJUSTMENT TYPE;6:ALLOWANCE CATEGORY"

 S DIR("A")="Select a * SORT * Field"

 S DIR("?")="The report can be sorted by one of the listed parameters."

 D ^DIR Q:Y="^"

 K DIR

 I $E(X)="^" S BARDONE=1 Q

 S BARY("BARSORTX")=+Y

 I $D(DTOUT)!($D(DUOUT)) S BARDONE2=1 Q

 D DISP^BARRSEL

 W !!,"SORT PARAMETER in Effect for Top Payer Report: "

 S BARSORTR=$P($T(SORTEXT),":",BARY("BARSORTX")+2) W BARSORTR

SORTEXT ;;:No Sort Selected:PROVIDER:CLINIC:APPROVING OFFICIAL:PRIMARY DIAGNOSIS:ADJUSTMENT TYPE:ALLOWANCE CATEGORY 

NMBR  ; Number of entries to print

 W ! K DIR

 S DIR("A")="Select number of entries to display"

 S DIR("B")=5  ; Default to Top 5

 S DIR(0)="LO^1:100"

 D ^DIR

 Q:$D(DTOUT)!($D(DUOUT))!(Y<1)

 S BAR("NBR TO PRINT")=+Y

ASKCXL  ;

 W !

 K DIR

 S DIR("A")="Do you wish to include cancelled bills in your count? YES/NO"

 S DIR("B")="YES"

 S DIR(0)="Y"

 D ^DIR

 K DIR

 Q:($D(DUOUT)!$D(DTOUT))

 S BARY("CXL")=Y  ; Quit parameter

 Q

ADJTYP  ; from ^BARRSEL

 S DIR(0)="SO^13:Deductible Adjustments;14:Co-Pays"

 S DIR("A")="Select ONE  of the above INCLUSION PARAMETERS"

 D ^DIR

 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!(Y="") Q

 S BARY("ADJTYP")=Y

 Q

 ;

HDCLIN  ; If clinic selected, add to HDR to print

 S BAR("CONJ")="at Clinic "

 S BAR("TXT")=BARY("CLIN","NM")

 D CHK^BARRHD

 Q

HDAPPR ;

 ; Approving Official (ie cashier)

 S BAR("CONJ")="Approving Official "

 S BAR("TXT")=BARY("APPR","NM")

 D CHK^BARRHD

 Q

HDRADJ  ; If Adj selected, add to HDR to print

 S BAR("CONJ")="Adjustment: "

 S BAR("TXT")=$P(^BAR(90052.01,BARY("ADJTYP"),0),U)

 D CHK^BARRHD

 Q

HDRSORT  ; Add Sort selected to HEADERS

 S BAR("CONJ")="Sort by: "

 S BAR("TXT")=BARSORTR

 D CHK^BARRHD

 Q

BARRPAY   ; IHS/SD/PKD - TOP PAYERS REPORT ; 07/2/2010

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**19,23,24**;OCT 26, 2005;Build 69

 +2       ; New Reports - Top Payers - PKD 

 +3       ; IHS/SD/POTT 03/13ADDED NEW VA billing -BAR*1.8*23

 +4       ; IHS/SD/POTT 07/13 ADDED SUPPORT FOR ICD-10 -BAR*1.8*23

 +5       ; IHS/SD/POTT HEAT143222 01/14 FIX USER EXIT AFTER D MOREQ  - BAR*1.8*24

 +6        QUIT 

 +7       ; *******************************

 +8       ;

EN        ; EP

 +1        KILL BARY,BAR,PKD

 +2       ;Setup basic A/R variables

           IF '$DATA(BARUSR)

               DO INIT^BARUTL

 +3       ; Routine used to get data

           SET BARP("RTN")="BARRPAY"

 +4       ; Financial Reports - verify w/ Adrian/Gina -pkd

           SET BAR("LOC")="BILLING"

 +5       ; Select exclusion parameters

           DO ^BARRSEL

 +6        IF $DATA">DATA">DATA">DATA(DTOUT)!$DATA">DATA">DATA">DATA(DUOUT)!$DATA">DATA">DATA">DATA(DIROUT)

               QUIT 

 +7       ; Additional Questions: Sort by; include CXL's; how many to top payers

           DO MOREQ

 +8       ;HEAT143222 BAR*1.8*24

           IF $DATA">DATA">DATA">DATA(DTOUT)!$DATA">DATA">DATA">DATA(DUOUT)!$DATA">DATA">DATA">DATA(DIROUT)

               QUIT 

 +9       ;

HD         SET BAR("HD",0)=BARMENU

 +1       ; Report header

           DO ^BARRHD

 +2       ; Add additional Selection Criteria to the Headers

 +3       ;P.OTT -BAR*1.8*23

           IF $DATA">DATA">DATA">DATA(BARY("DX"))!$DATA">DATA">DATA">DATA(BARY("DX9"))!$DATA">DATA">DATA">DATA(BARY("DX10"))

               DO DX^BARRHD

 +4       ;

 +5        IF $DATA(BARY("CLIN"))

               DO HDCLIN

 +6        IF $DATA(BARY("APPR"))

               DO HDAPPR

 +7        IF $DATA(BARY("ADJTYP"))

               DO HDRADJ

 +8        DO HDRSORT

 +9        NEW SORT,SORTNM,SUBNM,T,TMP,TRIEN,VISITLOC,COUNT,ADJTYP

 +10      ; Compute routine

           SET BARQ("RC")="COMPUTE^BARRPAY"

 +11      ; Print routine

           SET BARQ("RP")="PRINT^BARRPAY2"

 +12      ; Namespace for variables

           SET BARQ("NS")="BAR"

 +13      ; Clean-up routine

           SET BARQ("RX")="POUT^BARRUTL"

 +14       KILL ^TMP($JOB,"BAR-PAY"),