BARTDO ; IHS/SD/LSL - ROUTINE TO PERFORM TRANSACTIONS ; 12/12/2007
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,5**;JUN 22, 2008
;;
;given the da of a transaction, this will pull the data
;from the transaction and perform the setting of fields
;in the related files.
; to reverse an entry pass BARUNDO=1
;
; IHS/SD/SDR - 4/18/02 - V1.6 P2 - Update for new trans. type
; Updated to include new transaction type FLAT RATE ADJUSTMENT.
; It should be treated the same as BILL NEW.
;
; IHS/SD/LSL - 03/04/03 - V1.7 Patch 1 - Remove call to BARPSDAT
; Routine was deleted as Period Summary Data File no longer exists
;
Q
; *********************************************************************
;
TR(BARTRDA,BARUNDO) ; EP
; Pull the transaction and perform the sets per the type of transaction
S:'$D(BARUNDO) BARUNDO=0
;
I $D(UFMSESID) D
.S X=$$TRANTRIG^BARUFUT(DUZ,UFMSESID,BARTRDA) ;BAR*1.8*3 UFMS ;IF ERA POSTING FLAG IS SET
;
;
K BART
D ENP^XBDIQ1(90050.03,BARTRDA,".01;3.5;4;5;6;10;11;14;15;101;102;103","BART(","I")
S BARTYP=BART(101,"I")
Q:BARTYP=""
K BARX
;F X=39,40,41,43,49,108,503 S BARX(X)=""
F X=138,139,39,40,41,43,108,503 S BARX(X)="" ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 INCLUDE 'PAYMENT CREDIT'
I '$D(BARX(BARTYP)) Q
S BARAMT=BART(3.5)
S:BARUNDO BARAMT=-BARAMT ; reverse or back out
;
I BARTYP D @BARTYP ; types as set in the element tables for transactions
Q
; *********************************************************************
;
138 ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 INCLUDE 'CREDIT TO OTHER BILL' - ACT LIKE ADJUST
; Payment credit (act like adjustment)
D 43
Q
; ********************************************************************
139 ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 INCLUDE 'CREDIT FROM OTHER BILL' - ACT LIKE ADJUST
; Payment credit (act like adjustment)
D 43
Q
; *********************************************************************
;
39 ;
; Refund (act like adjustment)
D 43
Q
; ********************************************************************
;
40 ;
; payment to a bill /account
N DIC,DIE,DR,DA,BARBLV
S BARACC=BART(6,"I")
S BARBL=BART(4,"I")
;update account fields un-posted, current a/r ballance
S (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
S DA=BARACC
G:'$D(^BARAC(DUZ(2),DA,0)) BILL40
S BARBLV(301)=$$GET1^DIQ(90050.02,DA,301,"I")
S BARBLV(302)=$$GET1^DIQ(90050.02,DA,302,"I")
S DR="301////^S X=BARBLV(301)-BARAMT;302////^S X=BARBLV(302)-BARAMT"
S DIDEL=90050
D ^DIE
K DIDEL
; -------------------------------
;
BILL40 ;
; update bill amount field
N DIC,DIE,DR,DA,BARBLV
S (DIC,DIE)=$$DIC^XBDIQ1(90050.01)
S DA=BARBL
S BARBLV(15)=$$GET1^DIQ(90050.01,DA,15)
S DR="15////^S X=BARBLV(15)-BARAMT"
;
I ;
S DIDEL=90050
D ^DIE
K DIDEL
; -------------------------------
;
BATCH ;** update batch
; Replaced by triggers in Collection Batch
; -------------------------------
;
BLVL ;** batch level
; Replaced by triggers in Collection Batch
; -------------------------------
;
ILVL ;** batch item level
N DIC,DIE,DR,DA,BARUN
S (DIC,DIE)=$$DIC^XBSFGBL(90051.1101)
K DA
S DA(1)=BART(14,"I")
S DA=BART(15,"I")
S BARUN(18)=$$VALI^XBDIQ1(DIC,.DA,18)
S DR="18////^S X=BARUN(18)+BARAMT"
S DIDEL=90050
D ^DIE
K DIDEL
; -------------------------------
;
SLVL ;** batch item sub eob level
; to be coded when sub item is put into transactions
Q
; *********************************************************************
;
Q40 ;
Q
; *********************************************************************
;
41 ;cancellation of a bill/account
N DIC,DIE,DR,DA,BARBLV
;adjust account field current a/r balance
S (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
S DA=BART(6,"I")
G:'$D(^BARAC(DUZ(2),DA,0)) BILL41
S BARBLV(301)=$$GET1^DIQ(90050.02,DA,301,"I")
S DR="301////^S X=BARBLV(301)-BARAMT"
S DIDEL=90050
D ^DIE
K DIDEL
; -------------------------------
;
BILL41 ;update bill amount field
N DIE,DR,DA,BARBLV
S (DIC,DIE)=$$DIC^XBDIQ1(90050.01)
S DA=BART(4,"I")
S BARBLV(15)=$$GET1^DIQ(90050.01,DA,15)
S DR="15////^S X=BARBLV(15)-BARAMT"
S DIDEL=90050
D ^DIE
K DIDEL
Q41 ;
Q
; *********************************************************************
;
43 ;adjustment to a bill/account
N DIC,DIE,DR,DA,BARBLV
;adjust account field current a/r balance
S (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
S DA=BART(6,"I")
G:'$D(^BARAC(DUZ(2),DA,0)) BILL43
S BARBLV(301)=$$GET1^DIQ(90050.02,DA,301,"I")
S DR="301////^S X=BARBLV(301)-BARAMT"
S DIDEL=90050
D ^DIE
K DIDEL
; -------------------------------
;
BILL43 ;update bill amount field
N DIE,DR,DA,BARBLV
S (DIC,DIE)=$$DIC^XBDIQ1(90050.01)
S DA=BART(4,"I")
S BARBLV(15)=$$GET1^DIQ(90050.01,DA,15)
S DR="15////^S X=BARBLV(15)-BARAMT"
S DIDEL=90050
D ^DIE
K DIDEL
Q43 ;
Q
; *********************************************************************
;
49 ;bill new / account
N DIC,DIE,DA,DR,BARACV
S (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
S DA=BART(6,"I")
Q:'$D(^BARAC(DUZ(2),DA,0))
S BARACV=$$GET1^DIQ(90050.02,DA,301,"I")
S DR="301////^S X=BARACV-BARAMT"
S DIDEL=90050
D ^DIE
K DIDEL
Q49 ;
Q
; *********************************************************************
;
108 ; 3P credit - edit cr field and then same sequence as an adjustment
N DIE,DA,DR
S DIE=$$DIC^XBDIQ1(90050.01)
S DA=BARBLDA
S DR="20////^S X=BARAMT"
D ^DIE
D 43
Q108 ;
Q
; *********************************************************************
;
503 ; Flat Rate Adjustment
D 49 ;FRA should be treated the same as BILL NEW
Q
BARTDO ; IHS/SD/LSL - ROUTINE TO PERFORM TRANSACTIONS ; 12/12/2007
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,5**;JUN 22, 2008
+2 ;;
+3 ;given the da of a transaction, this will pull the data
+4 ;from the transaction and perform the setting of fields
+5 ;in the related files.
+6 ; to reverse an entry pass BARUNDO=1
+7 ;
+8 ; IHS/SD/SDR - 4/18/02 - V1.6 P2 - Update for new trans. type
+9 ; Updated to include new transaction type FLAT RATE ADJUSTMENT.
+10 ; It should be treated the same as BILL NEW.
+11 ;
+12 ; IHS/SD/LSL - 03/04/03 - V1.7 Patch 1 - Remove call to BARPSDAT
+13 ; Routine was deleted as Period Summary Data File no longer exists
+14 ;
+15 QUIT
+16 ; *********************************************************************
+17 ;
TR(BARTRDA,BARUNDO) ; EP
+1 ; Pull the transaction and perform the sets per the type of transaction
+2 IF '$DATA(BARUNDO)
SET BARUNDO=0
+3 ;
+4 IF $DATA(UFMSESID)
Begin DoDot:1
+5 ;BAR*1.8*3 UFMS ;IF ERA POSTING FLAG IS SET
SET X=$$TRANTRIG^BARUFUT(DUZ,UFMSESID,BARTRDA)
End DoDot:1
+6 ;
+7 ;
+8 KILL BART
+9 DO ENP^XBDIQ1(90050.03,BARTRDA,".01;3.5;4;5;6;10;11;14;15;101;102;103","BART(","I")
+10 SET BARTYP=BART(101,"I")
+11 IF BARTYP=""
QUIT
+12 KILL BARX
+13 ;F X=39,40,41,43,49,108,503 S BARX(X)=""
+14 ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 INCLUDE 'PAYMENT CREDIT'
FOR X=138,139,39,40,41,43,108,503
SET BARX(X)=""
+15 IF '$DATA(BARX(BARTYP))
QUIT
+16 SET BARAMT=BART(3.5)
+17 ; reverse or back out
IF BARUNDO
SET BARAMT=-BARAMT
+18 ;
+19 ; types as set in the element tables for transactions
IF BARTYP
DO @BARTYP
+20 QUIT
+21 ; *********************************************************************
+22 ;
138 ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 INCLUDE 'CREDIT TO OTHER BILL' - ACT LIKE ADJUST
+1 ; Payment credit (act like adjustment)
+2 DO 43
+3 QUIT
+4 ; ********************************************************************
139 ;BAR*1.8*5 SRS-80 IHS/SD/TPF 4/15/2008 INCLUDE 'CREDIT FROM OTHER BILL' - ACT LIKE ADJUST
+1 ; Payment credit (act like adjustment)
+2 DO 43
+3 QUIT
+4 ; *********************************************************************
+5 ;
39 ;
+1 ; Refund (act like adjustment)
+2 DO 43
+3 QUIT
+4 ; ********************************************************************
+5 ;
40 ;
+1 ; payment to a bill /account
+2 NEW DIC,DIE,DR,DA,BARBLV
+3 SET BARACC=BART(6,"I")
+4 SET BARBL=BART(4,"I")
+5 ;update account fields un-posted, current a/r ballance
+6 SET (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
+7 SET DA=BARACC
+8 IF '$DATA(^BARAC(DUZ(2),DA,0))
GOTO BILL40
+9 SET BARBLV(301)=$$GET1^DIQ(90050.02,DA,301,"I")
+10 SET BARBLV(302)=$$GET1^DIQ(90050.02,DA,302,"I")
+11 SET DR="301////^S X=BARBLV(301)-BARAMT;302////^S X=BARBLV(302)-BARAMT"
+12 SET DIDEL=90050
+13 DO ^DIE
+14 KILL DIDEL
+15 ; -------------------------------
+16 ;
BILL40 ;
+1 ; update bill amount field
+2 NEW DIC,DIE,DR,DA,BARBLV
+3 SET (DIC,DIE)=$$DIC^XBDIQ1(90050.01)
+4 SET DA=BARBL
+5 SET BARBLV(15)=$$GET1^DIQ(90050.01,DA,15)
+6 SET DR="15////^S X=BARBLV(15)-BARAMT"
+7 ;
I ;
+1 SET DIDEL=90050
+2 DO ^DIE
+3 KILL DIDEL
+4 ; -------------------------------
+5 ;
BATCH ;** update batch
+1 ; Replaced by triggers in Collection Batch
+2 ; -------------------------------
+3 ;
BLVL ;** batch level
+1 ; Replaced by triggers in Collection Batch
+2 ; -------------------------------
+3 ;
ILVL ;** batch item level
+1 NEW DIC,DIE,DR,DA,BARUN
+2 SET (DIC,DIE)=$$DIC^XBSFGBL(90051.1101)
+3 KILL DA
+4 SET DA(1)=BART(14,"I")
+5 SET DA=BART(15,"I")
+6 SET BARUN(18)=$$VALI^XBDIQ1(DIC,.DA,18)
+7 SET DR="18////^S X=BARUN(18)+BARAMT"
+8 SET DIDEL=90050
+9 DO ^DIE
+10 KILL DIDEL
+11 ; -------------------------------
+12 ;
SLVL ;** batch item sub eob level
+1 ; to be coded when sub item is put into transactions
+2 QUIT
+3 ; *********************************************************************
+4 ;
Q40 ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
41 ;cancellation of a bill/account
+1 NEW DIC,DIE,DR,DA,BARBLV
+2 ;adjust account field current a/r balance
+3 SET (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
+4 SET DA=BART(6,"I")
+5 IF '$DATA(^BARAC(DUZ(2),DA,0))
GOTO BILL41
+6 SET BARBLV(301)=$$GET1^DIQ(90050.02,DA,301,"I")
+7 SET DR="301////^S X=BARBLV(301)-BARAMT"
+8 SET DIDEL=90050
+9 DO ^DIE
+10 KILL DIDEL
+11 ; -------------------------------
+12 ;
BILL41 ;update bill amount field
+1 NEW DIE,DR,DA,BARBLV
+2 SET (DIC,DIE)=$$DIC^XBDIQ1(90050.01)
+3 SET DA=BART(4,"I")
+4 SET BARBLV(15)=$$GET1^DIQ(90050.01,DA,15)
+5 SET DR="15////^S X=BARBLV(15)-BARAMT"
+6 SET DIDEL=90050
+7 DO ^DIE
+8 KILL DIDEL
Q41 ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
43 ;adjustment to a bill/account
+1 NEW DIC,DIE,DR,DA,BARBLV
+2 ;adjust account field current a/r balance
+3 SET (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
+4 SET DA=BART(6,"I")
+5 IF '$DATA(^BARAC(DUZ(2),DA,0))
GOTO BILL43
+6 SET BARBLV(301)=$$GET1^DIQ(90050.02,DA,301,"I")
+7 SET DR="301////^S X=BARBLV(301)-BARAMT"
+8 SET DIDEL=90050
+9 DO ^DIE
+10 KILL DIDEL
+11 ; -------------------------------
+12 ;
BILL43 ;update bill amount field
+1 NEW DIE,DR,DA,BARBLV
+2 SET (DIC,DIE)=$$DIC^XBDIQ1(90050.01)
+3 SET DA=BART(4,"I")
+4 SET BARBLV(15)=$$GET1^DIQ(90050.01,DA,15)
+5 SET DR="15////^S X=BARBLV(15)-BARAMT"
+6 SET DIDEL=90050
+7 DO ^DIE
+8 KILL DIDEL
Q43 ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
49 ;bill new / account
+1 NEW DIC,DIE,DA,DR,BARACV
+2 SET (DIC,DIE)=$$DIC^XBDIQ1(90050.02)
+3 SET DA=BART(6,"I")
+4 IF '$DATA(^BARAC(DUZ(2),DA,0))
QUIT
+5 SET BARACV=$$GET1^DIQ(90050.02,DA,301,"I")
+6 SET DR="301////^S X=BARACV-BARAMT"
+7 SET DIDEL=90050
+8 DO ^DIE
+9 KILL DIDEL
Q49 ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
108 ; 3P credit - edit cr field and then same sequence as an adjustment
+1 NEW DIE,DA,DR
+2 SET DIE=$$DIC^XBDIQ1(90050.01)
+3 SET DA=BARBLDA
+4 SET DR="20////^S X=BARAMT"
+5 DO ^DIE
+6 DO 43
Q108 ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
503 ; Flat Rate Adjustment
+1 ;FRA should be treated the same as BILL NEW
DO 49
+2 QUIT
