BARFPST5 ; IHS/SD/LSL - A/R FLAT RATE POSTING ; 12/22/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**6,10,21,23**;OCT 26, 2005
;;
DOC ;
; LSL - 01/01/2000 - Created routine
; Contains code for POSTING, EDITING, CANCELLING, or QUITING
; Bills from A/R FLAT RATE POSTING
;
; IHS/ASDS/LSL - 06/29/00 - v1.3
; Mark bills for rollback capabilities. Set BARROLL array
; during posting process. Call EN^BARROLL after posting
; complete. BARRAYGO needs to be defined as well. (Currently,
; it will be set to 0 as we don't allow "Roll over as you go".)
;
; IHS/ASDS/LSL - 06/29/00 - V1.3
; Added tag ROLFIX to mark bills for rollback that were posted
; before the above change.
;
; ITSC/SD/LSL - 10/21/02 - V1.7 - NOIS QAA-1200-130051
; Added quit logic in PSTBIL if error getting A/R Transaction
;;
Q
; *********************************************************************
ACTION ; EP
; EP - Posting and review bills section.
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) D NOSESS Q ;IS SESSION STILL OPEN
I '+BARFLAG W !!,"You must Review the bills before posting."
D SELCOM ; Select command (P/R/E/C/Q)
I '+BARCOMD W !!,"This is a required response.",! G ACTION
I BARRECPQ="P" D ; Posting
. D POST ; Post FRP bills
. I BARSTOP=1 S BARRECPQ="E" Q ; HAS NEGATIVE BAL;MRS:BAR*1.8*6 DD 4.2.5
. S BARRAYGO=0 ; "Roll-over as you go flag" to no
. D EN^BARROLL ; Mark bills for roll-over
I BARRECPQ="R" D REVIEW^BARFPST4 G ACTION ; Review FRP bills
I BARRECPQ="E" D FRPBILL^BARFPST3 G ACTION ; Edit FRP bills
I BARRECPQ="C" D CANCEL G:'+BARCAN ACTION ; Cancel FRP entry
Q
; *********************************************************************
SELCOM ;
; Select command (P/R/E/C/Q)
S BARCOMD=1 ; "Select Command (P/R/E/C/Q)" Entry Flag
K DIR
I '+BARFLAG D ; If not review flag, don't allow post
. S DIR(0)="SAO^R:REVIEW;E:EDIT;C:CANCEL;Q:QUIT"
. S DIR("A")="Select Command (R/E/C/Q): "
E D ; If review flag, allow post
. S DIR(0)="SAO^P:POST;R:REVIEW;E:EDIT;C:CANCEL;Q:QUIT"
. S DIR("A")="Select Command (P/R/E/C/Q): "
D ^DIR
K DIR
I $D(DUOUT)!(Y="") S BARCOMD=0 ; Select Command Entry Flag
S BARRECPQ=$E($G(Y(0))) ; Users answer to prompt
Q
; *********************************************************************
POST ;
; Post to A/R TRANSACTION/IHS File and bill's history
S BARTMP=0 ; Adjustment array flag
S BARSTOP="" ; NEGATIVE BALANCE FLAG MRS:BAR*1.8*6 DD 4.2.5
S BARSECT=$$VALI^XBDIQ1(200,DUZ,29) ; Service/Section from NEW PERSON
I $D(BARPAY) D ; If payment entered
. I BARPAY<0,$$IHS^BARUFUT(DUZ(2)) D STOP^BARFPST1 S BARSTOP=1 Q ;MRS:BAR*1.8*10 D158-3
. ;;;I BARPAY<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP^BARFPST1 S BARSTOP=1 Q ;MRS:BAR*1.8*10 D158-3 P.OTT
. D CKBAL(BARIEN,BARPAY,BARCOL,BARITM) ;CHECK BALANCE;MRS:BAR*1.8*6 DD 4.2.5
. Q:BARSTOP=1 ;HAS NEGATIVE BALANCE;MRS:BAR*1.8*6 DD 4.2.5
. D PSTBIL ; Post bills with this payment
. W !,"Payment of "_$J(BARPAY,9,2)_" posted to "_BARCNT_" bills."
Q:BARSTOP=1 ; NEGATIVE BALANCE FLAG MRS:BAR*1.8*6 DD 4.2.5
I $D(BARADJ) D ; If Adjustments entered
. S BARTMP=1 ; Adjustment array flag
. S J=0
. F S J=$O(BARADJ(J)) Q:'+J D ; For each adjustment...
. . D PSTBIL ; Post bills with this adjustment
. . W !,"Adjustment category "_$P(BARADJ(J),U,3)_" Type "_$P(BARADJ(J),U,5)_" for "_$J($P(BARADJ(J),U),9,2)_" posted to "_BARCNT_" bills."
W !,"Done Posting."
; Mark FRP Batch as POSTED in A/R FLAT RATE POSTING file
K DA,DR,DIE
S DIE="^BARFRP(DUZ(2),"
S DA=BARIEN
S DR=".13////P"
D ^DIE
I $D(BARNOT) D ERROR Q
Q
; *********************************************************************
PSTBIL ;
; Post bills
K DA,DR,DIE
S (BARFRPL,BARCNT)=0
; Loop through facilities in A/R FLAT RATE POSTING File
F S BARFRPL=$O(^BARFRP(DUZ(2),BARIEN,2,BARFRPL)) Q:'+BARFRPL D
. ; IEN to VISIT LOCATION multiple in A/R COLLECTION BATCH
. S BAREOB=$$VALI^XBDIQ1(90054.0102,"BARIEN,BARFRPL",.01)
. S K=0
. ; Loop through bills (within facility) in A/R FLAT RATE POSTING File
. F S K=$O(^BARFRP(DUZ(2),BARIEN,2,BARFRPL,3,K)) Q:'+K D
. . S BARBLIEN=$P(^BARFRP(DUZ(2),BARIEN,2,BARFRPL,3,K,0),U) ; IEN to A/R BILL
. . S BARBLPAT=$$VALI^XBDIQ1(90050.01,BARBLIEN,101) ; A/R Patient IEN
. . S BARBLAC=$$VALI^XBDIQ1(90050.01,BARBLIEN,3) ; A/R Account
. . S BARBLCR=$S(+BARTMP:$P(BARADJ(J),U),'+BARTMP:BARPAY,1:"") ; Credit
. . S BARTRAN=$S(+BARTMP:43,'+BARTMP:40,1:"") ; Transaction code
. . S BARTRIEN=$$NEW^BARTR ; Create Transaction
. . ; Populate Transaction file
. . S DA=BARTRIEN ; IEN to A/R TRANSACTION
. . I BARTRIEN<1 S BARNOT(BARBLIEN,BARTRAN,$S(BARTRAN=43:$G(J),1:99999))="" Q
. . S BARCNT=BARCNT+1 ; Bill counter
. . S DIE=90050.03
. . S DR="2////^S X=BARBLCR" ; Credit
. . S DR=DR_";4////^S X=BARBLIEN" ; A/R Bill
. . S DR=DR_";5////^S X=BARBLPAT" ; A/R Patient
. . S DR=DR_";6////^S X=BARBLAC" ; A/R Account
. . S DR=DR_";8////^S X=DUZ(2)" ; Parent Location
. . S DR=DR_";9////^S X=DUZ(2)" ; Parent ASUFAC
. . S DR=DR_";10////^S X=BARSECT" ; A/R Section
. . S DR=DR_";11////^S X=BAREOB" ; Visit Location
. . S DR=DR_";12////^S X=$P(BARDT,""."")" ; Date
. . S DR=DR_";13////^S X=DUZ" ; Entry by
. . S DR=DR_";14////^S X=BARCOL" ; IEN to A/R COLLECTION BATCH
. . S DR=DR_";15////^S X=BARITM" ; IEN to ITEM mult in A/R COL
. . S DR=DR_";101////^S X=BARTRAN" ; Transaction Type
. . I BARTRAN=43 D ; If Adjustment
. . . S DR=DR_";102////^S X=$P(BARADJ(J),U,2)" ; Adjustment Category
. . . S DR=DR_";103////^S X=$P(BARADJ(J),U,4)" ; Adjustment Type
. . S DIDEL=90050
. . D ^DIE
. . K DIDEL,DIE,DA,DR
. . ; Post from transaction file to related files
. . D TR^BARTDO(BARTRIEN)
. . S BARROLL(BARBLIEN)="" ; Needed for rollback
Q
; *********************************************************************
ERROR ;
N L,T,A
W !!!,$$EN^BARVDF("BLN")
W $$CJ^XLFSTR("The system could not create at least 1 entry in the A/R Transaction File")
W !,$$CJ^XLFSTR("Please verify postings for the following bills and repost if necessary")
W $$EN^BARVDF("BLF")
S L=0
F S L=$O(BARNOT(L)) Q:'+L D
. S T=0
. F S T=$O(BARNOT(L,T)) Q:'+T D
. . S A=0
. . F S A=$O(BARNOT(L,T,A)) Q:'+A D
. . . W !,$$GET1^DIQ(90050.01,L,.01) ; Bill
. . . I T=40 W ?15,"PAYMENT OF ",$J(BARPAY,9,2)
. . . E W ?15,$P(BARADJ(A),U,3),", ",$P(BARADJ(A),U,5)," OF ",$J($P(BARADJ(A),U),9,2)
Q
; *********************************************************************
CANCEL ;
; Cancel Entries
N BARSTAT
S BARSTAT=$$VALI^XBDIQ1(90054.01,BARIEN,.13)
I BARSTAT="P" D Q
. S BARCAN=0
. W !,"This FRP Batch has already been posted. It may not be cancelled"
S DIR(0)="Y"
S BARCAN=1
S DIR("A",2)="Everything entered into the A/R FLAT RATE POSTING file"
S DIR("A",3)="for Collection Batch "_BARBNM
S DIR("A",4)="and ITEM "_BARINM_" will be deleted."
S DIR("A")="Continue"
S DIR("B")="No"
D ^DIR
K DIR
I Y'=1 S BARCAN=0 Q
; Kill Visit Location multiple which will subsequently kill the
; A/R Bill multiple.
NOSESS ; EP IHS/SD/PKD 1.8*21 Heat20490 3/21/11
; Kill Flat Rate Batch if Session not open
S BARCAN=1
; END 1.8*21
S DA=BARIEN
S DIK="^BARFRP(DUZ(2),"
D ^DIK
Q
; *********************************************************************
DELFRP ; EP
; EP - Called from MAN,FRD
D DELFRPE ; Get Flat Rate Posting Entry
I Y<1 D EXIT^BARFPST Q
D DELFRPD
Q
; *********************************************************************
DELFRPE ;
; Get Flat Rate Posting Entry
W !
K DIC
S DIC="^BARFRP(DUZ(2),"
S DIC(0)="AEMQZ"
S DIC("A")="Select FRP Batch: "
S DIC("S")="I $P(^(0),U,13)=""P""" ; Only posted batches
D ^DIC
I Y<1 Q
S BARIEN=+Y
S BARNAME=Y(0,0)
Q
; *********************************************************************
DELFRPD ;
; Delete FRP Batch
K DIR
S DIR(0)="Y"
S DIR("A")="Delete "_BARNAME
S DIR("B")="No"
D ^DIR
K DIR
I Y'=1 W !,"Not Deleted." Q
; Kill batch
S DA=BARIEN
S DIK="^BARFRP(DUZ(2),"
D ^DIK
W !,"Deleted!"
Q
; *********************************************************************
ROLFIX ;
; Mark bills for rollback that were posted before the code was
; changed to accomodate 6/29/00
D ^BARVKL0 ; Kill namespace variables
K DA,DR,DIE
S (L,BARCNT,BARIEN,BARRAYGO)=0
; Loop through FRP batches (only posted)
F S BARIEN=$O(^BARFRP(DUZ(2),BARIEN)) Q:'+BARIEN D
. Q:$P($G(^BARFRP(DUZ(2),BARIEN,0)),U,13)'="P"
. ; Loop through facilities in A/R FLAT RATE POSTING File
. S L=0
. F S L=$O(^BARFRP(DUZ(2),BARIEN,2,L)) Q:'+L D
. . ; IEN to VISIT LOCATION multiple in A/R COLLECTION BATCH
. . S BAREOB=$$VALI^XBDIQ1(90054.0102,"BARIEN,L",.01)
. . S K=0
. . ; Loop through bills (within facility) in A/R FLAT RATE POSTING File
. . F S K=$O(^BARFRP(DUZ(2),BARIEN,2,L,3,K)) Q:'+K D
. . . S BARBLIEN=$P(^BARFRP(DUZ(2),BARIEN,2,L,3,K,0),U) ; IEN to A/R BILL
. . . Q:$P(^BARBL(DUZ(2),BARBLIEN,2),U,8)]"" ; Q if rollback populated
. . . S BARROLL(BARBLIEN)="" ; Needed for rollback
. . . D EN^BARROLL
. . . K BARROLL
D ^BARVKL0
K DA,DR,DIC,DIE,K,L
Q
; *********************************************************************
CKBAL(BARA,BARPAY,BARCOL,BARITM) ;EP; CHECK IF TX'S WILL CREATE NEGATIVE BALANCE;BAR*1.8*6 DD 4.2.5
;ENTERS WITH BARA = BATCH IEN
; BARPAY = FLAT RATE PAY AMOUNT
; BARCOL = COLLECTION BATCH
; BARITM = COLLECTION BATCH ITEM
;
Q:'$$IHS^BARUFUT(DUZ(2)) ;ONLY CHECK IHS SITES
;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;QUIT IF IHS SITE OR TRIBAL WITH RESTRICTED POSTING ;P.OTT
N BAR,BARF,BARK,BARPTOT,BARMULT
S BARMULT=+$P(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2) ;MULTIPLE 3P EOB FLAG
S (BARF,BARCT,BARPTOT)=0
; Loop through facilities in A/R FLAT RATE POSTING File
F S BARF=$O(^BARFRP(DUZ(2),BARA,2,BARF)) Q:'+BARF D
.; IEN to VISIT LOCATION multiple in A/R COLLECTION BATCH
.S BAR=$$VALI^XBDIQ1(90054.0102,"BARA,BARF",.01)
.S BARK=0
.F S BARK=$O(^BARFRP(DUZ(2),BARA,2,BARF,3,BARK)) Q:'+BARK D
..S BARCT=BARCT+1
..S:BARMULT BAR(BARF,BAR)=$G(BAR(BARF,BAR))+BARPAY
S BARPTOT=BARCT*BARPAY
I BARMULT N BAREOB
D CKCOL^BARPSTU ;RETURNS BATCH TOTAL ARRAYS
I (BARITV(19)-BARPTOT)<0 D STOP("COLLECTION ITEM",(BARITV(19)-BARPTOT))
I (BARCLV(17)-BARPTOT)<0 D STOP("COLLECTION BATCH",(BARCLV(17)-BARPTOT))
Q:'BARMULT
S BARF=0
F S BARF=$O(BAR(BARF)) Q:'BARF D
.S BAREOB=0
.F S BAREOB=$O(BAR(BARF,BAREOB)) Q:'BAREOB D
..D CKCOL^BARPSTU ;RETURNS BATCH TOTAL ARRAYS
..S BARPTOT=BAR(BARF,BAREOB)
..I +$G(BAREOB),(BAREOV(4)-BARPTOT)<0 D
...D STOP($P(^AUTTLOC(BAREOB,0),U,2)_" VISIT LOCATION",(BAREOV(4)-BARPTOT))
Q
;
STOP(TYPE,BARDIF) ;EP; BAR*1.8*6 DD 4.2.5
Q:'$$IHS^BARUFUT(DUZ(2)) ;ONLY CHECK IHS SITES
;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;Q: IHS OR TRIBAL WITH RESTRICTION ; P.OTT
W !!,"THE TRANSACTION(S) YOU ARE ATTEMPTING TO POST WILL PUT"
W !,"THE ",TYPE," INTO A NEGATIVE BALANCE BY $"_-BARDIF
W:TYPE="BILL" !,"Bill will not be included when posting"
I TYPE'="BILL" D
.W !?10,"PLEASE CANCEL, OR USE 'E' TO EDIT THE TRANSACTIONS"
.W !?15,"TO PREVENT THE NEGATIVE BALANCE"
S BARSTOP=1
D EOP^BARUTL(1)
Q
BARFPST5 ; IHS/SD/LSL - A/R FLAT RATE POSTING ; 12/22/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**6,10,21,23**;OCT 26, 2005
+2 ;;
DOC ;
+1 ; LSL - 01/01/2000 - Created routine
+2 ; Contains code for POSTING, EDITING, CANCELLING, or QUITING
+3 ; Bills from A/R FLAT RATE POSTING
+4 ;
+5 ; IHS/ASDS/LSL - 06/29/00 - v1.3
+6 ; Mark bills for rollback capabilities. Set BARROLL array
+7 ; during posting process. Call EN^BARROLL after posting
+8 ; complete. BARRAYGO needs to be defined as well. (Currently,
+9 ; it will be set to 0 as we don't allow "Roll over as you go".)
+10 ;
+11 ; IHS/ASDS/LSL - 06/29/00 - V1.3
+12 ; Added tag ROLFIX to mark bills for rollback that were posted
+13 ; before the above change.
+14 ;
+15 ; ITSC/SD/LSL - 10/21/02 - V1.7 - NOIS QAA-1200-130051
+16 ; Added quit logic in PSTBIL if error getting A/R Transaction
+17 ;;
+18 QUIT
+19 ; *********************************************************************
ACTION ; EP
+1 ; EP - Posting and review bills section.
+2 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+3 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
DO NOSESS
QUIT
+4 IF '+BARFLAG
WRITE !!,"You must Review the bills before posting."
+5 ; Select command (P/R/E/C/Q)
DO SELCOM
+6 IF '+BARCOMD
WRITE !!,"This is a required response.",!
GOTO ACTION
+7 ; Posting
IF BARRECPQ="P"
Begin DoDot:1
+8 ; Post FRP bills
DO POST
+9 ; HAS NEGATIVE BAL;MRS:BAR*1.8*6 DD 4.2.5
IF BARSTOP=1
SET BARRECPQ="E"
QUIT
+10 ; "Roll-over as you go flag" to no
SET BARRAYGO=0
+11 ; Mark bills for roll-over
DO EN^BARROLL
End DoDot:1
+12 ; Review FRP bills
IF BARRECPQ="R"
DO REVIEW^BARFPST4
GOTO ACTION
+13 ; Edit FRP bills
IF BARRECPQ="E"
DO FRPBILL^BARFPST3
GOTO ACTION
+14 ; Cancel FRP entry
IF BARRECPQ="C"
DO CANCEL
IF '+BARCAN
GOTO ACTION
+15 QUIT
+16 ; *********************************************************************
SELCOM ;
+1 ; Select command (P/R/E/C/Q)
+2 ; "Select Command (P/R/E/C/Q)" Entry Flag
SET BARCOMD=1
+3 KILL DIR
+4 ; If not review flag, don't allow post
IF '+BARFLAG
Begin DoDot:1
+5 SET DIR(0)="SAO^R:REVIEW;E:EDIT;C:CANCEL;Q:QUIT"
+6 SET DIR("A")="Select Command (R/E/C/Q): "
End DoDot:1
+7 ; If review flag, allow post
IF '$TEST
Begin DoDot:1
+8 SET DIR(0)="SAO^P:POST;R:REVIEW;E:EDIT;C:CANCEL;Q:QUIT"
+9 SET DIR("A")="Select Command (P/R/E/C/Q): "
End DoDot:1
+10 DO ^DIR
+11 KILL DIR
+12 ; Select Command Entry Flag
IF $DATA(DUOUT)!(Y="")
SET BARCOMD=0
+13 ; Users answer to prompt
SET BARRECPQ=$EXTRACT($GET(Y(0)))
+14 QUIT
+15 ; *********************************************************************
POST ;
+1 ; Post to A/R TRANSACTION/IHS File and bill's history
+2 ; Adjustment array flag
SET BARTMP=0
+3 ; NEGATIVE BALANCE FLAG MRS:BAR*1.8*6 DD 4.2.5
SET BARSTOP=""
+4 ; Service/Section from NEW PERSON
SET BARSECT=$$VALI^XBDIQ1(200,DUZ,29)
+5 ; If payment entered
IF $DATA(BARPAY)
Begin DoDot:1
+6 ;MRS:BAR*1.8*10 D158-3
IF BARPAY<0
IF $$IHS^BARUFUT(DUZ(2))
DO STOP^BARFPST1
SET BARSTOP=1
QUIT
+7 ;;;I BARPAY<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP^BARFPST1 S BARSTOP=1 Q ;MRS:BAR*1.8*10 D158-3 P.OTT
+8 ;CHECK BALANCE;MRS:BAR*1.8*6 DD 4.2.5
DO CKBAL(BARIEN,BARPAY,BARCOL,BARITM)
+9 ;HAS NEGATIVE BALANCE;MRS:BAR*1.8*6 DD 4.2.5
IF BARSTOP=1
QUIT
+10 ; Post bills with this payment
DO PSTBIL
+11 WRITE !,"Payment of "_$JUSTIFY(BARPAY,9,2)_" posted to "_BARCNT_" bills."
End DoDot:1
+12 ; NEGATIVE BALANCE FLAG MRS:BAR*1.8*6 DD 4.2.5
IF BARSTOP=1
QUIT
+13 ; If Adjustments entered
IF $DATA(BARADJ)
Begin DoDot:1
+14 ; Adjustment array flag
SET BARTMP=1
+15 SET J=0
+16 ; For each adjustment...
FOR
SET J=$ORDER(BARADJ(J))
IF '+J
QUIT
Begin DoDot:2
+17 ; Post bills with this adjustment
DO PSTBIL
+18 WRITE !,"Adjustment category "_$PIECE(BARADJ(J),U,3)_" Type "_$PIECE(BARADJ(J),U,5)_" for "_$JUSTIFY($PIECE(BARADJ(J),U),9,2)_" posted to "_BARCNT_" bills."
End DoDot:2
End DoDot:1
+19 WRITE !,"Done Posting."
+20 ; Mark FRP Batch as POSTED in A/R FLAT RATE POSTING file
+21 KILL DA,DR,DIE
+22 SET DIE="^BARFRP(DUZ(2),"
+23 SET DA=BARIEN
+24 SET DR=".13////P"
+25 DO ^DIE
+26 IF $DATA(BARNOT)
DO ERROR
QUIT
+27 QUIT
+28 ; *********************************************************************
PSTBIL ;
+1 ; Post bills
+2 KILL DA,DR,DIE
+3 SET (BARFRPL,BARCNT)=0
+4 ; Loop through facilities in A/R FLAT RATE POSTING File
+5 FOR
SET BARFRPL=$ORDER(^BARFRP(DUZ(2),BARIEN,2,BARFRPL))
IF '+BARFRPL
QUIT
Begin DoDot:1
+6 ; IEN to VISIT LOCATION multiple in A/R COLLECTION BATCH
+7 SET BAREOB=$$VALI^XBDIQ1(90054.0102,"BARIEN,BARFRPL",.01)
+8 SET K=0
+9 ; Loop through bills (within facility) in A/R FLAT RATE POSTING File
+10 FOR
SET K=$ORDER(^BARFRP(DUZ(2),BARIEN,2,BARFRPL,3,K))
IF '+K
QUIT
Begin DoDot:2
+11 ; IEN to A/R BILL
SET BARBLIEN=$PIECE(^BARFRP(DUZ(2),BARIEN,2,BARFRPL,3,K,0),U)
+12 ; A/R Patient IEN
SET BARBLPAT=$$VALI^XBDIQ1(90050.01,BARBLIEN,101)
+13 ; A/R Account
SET BARBLAC=$$VALI^XBDIQ1(90050.01,BARBLIEN,3)
+14 ; Credit
SET BARBLCR=$SELECT(+BARTMP:$PIECE(BARADJ(J),U),'+BARTMP:BARPAY,1:"")
+15 ; Transaction code
SET BARTRAN=$SELECT(+BARTMP:43,'+BARTMP:40,1:"")
+16 ; Create Transaction
SET BARTRIEN=$$NEW^BARTR
+17 ; Populate Transaction file
+18 ; IEN to A/R TRANSACTION
SET DA=BARTRIEN
+19 IF BARTRIEN<1
SET BARNOT(BARBLIEN,BARTRAN,$SELECT(BARTRAN=43:$GET(J),1:99999))=""
QUIT
+20 ; Bill counter
SET BARCNT=BARCNT+1
+21 SET DIE=90050.03
+22 ; Credit
SET DR="2////^S X=BARBLCR"
+23 ; A/R Bill
SET DR=DR_";4////^S X=BARBLIEN"
+24 ; A/R Patient
SET DR=DR_";5////^S X=BARBLPAT"
+25 ; A/R Account
SET DR=DR_";6////^S X=BARBLAC"
+26 ; Parent Location
SET DR=DR_";8////^S X=DUZ(2)"
+27 ; Parent ASUFAC
SET DR=DR_";9////^S X=DUZ(2)"
+28 ; A/R Section
SET DR=DR_";10////^S X=BARSECT"
+29 ; Visit Location
SET DR=DR_";11////^S X=BAREOB"
+30 ; Date
SET DR=DR_";12////^S X=$P(BARDT,""."")"
+31 ; Entry by
SET DR=DR_";13////^S X=DUZ"
+32 ; IEN to A/R COLLECTION BATCH
SET DR=DR_";14////^S X=BARCOL"
+33 ; IEN to ITEM mult in A/R COL
SET DR=DR_";15////^S X=BARITM"
+34 ; Transaction Type
SET DR=DR_";101////^S X=BARTRAN"
+35 ; If Adjustment
IF BARTRAN=43
Begin DoDot:3
+36 ; Adjustment Category
SET DR=DR_";102////^S X=$P(BARADJ(J),U,2)"
+37 ; Adjustment Type
SET DR=DR_";103////^S X=$P(BARADJ(J),U,4)"
End DoDot:3
+38 SET DIDEL=90050
+39 DO ^DIE
+40 KILL DIDEL,DIE,DA,DR
+41 ; Post from transaction file to related files
+42 DO TR^BARTDO(BARTRIEN)
+43 ; Needed for rollback
SET BARROLL(BARBLIEN)=""
End DoDot:2
End DoDot:1
+44 QUIT
+45 ; *********************************************************************
ERROR ;
+1 NEW L,T,A
+2 WRITE !!!,$$EN^BARVDF("BLN")
+3 WRITE $$CJ^XLFSTR("The system could not create at least 1 entry in the A/R Transaction File")
+4 WRITE !,$$CJ^XLFSTR("Please verify postings for the following bills and repost if necessary")
+5 WRITE $$EN^BARVDF("BLF")
+6 SET L=0
+7 FOR
SET L=$ORDER(BARNOT(L))
IF '+L
QUIT
Begin DoDot:1
+8 SET T=0
+9 FOR
SET T=$ORDER(BARNOT(L,T))
IF '+T
QUIT
Begin DoDot:2
+10 SET A=0
+11 FOR
SET A=$ORDER(BARNOT(L,T,A))
IF '+A
QUIT
Begin DoDot:3
+12 ; Bill
WRITE !,$$GET1^DIQ(90050.01,L,.01)
+13 IF T=40
WRITE ?15,"PAYMENT OF ",$JUSTIFY(BARPAY,9,2)
+14 IF '$TEST
WRITE ?15,$PIECE(BARADJ(A),U,3),", ",$PIECE(BARADJ(A),U,5)," OF ",$JUSTIFY($PIECE(BARADJ(A),U),9,2)
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ; *********************************************************************
CANCEL ;
+1 ; Cancel Entries
+2 NEW BARSTAT
+3 SET BARSTAT=$$VALI^XBDIQ1(90054.01,BARIEN,.13)
+4 IF BARSTAT="P"
Begin DoDot:1
+5 SET BARCAN=0
+6 WRITE !,"This FRP Batch has already been posted. It may not be cancelled"
End DoDot:1
QUIT
+7 SET DIR(0)="Y"
+8 SET BARCAN=1
+9 SET DIR("A",2)="Everything entered into the A/R FLAT RATE POSTING file"
+10 SET DIR("A",3)="for Collection Batch "_BARBNM
+11 SET DIR("A",4)="and ITEM "_BARINM_" will be deleted."
+12 SET DIR("A")="Continue"
+13 SET DIR("B")="No"
+14 DO ^DIR
+15 KILL DIR
+16 IF Y'=1
SET BARCAN=0
QUIT
+17 ; Kill Visit Location multiple which will subsequently kill the
+18 ; A/R Bill multiple.
NOSESS ; EP IHS/SD/PKD 1.8*21 Heat20490 3/21/11
+1 ; Kill Flat Rate Batch if Session not open
+2 SET BARCAN=1
+3 ; END 1.8*21
+4 SET DA=BARIEN
+5 SET DIK="^BARFRP(DUZ(2),"
+6 DO ^DIK
+7 QUIT
+8 ; *********************************************************************
DELFRP ; EP
+1 ; EP - Called from MAN,FRD
+2 ; Get Flat Rate Posting Entry
DO DELFRPE
+3 IF Y<1
DO EXIT^BARFPST
QUIT
+4 DO DELFRPD
+5 QUIT
+6 ; *********************************************************************
DELFRPE ;
+1 ; Get Flat Rate Posting Entry
+2 WRITE !
+3 KILL DIC
+4 SET DIC="^BARFRP(DUZ(2),"
+5 SET DIC(0)="AEMQZ"
+6 SET DIC("A")="Select FRP Batch: "
+7 ; Only posted batches
SET DIC("S")="I $P(^(0),U,13)=""P"""
+8 DO ^DIC
+9 IF Y<1
QUIT
+10 SET BARIEN=+Y
+11 SET BARNAME=Y(0,0)
+12 QUIT
+13 ; *********************************************************************
DELFRPD ;
+1 ; Delete FRP Batch
+2 KILL DIR
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Delete "_BARNAME
+5 SET DIR("B")="No"
+6 DO ^DIR
+7 KILL DIR
+8 IF Y'=1
WRITE !,"Not Deleted."
QUIT
+9 ; Kill batch
+10 SET DA=BARIEN
+11 SET DIK="^BARFRP(DUZ(2),"
+12 DO ^DIK
+13 WRITE !,"Deleted!"
+14 QUIT
+15 ; *********************************************************************
ROLFIX ;
+1 ; Mark bills for rollback that were posted before the code was
+2 ; changed to accomodate 6/29/00
+3 ; Kill namespace variables
DO ^BARVKL0
+4 KILL DA,DR,DIE
+5 SET (L,BARCNT,BARIEN,BARRAYGO)=0
+6 ; Loop through FRP batches (only posted)
+7 FOR
SET BARIEN=$ORDER(^BARFRP(DUZ(2),BARIEN))
IF '+BARIEN
QUIT
Begin DoDot:1
+8 IF $PIECE($GET(^BARFRP(DUZ(2),BARIEN,0)),U,13)'="P"
QUIT
+9 ; Loop through facilities in A/R FLAT RATE POSTING File
+10 SET L=0
+11 FOR
SET L=$ORDER(^BARFRP(DUZ(2),BARIEN,2,L))
IF '+L
QUIT
Begin DoDot:2
+12 ; IEN to VISIT LOCATION multiple in A/R COLLECTION BATCH
+13 SET BAREOB=$$VALI^XBDIQ1(90054.0102,"BARIEN,L",.01)
+14 SET K=0
+15 ; Loop through bills (within facility) in A/R FLAT RATE POSTING File
+16 FOR
SET K=$ORDER(^BARFRP(DUZ(2),BARIEN,2,L,3,K))
IF '+K
QUIT
Begin DoDot:3
+17 ; IEN to A/R BILL
SET BARBLIEN=$PIECE(^BARFRP(DUZ(2),BARIEN,2,L,3,K,0),U)
+18 ; Q if rollback populated
IF $PIECE(^BARBL(DUZ(2),BARBLIEN,2),U,8)]""
QUIT
+19 ; Needed for rollback
SET BARROLL(BARBLIEN)=""
+20 DO EN^BARROLL
+21 KILL BARROLL
End DoDot:3
End DoDot:2
End DoDot:1
+22 DO ^BARVKL0
+23 KILL DA,DR,DIC,DIE,K,L
+24 QUIT
+25 ; *********************************************************************
CKBAL(BARA,BARPAY,BARCOL,BARITM) ;EP; CHECK IF TX'S WILL CREATE NEGATIVE BALANCE;BAR*1.8*6 DD 4.2.5
+1 ;ENTERS WITH BARA = BATCH IEN
+2 ; BARPAY = FLAT RATE PAY AMOUNT
+3 ; BARCOL = COLLECTION BATCH
+4 ; BARITM = COLLECTION BATCH ITEM
+5 ;
+6 ;ONLY CHECK IHS SITES
IF '$$IHS^BARUFUT(DUZ(2))
QUIT
+7 ;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;QUIT IF IHS SITE OR TRIBAL WITH RESTRICTED POSTING ;P.OTT
+8 NEW BAR,BARF,BARK,BARPTOT,BARMULT
+9 ;MULTIPLE 3P EOB FLAG
SET BARMULT=+$PIECE(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2)
+10 SET (BARF,BARCT,BARPTOT)=0
+11 ; Loop through facilities in A/R FLAT RATE POSTING File
+12 FOR
SET BARF=$ORDER(^BARFRP(DUZ(2),BARA,2,BARF))
IF '+BARF
QUIT
Begin DoDot:1
+13 ; IEN to VISIT LOCATION multiple in A/R COLLECTION BATCH
+14 SET BAR=$$VALI^XBDIQ1(90054.0102,"BARA,BARF",.01)
+15 SET BARK=0
+16 FOR
SET BARK=$ORDER(^BARFRP(DUZ(2),BARA,2,BARF,3,BARK))
IF '+BARK
QUIT
Begin DoDot:2
+17 SET BARCT=BARCT+1
+18 IF BARMULT
SET BAR(BARF,BAR)=$GET(BAR(BARF,BAR))+BARPAY
End DoDot:2
End DoDot:1
+19 SET BARPTOT=BARCT*BARPAY
+20 IF BARMULT
NEW BAREOB
+21 ;RETURNS BATCH TOTAL ARRAYS
DO CKCOL^BARPSTU
+22 IF (BARITV(19)-BARPTOT)<0
DO STOP("COLLECTION ITEM",(BARITV(19)-BARPTOT))
+23 IF (BARCLV(17)-BARPTOT)<0
DO STOP("COLLECTION BATCH",(BARCLV(17)-BARPTOT))
+24 IF 'BARMULT
QUIT
+25 SET BARF=0
+26 FOR
SET BARF=$ORDER(BAR(BARF))
IF 'BARF
QUIT
Begin DoDot:1
+27 SET BAREOB=0
+28 FOR
SET BAREOB=$ORDER(BAR(BARF,BAREOB))
IF 'BAREOB
QUIT
Begin DoDot:2
+29 ;RETURNS BATCH TOTAL ARRAYS
DO CKCOL^BARPSTU
+30 SET BARPTOT=BAR(BARF,BAREOB)
+31 IF +$GET(BAREOB)
IF (BAREOV(4)-BARPTOT)<0
Begin DoDot:3
+32 DO STOP($PIECE(^AUTTLOC(BAREOB,0),U,2)_" VISIT LOCATION",(BAREOV(4)-BARPTOT))
End DoDot:3
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
STOP(TYPE,BARDIF) ;EP; BAR*1.8*6 DD 4.2.5
+1 ;ONLY CHECK IHS SITES
IF '$$IHS^BARUFUT(DUZ(2))
QUIT
+2 ;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;Q: IHS OR TRIBAL WITH RESTRICTION ; P.OTT
+3 WRITE !!,"THE TRANSACTION(S) YOU ARE ATTEMPTING TO POST WILL PUT"
+4 WRITE !,"THE ",TYPE," INTO A NEGATIVE BALANCE BY $"_-BARDIF
+5 IF TYPE="BILL"
WRITE !,"Bill will not be included when posting"
+6 IF TYPE'="BILL"
Begin DoDot:1
+7 WRITE !?10,"PLEASE CANCEL, OR USE 'E' TO EDIT THE TRANSACTIONS"
+8 WRITE !?15,"TO PREVENT THE NEGATIVE BALANCE"
End DoDot:1
+9 SET BARSTOP=1
+10 DO EOP^BARUTL(1)
+11 QUIT
