Routine: BARMAWO3

BARMAWO3 ; IHS/SD/LSL - Automatic Write-Off UFMS NON-BEN IN ERROR 2007 - Reversal ;

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

 ; THIS IS TO BE USE ONLY TO REVERSE THE WRITE OFFS ON NON-BEN ACCOUNTS

 ; WHEN PATCH 1 OF THE UFMS WRITE-OFF 2007 WERE MSITAKENLY MADE BECAUSE

 ; THE OLD CODE WAS USING THE 'STANDS FOR' AND NOT THE CODE FOR VP INSURER TYPE

 ; THE STRING HAD BEEN CHANGED BY THE AUPN DEVELOPER AND WAS NOT PUBLICIZED.

 ; THIS ROUTINE WAS COPIED AND MODIFIED FROM BARMAWO2

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

 ;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 2007 (916) 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 916 (AUTO WRITE-OFF 2007)"

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

 W !?7,"but negative dollar amount. Only the Non-Ben entries mistakenly written"

 W !?7,"off during the UFMS AUTO WRITE-OFF of 2007 in Patch 1 will be reversed"

 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-NON-BEN-REVERSE")) D  Q

 . S Y=^BARTMP("AWO-NON-BEN-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-NON-BEN-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 APR 12,2007 @ 7:00 for each DUZ(2)

 ; APR 12,2007 @ 7:00 used because this is just before the release (4/13)

 ; of UFMS AWO coding. Code 916 did not exist before then.

 S BARDTTR=3070412.07

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

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

ISITAWO ;

 ; Check to see if trans is AUTO WRITE-OFF 2007

 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

 ;BAR*1.8*2

 S BARBL=$P(BARTR(0),U,4)                            ;BILL IEN

 Q:BARBL=""

 S POSTTRAN=$O(^BARTR(DUZ(2),"AC",BARBL,BARDTTR))  ;GET NEXT TRANSACTION

 I POSTTRAN'="" D

 .S POSTAWO=$$GET1^DIQ(90050.03,POSTTRAN_",",103,"I")

 .S POSTDEB=$$GET1^DIQ(90050.03,POSTTRAN_",",3,"I")   ;GET DEBIT OF NEXT TRANS

 S PRETRAN=$O(^BARTR(DUZ(2),"AC",BARBL,BARDTTR),-1)  ;GET NEXT TRANSACTION

 I PRETRAN'="" D

 .S PREAWO=$$GET1^DIQ(90050.03,PRETRAN_",",103,"I")

 .S PRECRED=$$GET1^DIQ(90050.03,PRETRAN_",",2,"I")   ;GET DEBIT OF PREVIOUS TRANS

 ;GET ADJUSTMENT TYPE

 ;this is only for those non-ben accounts that were accidently written off

 S BARACT=$P(BARTR(0),U,6)

 Q:BARACT=""

 S D0=BARACT     ;BAR*1.8*2

 S BARITYP=$$VALI^BARVPM(8)  ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'

 Q:BARITYP'="N"               ;NON-BEN CODE

 K D0

 ;end new code

 ;;ADJUST ACCOUNT       -   WRITE-OFF       -   AUTO WRITE-OFF 2007

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

 . ;I POSTTRAN'="",($P(BARTR(0),U,2)=POSTDEB),(POSTAWO=916) Q  ;IF THIS IS TRUE THEY MANUALLY REVER

 . ;I PRETRAN'="",($P(BARTR(0),U,3)=PRECRED),(PREAWO=916) Q  ;IF THIS IS TRUE THEY

 . I POSTTRAN'="",(POSTAWO=916) Q  ;IF THIS IS TRUE THEY MANUALLY REVER

 . I PRETRAN'="",(PREAWO=916) Q  ;IF THIS IS TRUE THEY

 . D REVERSE

 . D BILLED

 . D ARBILL

ARBILL ;

 K DIR,DIE,DR,DIC,DA,DR

 S DA=$P(BARTR(0),U,4)

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

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

 D ^DIE

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

REVERSE ;

 S BARTRIEN=$$NEW^BARTR                   ; Create new transaction

 S DA=BARTRIEN

 S DIE=90050.03

 S DR="3////^S X=$P(BARTR(0),U,2)"       ; PUT WRITE-OFF AMT IN DEBIT ($$$)

 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////916"                  ; Adj Type (Auto Write off 2007)

 S DIDEL=90050

 D ^DIE                                ; Populate transaction file

 K DIDEL,DIE,DA,DR

 D TR^BARTDO(BARTRIEN)                    ; Post from trans to files

 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)."

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

BILLED ;

 S BARBLDA=$P(BARTR(0),U,4)

 S ABMBIL=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)

 ; Mark bill in 3PB Bill file as BILLED

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

 S DA=$P(ABMBIL,",",2)

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

 D ^DIE

 K DR

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

XIT ;

 D ^BARVKL0

BARMAWO3  ; IHS/SD/LSL - Automatic Write-Off UFMS NON-BEN IN ERROR 2007 - Reversal ;

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

 +2       ;

 +3       ; THIS IS TO BE USE ONLY TO REVERSE THE WRITE OFFS ON NON-BEN ACCOUNTS

 +4       ; WHEN PATCH 1 OF THE UFMS WRITE-OFF 2007 WERE MSITAKENLY MADE BECAUSE

 +5       ; THE OLD CODE WAS USING THE 'STANDS FOR' AND NOT THE CODE FOR VP INSURER TYPE

 +6       ; THE STRING HAD BEEN CHANGED BY THE AUPN DEVELOPER AND WAS NOT PUBLICIZED.

 +7       ;

 +8       ; THIS ROUTINE WAS COPIED AND MODIFIED FROM BARMAWO2

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

 +10      ;STOP!!!  STOP!!!!   STOP!!!!

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

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

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

 +14      ; *********************************************************************

 +15       QUIT

 +16      ;

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 2007 (916) 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 916 (AUTO WRITE-OFF 2007)"

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

 +7        WRITE !?7,"but negative dollar amount. Only the Non-Ben entries mistakenly written"

 +8        WRITE !?7,"off during the UFMS AUTO WRITE-OFF of 2007 in Patch 1 will be reversed"

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

 +10      ;

 +11      ; See if this has been run before

           DO CHECK

 +12       IF BARDONE

               QUIT

 +13      ;

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

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

 +16      ;

 +17       KILL DIR

 +18       SET DIR(0)="Y"

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

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

 +21       DO ^DIR

 +22       KILL DIR

 +23       IF Y=1

               SET BARCONT=1

 +24       QUIT

 +25      ; *********************************************************************

 +26      ;

CHECK     ;

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

 +2        SET BARDONE=0

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

               Begin DoDot:1

 +4                SET Y=^BARTMP("AWO-NON-BEN-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-NON-BEN-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 APR 12,2007 @ 7:00 for each DUZ(2)

 +2       ; APR 12,2007 @ 7:00 used because this is just before the release (4/13)

 +3       ; of UFMS AWO coding. Code 916 did not exist before then.

 +4        SET BARDTTR=3070412.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 AUTO WRITE-OFF 2007

 +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       ;BAR*1.8*2

 +5       ;BILL IEN

           SET BARBL=$PIECE(BARTR(0),U,4)

 +6        IF BARBL=""

               QUIT

 +7       ;GET NEXT TRANSACTION

           SET POSTTRAN=$ORDER(^BARTR(DUZ(2),"AC",BARBL,BARDTTR))

 +8        IF POSTTRAN'=""

               Begin DoDot:1

 +9                SET POSTAWO=$$GET1^DIQ(90050.03,POSTTRAN_",",103,"I")

 +10      ;GET DEBIT OF NEXT TRANS

                   SET POSTDEB=$$GET1^DIQ(90050.03,POSTTRAN_",",3,"I")

               End DoDot:1

 +11      ;GET NEXT TRANSACTION

           SET PRETRAN=$ORDER(^BARTR(DUZ(2),"AC",BARBL,BARDTTR),-1)

 +12       IF PRETRAN'=""

               Begin DoDot:1

 +13               SET PREAWO=$$GET1^DIQ(90050.03,PRETRAN_",",103,"I")

 +14      ;GET DEBIT OF PREVIOUS TRANS

                   SET PRECRED=$$GET1^DIQ(90050.03,PRETRAN_",",2,"I")

               End DoDot:1

 +15      ;GET ADJUSTMENT TYPE

 +16      ;

 +17      ;this is only for those non-ben accounts that were accidently written off

 +18       SET BARACT=$PIECE(BARTR(0),U,6)

 +19       IF BARACT=""

               QUIT

 +20      ;BAR*1.8*2

           SET D0=BARACT

 +21      ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'

           SET BARITYP=$$VALI^BARVPM(8)

 +22      ;NON-BEN CODE

           IF BARITYP'="N"

               QUIT

 +23       KILL D0

 +24      ;end new code

 +25      ;;ADJUST ACCOUNT       -   WRITE-OFF       -   AUTO WRITE-OFF 2007

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

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

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

                       Begin DoDot:1

 +27      ;I POSTTRAN'="",($P(BARTR(0),U,2)=POSTDEB),(POSTAWO=916) Q  ;IF THIS IS TRUE THEY MANUALLY REVER

 +28      ;I PRETRAN'="",($P(BARTR(0),U,3)=PRECRED),(PREAWO=916) Q  ;IF THIS IS TRUE THEY

 +29      ;IF THIS IS TRUE THEY MANUALLY REVER

                           IF POSTTRAN'=""

                               IF (POSTAWO=916)

                                   QUIT

 +30      ;IF THIS IS TRUE THEY

                           IF PRETRAN'=""

                               IF (PREAWO=916)

                                   QUIT

 +31                       DO REVERSE

 +32                       DO BILLED

 +33                       DO ARBILL

                       End DoDot:1

 +34       QUIT

ARBILL    ;

 +1        KILL DIR,DIE,DR,DIC,DA,DR

 +2        SET DA=$PIECE(BARTR(0),U,4)

 +3        SET DIE="^BARBL(DUZ(2),"

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

 +5        DO ^DIE

 +6        QUIT

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

REVERSE   ;

 +1       ; Create new transaction

           SET BARTRIEN=$$NEW^BARTR

 +2        SET DA=BARTRIEN

 +3        SET DIE=90050.03

 +4       ; PUT WRITE-OFF AMT IN DEBIT ($$$)

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

 +5       ; A/R Bill

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

 +6       ; A/R Patient

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

 +7       ; A/R Account

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

 +8       ; Parent Location

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

 +9       ; Parent ASUFAC

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

 +10      ; A/R Section

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

 +11      ; Visit location

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

 +12      ; Date

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

 +13      ; A/R Entry by

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

 +14      ; Transaction type (Adj)

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

 +15      ; Adj Category (Write off)

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

 +16      ; Adj Type (Auto Write off 2007)

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

 +17       SET DIDEL=90050

 +18      ; Populate transaction file

           DO ^DIE

 +19       KILL DIDEL,DIE,DA,DR

 +20      ; Post from trans to files

           DO TR^BARTDO(BARTRIEN)

 +21       KILL BARBL

 +22       SET BARCNT=BARCNT+1

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

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

 +25       QUIT

 +26      ; *********************************************************************

BILLED    ;

 +1        SET BARBLDA=$PIECE(BARTR(0),U,4)

 +2        SET ABMBIL=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)

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

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

 +5        SET DA=$PIECE(ABMBIL,",",2)

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

 +7        DO ^DIE

 +8        KILL DR

 +9        QUIT

 +10      ; *********************************************************************

 +11      ;

XIT       ;

 +1        DO ^BARVKL0

 +2        QUIT

BARMAWO3.m