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.
; *********************************************************************
Q
;
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
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
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)
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
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)."
Q
; *********************************************************************
;
ROLLBILL ;
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
XIT ;
D ^BARVKL0
Q
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
