Routine: BARMAWO2

BARMAWO2 ; IHS/SD/LSL - Automatic Write-Off 2000 - Reversal ;

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**28**;OCT 26, 2005;Build 92

 ; IHS/ASDS/LSL - 09/07/01 - Routine created

 ;     Reverse all transactions of transaction type 43 (Adjustment)

 ;     with Adjustment category 3 (Write-off)

 ;     with Adjustment type 501 (Auto Write-off 2000)

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

 ;STOP!!!  STOP!!!!   STOP!!!!

 ;IHS/SD/SDR 1.8*28 HEAT293633 - This is an old, outdated routine and shouldn't be used

 ;  without review and possible changes.  Routine EN^BARMAWO6 should be used instead.  A

 ;  quit has been added to this routine so it can't be accidentally run.

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

EN ; EP - IHS/DIT/CPC 1.8*28 CR 8349 START

 W "*********************************************************************",!

 W "                     STOP!!!  STOP!!!!   STOP!!!!",!

 W "This is an old, outdated routine and shouldn't be used.  Please ",!

 W "request assistance from OIT before starting the write-off process.",!

 W "*********************************************************************",!

 H 10

 Q  ;IHS/DIT/CPC 1.8*28 CR 8349 STOP

 D NOTE

 Q:'BARCONT

 D NOW^%DTC

 S BARNOW=%

 D LOOP

 W !!!,BARCNT," Bills with Auto Write off 2000 (501) reversed."

 D XIT

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

NOTE ;

 S BARCONT=0

 W !!,$$EN^BARVDF("RVN"),"NOTE:",$$EN^BARVDF("RVF")

 W ?7,"All transactions (at all facilities) of transaction type 43 (Adjustment)"

 W !?7,"with Adjustment Category 3 (Write Off)"

 W !?7,"and Adjustment Type 501 (Auto Write-off 2000)"

 W !?7,"will be reversed by creating a new transaction of the same type,"

 W !?7,"but negative dollar amount."

 W !!?7,$$EN^BARVDF("RVN"),"ALSO,",$$EN^BARVDF("RVF")," the bill will be re-opened in 3PB with a balance due."

 D CHECK                          ; See if this has been run before

 Q:BARDONE

 W !!,"The bill number and amount written off will scroll by on the screen"

 W !,"if you wish to capture this information.",!

 K DIR

 S DIR(0)="Y"

 S DIR("A")="Continue"

 S DIR("B")="No"

 D ^DIR

 K DIR

 S:Y=1 BARCONT=1

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

CHECK ;

 ; Check to see if this option has already been run

 S BARDONE=0

 I $D(^BARTMP("AWO-REVERSE")) D  Q

 . S Y=^BARTMP("AWO-REVERSE")

 . D DD^%DT

 . S BARDONDT=Y

 . S BARDONE=1

 . S $P(BARDASH,"*",54)=""

 . W !!?14,BARDASH

 . W !?14,"* This option was already executed on ",BARDONDT,". *"

 . W !?14,"*",?24,"It may not be executed again.",?66,"*"

 . W !?14,BARDASH

 . D EOP^BARUTL(0)

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

LOOP ;

 ; Loop all DUZ(2) in transaction file.

 S ^BARTMP("AWO-REVERSE")=DT

 S BARCNT=0

 S BARHOLD=DUZ(2)

 S DUZ(2)=0

 F  S DUZ(2)=$O(^BARTR(DUZ(2))) Q:'+DUZ(2)  D TRANS

 S DUZ(2)=BARHOLD

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

TRANS ;

 ; Loop transactions after 12/18/2000 @ 7:00 for each DUZ(2)

 ; 12/18/2000 @ 7:00 used because this is when first AWO coding was

 ; completed. Code 501 did not exist before then.

 S BARDTTR=3001228.07

 F  S BARDTTR=$O(^BARTR(DUZ(2),BARDTTR)) Q:('+BARDTTR!(BARDTTR>BARNOW))  D ISITAWO

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

ISITAWO ;

 ; Check to see if trans is AWO 2000

 S BARTR(0)=$G(^BARTR(DUZ(2),BARDTTR,0))    ; A/R Transaction 0 node

 S BARTR(1)=$G(^BARTR(DUZ(2),BARDTTR,1))    ; A/R Transaction 1 node

 I $P(BARTR(1),U)=43,$P(BARTR(1),U,2)=3,$P(BARTR(1),U,3)=501 D

 . D REVERSE

 . D ROLLBILL

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

REVERSE ;

 S DIE=90050.03

 S DR="2////^S X=-$P(BARTR(0),U,2)"       ; Credit ($$$)

 S DR=DR_";4////^S X=$P(BARTR(0),U,4)"    ; A/R Bill

 S DR=DR_";5////^S X=$P(BARTR(0),U,5)"    ; A/R Patient

 S DR=DR_";6////^S X=$P(BARTR(0),U,6)"    ; A/R Account

 S DR=DR_";8////^S X=$P(BARTR(0),U,8)"    ; Parent Location

 S DR=DR_";9////^S X=$P(BARTR(0),U,9)"    ; Parent ASUFAC

 S DR=DR_";10////^S X=$P(BARTR(0),U,10)"  ; A/R Section

 S DR=DR_";11////^S X=$P(BARTR(0),U,11)"  ; Visit location

 S DR=DR_";12////^S X=DT"                 ; Date

 S DR=DR_";13////^S X=DUZ"                ; A/R Entry by

 S DR=DR_";101////43"                     ; Transaction type (Adj)

 S DR=DR_";102////3"                      ; Adj Category (Write off)

 S DR=DR_";103////501"                  ; Adj Type (Auto Write off 2000)

 S DIDEL=90050

 K DIDEL,DIE,DA,DR

 K BARBL

 S BARCNT=BARCNT+1

 S BARBILL=$$GET1^DIQ(90050.01,$P(BARTR(0),U,4),.01)

 W !,BARBILL,?25," for ",$J($FN(-$P(BARTR(0),U,2),",",2),10)," written off (reversed)."

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

ROLLBILL ;

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

BILLED ;

 ; Mark bill in 3PB Bill file as BILLED

 S DIE="^ABMDBILL(DUZ(2),"

 S DA=ABMP("BDFN")

 S DR=".04////B"

 D ^DIE

 K DR

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

XIT ;

 D ^BARVKL0

BARMAWO2  ; IHS/SD/LSL - Automatic Write-Off 2000 - Reversal ;

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**28**;OCT 26, 2005;Build 92

 +2       ;

 +3       ; IHS/ASDS/LSL - 09/07/01 - Routine created

 +4       ;     Reverse all transactions of transaction type 43 (Adjustment)

 +5       ;     with Adjustment category 3 (Write-off)

 +6       ;     with Adjustment type 501 (Auto Write-off 2000)

 +7       ;

 +8       ; *********************************************************************

 +9       ;STOP!!!  STOP!!!!   STOP!!!!

 +10      ;IHS/SD/SDR 1.8*28 HEAT293633 - This is an old, outdated routine and shouldn't be used

 +11      ;  without review and possible changes.  Routine EN^BARMAWO6 should be used instead.  A

 +12      ;  quit has been added to this routine so it can't be accidentally run.

 +13      ; *********************************************************************

 +14       QUIT

 +15      ;

EN        ; EP - IHS/DIT/CPC 1.8*28 CR 8349 START

 +1        WRITE "*********************************************************************",!

 +2        WRITE "                     STOP!!!  STOP!!!!   STOP!!!!",!

 +3        WRITE "This is an old, outdated routine and shouldn't be used.  Please ",!

 +4        WRITE "request assistance from OIT before starting the write-off process.",!

 +5        WRITE "*********************************************************************",!

 +6        HANG 10

 +7       ;IHS/DIT/CPC 1.8*28 CR 8349 STOP

           QUIT

 +8        DO NOTE

 +9        IF 'BARCONT

               QUIT

 +10       DO NOW^%DTC

 +11       SET BARNOW=%

 +12       DO LOOP

 +13       WRITE !!!,BARCNT," Bills with Auto Write off 2000 (501) reversed."

 +14       DO XIT

 +15       QUIT

 +16      ; *********************************************************************

 +17      ;

NOTE      ;

 +1        SET BARCONT=0

 +2        WRITE !!,$$EN^BARVDF("RVN"),"NOTE:",$$EN^BARVDF("RVF")

 +3        WRITE ?7,"All transactions (at all facilities) of transaction type 43 (Adjustment)"

 +4        WRITE !?7,"with Adjustment Category 3 (Write Off)"

 +5        WRITE !?7,"and Adjustment Type 501 (Auto Write-off 2000)"

 +6        WRITE !?7,"will be reversed by creating a new transaction of the same type,"

 +7        WRITE !?7,"but negative dollar amount."

 +8        WRITE !!?7,$$EN^BARVDF("RVN"),"ALSO,",$$EN^BARVDF("RVF")," the bill will be re-opened in 3PB with a balance due."

 +9       ;

 +10      ; See if this has been run before

           DO CHECK

 +11       IF BARDONE

               QUIT

 +12      ;

 +13       WRITE !!,"The bill number and amount written off will scroll by on the screen"

 +14       WRITE !,"if you wish to capture this information.",!

 +15      ;

 +16       KILL DIR

 +17       SET DIR(0)="Y"

 +18       SET DIR("A")="Continue"

 +19       SET DIR("B")="No"

 +20       DO ^DIR

 +21       KILL DIR

 +22       IF Y=1

               SET BARCONT=1

 +23       QUIT

 +24      ; *********************************************************************

 +25      ;

CHECK     ;

 +1       ; Check to see if this option has already been run

 +2        SET BARDONE=0

 +3        IF $DATA(^BARTMP("AWO-REVERSE"))

               Begin DoDot:1

 +4                SET Y=^BARTMP("AWO-REVERSE")

 +5                DO DD^%DT

 +6                SET BARDONDT=Y

 +7                SET BARDONE=1

 +8                SET $PIECE(BARDASH,"*",54)=""

 +9                WRITE !!?14,BARDASH

 +10               WRITE !?14,"* This option was already executed on ",BARDONDT,". *"

 +11               WRITE !?14,"*",?24,"It may not be executed again.",?66,"*"

 +12               WRITE !?14,BARDASH

 +13               DO EOP^BARUTL(0)

               End DoDot:1

               QUIT

 +14       QUIT

 +15      ; *********************************************************************

 +16      ;

LOOP      ;

 +1       ; Loop all DUZ(2) in transaction file.

 +2        SET ^BARTMP("AWO-REVERSE")=DT

 +3        SET BARCNT=0

 +4        SET BARHOLD=DUZ(2)

 +5        SET DUZ(2)=0

 +6        FOR

               SET DUZ(2)=$ORDER(^BARTR(DUZ(2)))

               IF '+DUZ(2)

                   QUIT

               DO TRANS

 +7        SET DUZ(2)=BARHOLD

 +8        QUIT

 +9       ; *********************************************************************

 +10      ;

TRANS     ;

 +1       ; Loop transactions after 12/18/2000 @ 7:00 for each DUZ(2)

 +2       ; 12/18/2000 @ 7:00 used because this is when first AWO coding was

 +3       ; completed. Code 501 did not exist before then.

 +4        SET BARDTTR=3001228.07

 +5        FOR

               SET BARDTTR=$ORDER(^BARTR(DUZ(2),BARDTTR))

               IF ('+BARDTTR!(BARDTTR>BARNOW))

                   QUIT

               DO ISITAWO

 +6        QUIT

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

 +8       ;

ISITAWO   ;

 +1       ; Check to see if trans is AWO 2000

 +2       ; A/R Transaction 0 node

           SET BARTR(0)=$GET(^BARTR(DUZ(2),BARDTTR,0))

 +3       ; A/R Transaction 1 node

           SET BARTR(1)=$GET(^BARTR(DUZ(2),BARDTTR,1))

 +4        IF $PIECE(BARTR(1),U)=43

               IF $PIECE(BARTR(1),U,2)=3

                   IF $PIECE(BARTR(1),U,3)=501

                       Begin DoDot:1

 +5                        DO REVERSE

 +6                        DO ROLLBILL

                       End DoDot:1

 +7        QUIT

 +8       ; *********************************************************************

 +9       ;

REVERSE   ;

 +1        SET DIE=90050.03

 +2       ; Credit ($$$)

           SET DR="2////^S X=-$P(BARTR(0),U,2)"

 +3       ; A/R Bill

           SET DR=DR_";4////^S X=$P(BARTR(0),U,4)"

 +4       ; A/R Patient

           SET DR=DR_";5////^S X=$P(BARTR(0),U,5)"

 +5       ; A/R Account

           SET DR=DR_";6////^S X=$P(BARTR(0),U,6)"

 +6       ; Parent Location

           SET DR=DR_";8////^S X=$P(BARTR(0),U,8)"

 +7       ; Parent ASUFAC

           SET DR=DR_";9////^S X=$P(BARTR(0),U,9)"

 +8       ; A/R Section

           SET DR=DR_";10////^S X=$P(BARTR(0),U,10)"

 +9       ; Visit location

           SET DR=DR_";11////^S X=$P(BARTR(0),U,11)"

 +10      ; Date

           SET DR=DR_";12////^S X=DT"

 +11      ; A/R Entry by

           SET DR=DR_";13////^S X=DUZ"

 +12      ; Transaction type (Adj)

           SET DR=DR_";101////43"

 +13      ; Adj Category (Write off)

           SET DR=DR_";102////3"

 +14      ; Adj Type (Auto Write off 2000)

           SET DR=DR_";103////501"

 +15       SET DIDEL=90050

 +16       KILL DIDEL,DIE,DA,DR

 +17       KILL BARBL

 +18       SET BARCNT=BARCNT+1

 +19       SET BARBILL=$$GET1^DIQ(90050.01,$PIECE(BARTR(0),U,4),.01)

 +20       WRITE !,BARBILL,?25," for ",$JUSTIFY($FNUMBER(-$PIECE(BARTR(0),U,2),",",2),10)," written off (reversed)."

 +21       QUIT

 +22      ; *********************************************************************

 +23      ;

ROLLBILL  ;

 +1        QUIT

 +2       ; *********************************************************************

 +3       ;

BILLED    ;

 +1       ; Mark bill in 3PB Bill file as BILLED

 +2        SET DIE="^ABMDBILL(DUZ(2),"

 +3        SET DA=ABMP("BDFN")

 +4        SET DR=".04////B"

 +5        DO ^DIE

 +6        KILL DR

 +7        QUIT

 +8       ; *********************************************************************

 +9       ;

XIT       ;

 +1        DO ^BARVKL0

 +2        QUIT

BARMAWO2.m