BARFPST ; IHS/SD/LSL - FLAT RATE POSTING ; 07/08/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**6,21**;OCT 26, 2005
;;
DOC ;
; LSL - 12/30/1999 - Created routine
; First Flat Rate Posting Routine
; Contains top level logic loop, Batch, Item, and Facility
;
; IHS/SD/LSL - 02/27/04 - V1.7 Patch 5
; Mark FAC as entry point
;;
Q
; *********************************************************************
EN ; EP
; EP - Electronic Signature test
D ^BARVKL0 ; kill namespace variables
S BARESIG="" ; BAR electronic signature flag
D SIG^XUSESIG Q:X1="" ; elec sig test - Q if fail
S BARESIG=1 ; passed elec sig test
I '$D(BARUSR) D INIT^BARUTL ; Initialize BAR environment
D FRPBATCH ; Look up Flat Rate Post entry
I $D(BARNEW),'+BARNEW D EXIT Q ; If not new entry, quit
; Ask A/R col batch if not existing FRP
I '+$G(BARIEN) D BATCH I '+BARBATCH D EXIT Q
; -------------------------------
;
SELITEM ;
; return here if user never enters a facility when multiple 3P EOB
D ITEM ; Select batch item
I '+BARITEM D EXIT Q ; Batch item failed
; I multiple 3P EOB
I +$P(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2) D
. F D FAC Q:'+BARFAC D
. . S BAREOB=+Y ; IEN to VISIT LOC multiple
. . D PAYADJD^BARFPST1 ; Display current payment/adjustment
. . F D PAYADJ^BARFPST1 Q:BARPA="Q" ; Ask for payments/adjustments
. . Q:('$D(BARPAY)&('$D(BARADJ))) ; No paymnt/adjustments entered
. . D BARSAV^BARFPST2 ; Save data in FLAT RATE POST File
. . Q:$D(BARNONE) ; Entry to FRP file failed
. . D DISP^BARFPST3 ; Display accum post/balance
. . D FRPBILL^BARFPST3 ; A/R bill selection
E D
. S BAREOB=DUZ(2) ; Parent facility
. D PAYADJD^BARFPST1 ; Display current payment/adjustment
.;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
.I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
. F D PAYADJ^BARFPST1 Q:BARPA="Q" ; Ask for payments/adjustments
. Q:('$D(BARPAY)&('$D(BARADJ))) ; No paymnt/adjustments entered
. D BARSAV^BARFPST2 ; Save data in FLAT RATE POST File
. Q:$D(BARNONE) ; Entry to FRP file failed
. D DISP^BARFPST3 ; Display accum post/balance
.;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
.I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
. D FRPBILL^BARFPST3 ; A/R bill selection
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) D EXIT Q ;IS SESSION STILL OPEN
; Q if facility not asked and no payments or adjustments
I '$D(BARFAC),('$D(BARPAY)&('$D(BARADJ))) D EXIT Q
I '$D(BARFIEN) G SELITEM
D ACTION^BARFPST5 ; Posting and reviewing bills.
D EXIT
Q
; *********************************************************************
;
FRPBATCH ;
; Look up Flate Rate Posting entry
K DIC
S DIC="^BARFRP(DUZ(2),"
S DIC(0)="AEMQZ"
S DIC("A")="Select previously opened FRP batch: "
; Screen for FRP batches not already posted.
S DIC("S")="I $P(^(0),U,13)'=""P"""
D ^DIC
; If look up fails, ask if user is creating a new entry
I Y<1 D NEWFRP Q
S BARCOL=$P(Y(0),U,4) ; IEN to A/R COLLECTION BATCH
I '$$CKDATE^BARPST(BARCOL,1,"SELECT A/R COLLECTION BATCH") D NEWFRP Q ; OLD BATCH BAR*1.8*6 DD 4.2.4
S BARIEN=+Y ; IEN to A/R FLAT RATE POSTING
S BARITM=$P(Y(0),U,5) ; IEN to ITEM Mult of A/R COLLECT BATCH
S BARNAME=Y(0,0) ; Name of FRP batch
S BARBNM=$$VAL^XBDIQ1(90054.01,BARIEN,.04) ; Collection batch name
Q
; *********************************************************************
;
NEWFRP ;
; Ask if user wants to create a new Flat Rate Posting entry
K DIR
S DIR(0)="Y"
S DIR("A")="Create new entry"
S DIR("B")="Yes"
D ^DIR
I Y'=1 S BARNEW=0 Q
S BARNEW=1 ; Flag for new FRP entry
Q
; *********************************************************************
;
BATCH ; EP
; EP - Select Collection Batch
W !
K DIC
S BARBATCH=1 ; Batch loop flag
S DIC="^BARCOL(DUZ(2),"
S DIC(0)="AEZQM"
S DIC("A")="Select Batch: "
; Screen for only postable batches where service/section of user
; equals that of batch.
S DIC("S")="I $P(^(0),U,3)=""P""&($G(BARUSR(29,""I""))=$P(^(0),U,10))"
; Write site location next to each selection
S DIC("W")="D BATW^BARPST"
D ^DIC
K DIC
I Y'>0 S BARBATCH=0 Q ; Batch loop flag
S BARCOL=+Y ; IEN to A/R COLLECTION BATCH
I '$$CKDATE^BARPST(BARCOL,1,"SELECT A/R COLLECTION BATCH") S BARBATCH=0 Q ;MRS:BAR*1.8*6 DD 4.2.4
S BARBNM=$P(Y(0),U) ; Collection batch name
D BBAL^BARPST(BARCOL) ; Display batch balance and posting total
Q
; *********************************************************************
;
ITEM ; EP
; EP - Select Batch Item Number
W !
S BARITEM=1 ; Item loop flag
S DA(1)=BARCOL
S DIC="^BARCOL(DUZ(2),"_DA(1)_",1,"
S DIC(0)="AEMQZ"
S DIC("W")="D DICW^BARPST" ; Help dislpay
S DIC("A")="Select Batch Item: "
S:$D(BARITM) DIC("B")=$$VAL^XBDIQ1(90051.1101,"BARCOL,BARITM",.01)
; Screen for all ITEMS not Cancelled or Rolled up
S DIC("S")="I $P(^(0),U,17)'=""C""&($P(^(0),U,17)'=""R"")"
D ^DIC
K DIC
I +Y<1 S BARITEM=0 Q ; Item loop flag
S BARITM=+Y ; IEN to ITEM Mult of A/R COLLECT BATCH
S BARINM=$P(Y(0),U,11) ; Check number
D IBAL^BARPST(BARITM) ; Display item balance and posting total
Q
; *********************************************************************
;
FAC ; EP
; Select visit location only if Multiple 3P EOB site parameter
; is set to yes.
K BAREOB
W !
S BARFAC=1 ; Facility loop flag
S DA(2)=+BARCOL ; IEN to A/R COLLECTION
S DA(1)=+BARITM ; IEN to ITEM multiple
D ^XBSFGBL(90051.1101601,.BARGL) ; Format global structure
S DIC=$P(BARGL,"DA,",1)
S DIC(0)="AEMQZ"
S DIC("W")="W ?20,$J($P(^(0),U,2),8,2)"
S DIC("A")="Select Visit Location: "
D ^DIC
K DIC
I +Y<1 S BARFAC=0 ; Facility loop flag
Q
; *********************************************************************
;
EXIT ; EP
; EP - Exit, kill local variables
D ^BARVKL0 ; kill namespace variables
Q
BARFPST ; IHS/SD/LSL - FLAT RATE POSTING ; 07/08/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**6,21**;OCT 26, 2005
+2 ;;
DOC ;
+1 ; LSL - 12/30/1999 - Created routine
+2 ; First Flat Rate Posting Routine
+3 ; Contains top level logic loop, Batch, Item, and Facility
+4 ;
+5 ; IHS/SD/LSL - 02/27/04 - V1.7 Patch 5
+6 ; Mark FAC as entry point
+7 ;;
+8 QUIT
+9 ; *********************************************************************
EN ; EP
+1 ; EP - Electronic Signature test
+2 ; kill namespace variables
DO ^BARVKL0
+3 ; BAR electronic signature flag
SET BARESIG=""
+4 ; elec sig test - Q if fail
DO SIG^XUSESIG
IF X1=""
QUIT
+5 ; passed elec sig test
SET BARESIG=1
+6 ; Initialize BAR environment
IF '$DATA(BARUSR)
DO INIT^BARUTL
+7 ; Look up Flat Rate Post entry
DO FRPBATCH
+8 ; If not new entry, quit
IF $DATA(BARNEW)
IF '+BARNEW
DO EXIT
QUIT
+9 ; Ask A/R col batch if not existing FRP
+10 IF '+$GET(BARIEN)
DO BATCH
IF '+BARBATCH
DO EXIT
QUIT
+11 ; -------------------------------
+12 ;
SELITEM ;
+1 ; return here if user never enters a facility when multiple 3P EOB
+2 ; Select batch item
DO ITEM
+3 ; Batch item failed
IF '+BARITEM
DO EXIT
QUIT
+4 ; I multiple 3P EOB
+5 IF +$PIECE(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2)
Begin DoDot:1
+6 FOR
DO FAC
IF '+BARFAC
QUIT
Begin DoDot:2
+7 ; IEN to VISIT LOC multiple
SET BAREOB=+Y
+8 ; Display current payment/adjustment
DO PAYADJD^BARFPST1
+9 ; Ask for payments/adjustments
FOR
DO PAYADJ^BARFPST1
IF BARPA="Q"
QUIT
+10 ; No paymnt/adjustments entered
IF ('$DATA(BARPAY)&('$DATA(BARADJ)))
QUIT
+11 ; Save data in FLAT RATE POST File
DO BARSAV^BARFPST2
+12 ; Entry to FRP file failed
IF $DATA(BARNONE)
QUIT
+13 ; Display accum post/balance
DO DISP^BARFPST3
+14 ; A/R bill selection
DO FRPBILL^BARFPST3
End DoDot:2
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 ; Parent facility
SET BAREOB=DUZ(2)
+17 ; Display current payment/adjustment
DO PAYADJD^BARFPST1
+18 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+19 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+20 ; Ask for payments/adjustments
FOR
DO PAYADJ^BARFPST1
IF BARPA="Q"
QUIT
+21 ; No paymnt/adjustments entered
IF ('$DATA(BARPAY)&('$DATA(BARADJ)))
QUIT
+22 ; Save data in FLAT RATE POST File
DO BARSAV^BARFPST2
+23 ; Entry to FRP file failed
IF $DATA(BARNONE)
QUIT
+24 ; Display accum post/balance
DO DISP^BARFPST3
+25 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+26 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+27 ; A/R bill selection
DO FRPBILL^BARFPST3
End DoDot:1
+28 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+29 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
DO EXIT
QUIT
+30 ; Q if facility not asked and no payments or adjustments
+31 IF '$DATA(BARFAC)
IF ('$DATA(BARPAY)&('$DATA(BARADJ)))
DO EXIT
QUIT
+32 IF '$DATA(BARFIEN)
GOTO SELITEM
+33 ; Posting and reviewing bills.
DO ACTION^BARFPST5
+34 DO EXIT
+35 QUIT
+36 ; *********************************************************************
+37 ;
FRPBATCH ;
+1 ; Look up Flate Rate Posting entry
+2 KILL DIC
+3 SET DIC="^BARFRP(DUZ(2),"
+4 SET DIC(0)="AEMQZ"
+5 SET DIC("A")="Select previously opened FRP batch: "
+6 ; Screen for FRP batches not already posted.
+7 SET DIC("S")="I $P(^(0),U,13)'=""P"""
+8 DO ^DIC
+9 ; If look up fails, ask if user is creating a new entry
+10 IF Y<1
DO NEWFRP
QUIT
+11 ; IEN to A/R COLLECTION BATCH
SET BARCOL=$PIECE(Y(0),U,4)
+12 ; OLD BATCH BAR*1.8*6 DD 4.2.4
IF '$$CKDATE^BARPST(BARCOL,1,"SELECT A/R COLLECTION BATCH")
DO NEWFRP
QUIT
+13 ; IEN to A/R FLAT RATE POSTING
SET BARIEN=+Y
+14 ; IEN to ITEM Mult of A/R COLLECT BATCH
SET BARITM=$PIECE(Y(0),U,5)
+15 ; Name of FRP batch
SET BARNAME=Y(0,0)
+16 ; Collection batch name
SET BARBNM=$$VAL^XBDIQ1(90054.01,BARIEN,.04)
+17 QUIT
+18 ; *********************************************************************
+19 ;
NEWFRP ;
+1 ; Ask if user wants to create a new Flat Rate Posting entry
+2 KILL DIR
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Create new entry"
+5 SET DIR("B")="Yes"
+6 DO ^DIR
+7 IF Y'=1
SET BARNEW=0
QUIT
+8 ; Flag for new FRP entry
SET BARNEW=1
+9 QUIT
+10 ; *********************************************************************
+11 ;
BATCH ; EP
+1 ; EP - Select Collection Batch
+2 WRITE !
+3 KILL DIC
+4 ; Batch loop flag
SET BARBATCH=1
+5 SET DIC="^BARCOL(DUZ(2),"
+6 SET DIC(0)="AEZQM"
+7 SET DIC("A")="Select Batch: "
+8 ; Screen for only postable batches where service/section of user
+9 ; equals that of batch.
+10 SET DIC("S")="I $P(^(0),U,3)=""P""&($G(BARUSR(29,""I""))=$P(^(0),U,10))"
+11 ; Write site location next to each selection
+12 SET DIC("W")="D BATW^BARPST"
+13 DO ^DIC
+14 KILL DIC
+15 ; Batch loop flag
IF Y'>0
SET BARBATCH=0
QUIT
+16 ; IEN to A/R COLLECTION BATCH
SET BARCOL=+Y
+17 ;MRS:BAR*1.8*6 DD 4.2.4
IF '$$CKDATE^BARPST(BARCOL,1,"SELECT A/R COLLECTION BATCH")
SET BARBATCH=0
QUIT
+18 ; Collection batch name
SET BARBNM=$PIECE(Y(0),U)
+19 ; Display batch balance and posting total
DO BBAL^BARPST(BARCOL)
+20 QUIT
+21 ; *********************************************************************
+22 ;
ITEM ; EP
+1 ; EP - Select Batch Item Number
+2 WRITE !
+3 ; Item loop flag
SET BARITEM=1
+4 SET DA(1)=BARCOL
+5 SET DIC="^BARCOL(DUZ(2),"_DA(1)_",1,"
+6 SET DIC(0)="AEMQZ"
+7 ; Help dislpay
SET DIC("W")="D DICW^BARPST"
+8 SET DIC("A")="Select Batch Item: "
+9 IF $DATA(BARITM)
SET DIC("B")=$$VAL^XBDIQ1(90051.1101,"BARCOL,BARITM",.01)
+10 ; Screen for all ITEMS not Cancelled or Rolled up
+11 SET DIC("S")="I $P(^(0),U,17)'=""C""&($P(^(0),U,17)'=""R"")"
+12 DO ^DIC
+13 KILL DIC
+14 ; Item loop flag
IF +Y<1
SET BARITEM=0
QUIT
+15 ; IEN to ITEM Mult of A/R COLLECT BATCH
SET BARITM=+Y
+16 ; Check number
SET BARINM=$PIECE(Y(0),U,11)
+17 ; Display item balance and posting total
DO IBAL^BARPST(BARITM)
+18 QUIT
+19 ; *********************************************************************
+20 ;
FAC ; EP
+1 ; Select visit location only if Multiple 3P EOB site parameter
+2 ; is set to yes.
+3 KILL BAREOB
+4 WRITE !
+5 ; Facility loop flag
SET BARFAC=1
+6 ; IEN to A/R COLLECTION
SET DA(2)=+BARCOL
+7 ; IEN to ITEM multiple
SET DA(1)=+BARITM
+8 ; Format global structure
DO ^XBSFGBL(90051.1101601,.BARGL)
+9 SET DIC=$PIECE(BARGL,"DA,",1)
+10 SET DIC(0)="AEMQZ"
+11 SET DIC("W")="W ?20,$J($P(^(0),U,2),8,2)"
+12 SET DIC("A")="Select Visit Location: "
+13 DO ^DIC
+14 KILL DIC
+15 ; Facility loop flag
IF +Y<1
SET BARFAC=0
+16 QUIT
+17 ; *********************************************************************
+18 ;
EXIT ; EP
+1 ; EP - Exit, kill local variables
+2 ; kill namespace variables
DO ^BARVKL0
+3 QUIT
