Routine: BARTDO

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

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

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

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

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

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

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

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

39 ;

 ; Refund (act like adjustment)

 D 43

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

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

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

Q40 ;

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

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 ;

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

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 ;

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

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 ;

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

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 ;

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

503 ; Flat Rate Adjustment

 D 49   ;FRA should be treated the same as BILL NEW

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

BARTDO.m