BARMAWO1 ; IHS/SD/LSL - Automatic Write-off (con't) ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,2,28**;OCT 26, 2005;Build 92
;
; IHS/ASDS/LSL - 06/15/2001 - V1.5 Patch 1 - NOIS HQW-0601-100051
; Modifying BARMAWO to extend the expiration date resulted in
; the routine being too large. Created this routine to break
; up BARMAWO.
;
; IHS/ASDS/LSL - 09/07/01 - V1.5 Patch 2
; Modified to accomodate finance changes as documented in BARMAWO
;
; IHS/SD/LSL - 07/24/02 - V1.7 - NOIS CMA-0702-110082
; Resolve <UNDEF>WRITEOFF+17^BARMAWO1
;
; IHS/SD/LSL - 11/26/02 - V1.7 - NOIS QAA-1200-130051
; Quit if error in getting A/R Transaction
;
; IHS/SD/LSL - 12/06/02 - V1.7 - NOIS NHA-0601-180049
; Find 3P bill correctly.
;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
; *********************************************************************
LOOPDUZ ; EP
; Loop A/R Bill File by DUZ(2)
S BARDUZ=0
F S BARDUZ=$O(^BARBL(BARDUZ)) Q:'+BARDUZ D LOOPDT
Q
; *********************************************************************
LOOPDT ;
; Loop A/R Bill File by date of service
S BARVISIT=0
F S BARVISIT=$O(^BARBL(BARDUZ,"E",BARVISIT)) Q:'+BARVISIT!(BARVISIT>BARDOS) D LOOPBIL
Q
; *********************************************************************
LOOPBIL ;
; Loop bills for date of service
S BARBL2=0
F S BARBL2=$O(^BARBL(BARDUZ,"E",BARVISIT,BARBL2)) Q:'+BARBL2 D WRITEOFF
Q
; *********************************************************************
WRITEOFF ;
; Write off bills that meet criteria
Q:'$D(^BARBL(BARDUZ,BARBL2)) ; No bill data
S BAR(0)=$G(^BARBL(BARDUZ,BARBL2,0)) ; A/R Bill 0 node
S BAR(1)=$G(^BARBL(BARDUZ,BARBL2,1)) ; A/R Bill 0 node
S BARBAL=$P(BAR(0),U,15) ; Bill Balance
S BARAMT=$P(BAR(0),U,13) ; Billed Amount
S BARVSTL=$P(BAR(1),U,8) ; Visit location
; Q if A/R account is not on bill
Q:$P(BAR(0),U,3)=""
; Q if visit location not in list
I $D(BAR("LOC")),'$D(BAR("LOC",BARVSTL)) Q
; Q if A/R account not in list
I $D(BAR("ACCT")),'$D(BAR("ACCT",$P(BAR(0),U,3))) Q
S BARACT=$P(BAR(0),U,3) ;A/R Account
;BAR*1.8*2 LOGIC BELOW DOES NOT WORK BECAUSE OF CHANGES MADE TO SET OF CODES
;BY AUPN DEVELOPER
;S BARITYP=$$GET1^DIQ(90050.02,BARACT,1.08)
;I BARITYP["NON-BENEFICIARY" Q ;Don't write off non-bens
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
;
I BARBAL'>0 D Q ; Don't want 0 or credit bal
. S ^BARTMP("BARAWO",BARDUZ,DT,DUZ,"CREDIT",BARBL2)=""
I BARAMT>20000 D Q ; May only write-off $20,000
. S ^BARTMP("BARAWO",BARDUZ,DT,DUZ,"TOO HIGH",BARBL2)=""
;I $P(BAR(1),U,2)>(DT-30000) D Q
;. S ^BARTMP("BARAWO2",BARDUZ,DT,DUZ,"DATE",BARBL2)=""
;BAR*1.8*1 UFMS. IF EXP DATE TO USE OPTION IS 4/30/2007 THIS IS A UFMS WRITEOFF
;AND THERE IS NO DATE LIMIT PAST 3 YEARS ON DOS
;I BAREXP'=3070430 D Q
I BAREXP'=3070525 D Q
.I $P(BAR(1),U,2)>(DT-30000) D
.. S ^BARTMP("BARAWO2",BARDUZ,DT,DUZ,"DATE",BARBL2)=""
S DUZ(2)=BARDUZ
S BARTRIEN=$$NEW^BARTR ; Create new transaction
I BARTRIEN<1 D MSG^BARTR(BARBL2) Q
S DA=BARTRIEN
S DIE=90050.03
S DR="2////^S X=BARBAL" ; Credit ($$$)
S DR=DR_";4////^S X=BARBL2" ; A/R Bill
S DR=DR_";5////^S X=$P(BAR(1),U)" ; A/R Patient
S DR=DR_";6////^S X=$P(BAR(0),U,3)" ; A/R Account
S DR=DR_";8////^S X=DUZ(2)" ; Parent Location
S DR=DR_";9////^S X=DUZ(2)" ; Parent ASUFAC
S DR=DR_";10////^S X=BARSECT" ; A/R Section
S DR=DR_";11////^S X=$P(BAR(1),U,8)" ; 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)
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
W !,$P(BAR(0),U),?25," for ",$J($FN(BARBAL,",",2),10)," written off."
D ROLLBILL ; Roll info to 3PB
Q
; *********************************************************************
ROLLBILL ;
; For bills written off, update Payment multiple in 3P and mark bill
; complete in 3PB. Also mark bill as rolled in A/R
S BARBLDA=BARBL2
D SETVAR^BARROLL ; Set A/R vars to roll to 3PB
S ROLL=0 ;BAR*1.8*1 UFMS WRITE-OFF
D ROLL
Q:'ROLL ;BAR*1.8*1 UFMS WRITE-OFF
D SETBLRL^BARROLL ; Mark bill as rolled
Q
; *********************************************************************
ROLL ;EP
; Changed code NHA-0601-180049 V1.6 Patch 4
; Roll A/R vars to 3PB
K DIE,DA,DR
S BAR("3P BILL LOC")=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
S DUZO2=DUZ(2)
S DUZ(2)=$P(BAR("3P BILL LOC"),",")
S Y=$P(BAR("3P BILL LOC"),",",2)
;BEGIN ;IF CAN'T FIND 3P BILL INFO SKIP ROLL OVER BAR*1.8*1
I DUZ(2)=""!(Y="") S ROLL=0,DUZ(2)=DUZO2 Q
S ROLL=1
;END
S Y=Y_"^"_DUZ(2)
S DIC=$$DIC^XBDIQ1(9002274.4)
S BARGBL=DIC_+Y_")"
I $D(@BARGBL) D ROLLTPB ; Roll to 3PB
S DUZ(2)=DUZO2
Q
; *********************************************************************
ROLLTPB ;
; File A/R data in payment mult of 3PB
M ABM=BARSUM
S X=Y
;S Z=BAR3PNM ;IM18173 BAR*1.8*1
S ABMP("BDFN")=+X ; IEN to 3PB BILL
S ABMP("BILL")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",1) ; Bill #
;BEGIN IM18173
;I '$D(Z) D ; Z UNDEF IFF rtn called by A/R 1.0
;. S ABMP("AR1.0")=""
;. S Y=ABM
;. K ABM
;. S ABM("AMT")=Y
;I $G(Z)]"",ABMP("BILL")'=Z D LKUP^ABMAROLL
;END IM18173
I 'ABMP("BDFN") Q
; File A/R data in payment multiple of 3P BILL and complete bill
D FILE^ABMAROLL
Q
BARMAWO1 ; IHS/SD/LSL - Automatic Write-off (con't) ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,2,28**;OCT 26, 2005;Build 92
+2 ;
+3 ; IHS/ASDS/LSL - 06/15/2001 - V1.5 Patch 1 - NOIS HQW-0601-100051
+4 ; Modifying BARMAWO to extend the expiration date resulted in
+5 ; the routine being too large. Created this routine to break
+6 ; up BARMAWO.
+7 ;
+8 ; IHS/ASDS/LSL - 09/07/01 - V1.5 Patch 2
+9 ; Modified to accomodate finance changes as documented in BARMAWO
+10 ;
+11 ; IHS/SD/LSL - 07/24/02 - V1.7 - NOIS CMA-0702-110082
+12 ; Resolve <UNDEF>WRITEOFF+17^BARMAWO1
+13 ;
+14 ; IHS/SD/LSL - 11/26/02 - V1.7 - NOIS QAA-1200-130051
+15 ; Quit if error in getting A/R Transaction
+16 ;
+17 ; IHS/SD/LSL - 12/06/02 - V1.7 - NOIS NHA-0601-180049
+18 ; Find 3P bill correctly.
+19 ;IHS/DIT/CPC 1.8*28 CR 8349 START
+20 WRITE "*********************************************************************",!
+21 WRITE " STOP!!! STOP!!!! STOP!!!!",!
+22 WRITE "This is an old, outdated routine and shouldn't be used. Please ",!
+23 WRITE "request assistance from OIT before starting the write-off process.",!
+24 WRITE "*********************************************************************",!
+25 HANG 10
+26 ;IHS/DIT/CPC 1.8*28 CR 8349 STOP
QUIT
+27 ; *********************************************************************
LOOPDUZ ; EP
+1 ; Loop A/R Bill File by DUZ(2)
+2 SET BARDUZ=0
+3 FOR
SET BARDUZ=$ORDER(^BARBL(BARDUZ))
IF '+BARDUZ
QUIT
DO LOOPDT
+4 QUIT
+5 ; *********************************************************************
LOOPDT ;
+1 ; Loop A/R Bill File by date of service
+2 SET BARVISIT=0
+3 FOR
SET BARVISIT=$ORDER(^BARBL(BARDUZ,"E",BARVISIT))
IF '+BARVISIT!(BARVISIT>BARDOS)
QUIT
DO LOOPBIL
+4 QUIT
+5 ; *********************************************************************
LOOPBIL ;
+1 ; Loop bills for date of service
+2 SET BARBL2=0
+3 FOR
SET BARBL2=$ORDER(^BARBL(BARDUZ,"E",BARVISIT,BARBL2))
IF '+BARBL2
QUIT
DO WRITEOFF
+4 QUIT
+5 ; *********************************************************************
WRITEOFF ;
+1 ; Write off bills that meet criteria
+2 ; No bill data
IF '$DATA(^BARBL(BARDUZ,BARBL2))
QUIT
+3 ; A/R Bill 0 node
SET BAR(0)=$GET(^BARBL(BARDUZ,BARBL2,0))
+4 ; A/R Bill 0 node
SET BAR(1)=$GET(^BARBL(BARDUZ,BARBL2,1))
+5 ; Bill Balance
SET BARBAL=$PIECE(BAR(0),U,15)
+6 ; Billed Amount
SET BARAMT=$PIECE(BAR(0),U,13)
+7 ; Visit location
SET BARVSTL=$PIECE(BAR(1),U,8)
+8 ; Q if A/R account is not on bill
+9 IF $PIECE(BAR(0),U,3)=""
QUIT
+10 ; Q if visit location not in list
+11 IF $DATA(BAR("LOC"))
IF '$DATA(BAR("LOC",BARVSTL))
QUIT
+12 ; Q if A/R account not in list
+13 IF $DATA(BAR("ACCT"))
IF '$DATA(BAR("ACCT",$PIECE(BAR(0),U,3)))
QUIT
+14 ;A/R Account
SET BARACT=$PIECE(BAR(0),U,3)
+15 ;BAR*1.8*2 LOGIC BELOW DOES NOT WORK BECAUSE OF CHANGES MADE TO SET OF CODES
+16 ;BY AUPN DEVELOPER
+17 ;S BARITYP=$$GET1^DIQ(90050.02,BARACT,1.08)
+18 ;I BARITYP["NON-BENEFICIARY" Q ;Don't write off non-bens
+19 ;BAR*1.8*2
SET D0=BARACT
+20 ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'
SET BARITYP=$$VALI^BARVPM(8)
+21 ;NON-BEN CODE
IF BARITYP="N"
QUIT
+22 ;
+23 ; Don't want 0 or credit bal
IF BARBAL'>0
Begin DoDot:1
+24 SET ^BARTMP("BARAWO",BARDUZ,DT,DUZ,"CREDIT",BARBL2)=""
End DoDot:1
QUIT
+25 ; May only write-off $20,000
IF BARAMT>20000
Begin DoDot:1
+26 SET ^BARTMP("BARAWO",BARDUZ,DT,DUZ,"TOO HIGH",BARBL2)=""
End DoDot:1
QUIT
+27 ;I $P(BAR(1),U,2)>(DT-30000) D Q
+28 ;. S ^BARTMP("BARAWO2",BARDUZ,DT,DUZ,"DATE",BARBL2)=""
+29 ;BAR*1.8*1 UFMS. IF EXP DATE TO USE OPTION IS 4/30/2007 THIS IS A UFMS WRITEOFF
+30 ;AND THERE IS NO DATE LIMIT PAST 3 YEARS ON DOS
+31 ;I BAREXP'=3070430 D Q
+32 IF BAREXP'=3070525
Begin DoDot:1
+33 IF $PIECE(BAR(1),U,2)>(DT-30000)
Begin DoDot:2
+34 SET ^BARTMP("BARAWO2",BARDUZ,DT,DUZ,"DATE",BARBL2)=""
End DoDot:2
End DoDot:1
QUIT
+35 SET DUZ(2)=BARDUZ
+36 ; Create new transaction
SET BARTRIEN=$$NEW^BARTR
+37 IF BARTRIEN<1
DO MSG^BARTR(BARBL2)
QUIT
+38 SET DA=BARTRIEN
+39 SET DIE=90050.03
+40 ; Credit ($$$)
SET DR="2////^S X=BARBAL"
+41 ; A/R Bill
SET DR=DR_";4////^S X=BARBL2"
+42 ; A/R Patient
SET DR=DR_";5////^S X=$P(BAR(1),U)"
+43 ; A/R Account
SET DR=DR_";6////^S X=$P(BAR(0),U,3)"
+44 ; Parent Location
SET DR=DR_";8////^S X=DUZ(2)"
+45 ; Parent ASUFAC
SET DR=DR_";9////^S X=DUZ(2)"
+46 ; A/R Section
SET DR=DR_";10////^S X=BARSECT"
+47 ; Visit location
SET DR=DR_";11////^S X=$P(BAR(1),U,8)"
+48 ; Date
SET DR=DR_";12////^S X=DT"
+49 ; A/R Entry by
SET DR=DR_";13////^S X=DUZ"
+50 ; Transaction type (Adj)
SET DR=DR_";101////43"
+51 ; Adj Category (Write off)
SET DR=DR_";102////3"
+52 ; Adj Type (Auto write off)
SET DR=DR_";103////916"
+53 SET DIDEL=90050
+54 ; Populate transaction file
DO ^DIE
+55 KILL DIDEL,DIE,DA,DR
+56 ; Post from Trans to files
DO TR^BARTDO(BARTRIEN)
+57 KILL BARBL
+58 SET BARCNT=BARCNT+1
+59 WRITE !,$PIECE(BAR(0),U),?25," for ",$JUSTIFY($FNUMBER(BARBAL,",",2),10)," written off."
+60 ; Roll info to 3PB
DO ROLLBILL
+61 QUIT
+62 ; *********************************************************************
ROLLBILL ;
+1 ; For bills written off, update Payment multiple in 3P and mark bill
+2 ; complete in 3PB. Also mark bill as rolled in A/R
+3 SET BARBLDA=BARBL2
+4 ; Set A/R vars to roll to 3PB
DO SETVAR^BARROLL
+5 ;BAR*1.8*1 UFMS WRITE-OFF
SET ROLL=0
+6 DO ROLL
+7 ;BAR*1.8*1 UFMS WRITE-OFF
IF 'ROLL
QUIT
+8 ; Mark bill as rolled
DO SETBLRL^BARROLL
+9 QUIT
+10 ; *********************************************************************
ROLL ;EP
+1 ; Changed code NHA-0601-180049 V1.6 Patch 4
+2 ; Roll A/R vars to 3PB
+3 KILL DIE,DA,DR
+4 SET BAR("3P BILL LOC")=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
+5 SET DUZO2=DUZ(2)
+6 SET DUZ(2)=$PIECE(BAR("3P BILL LOC"),",")
+7 SET Y=$PIECE(BAR("3P BILL LOC"),",",2)
+8 ;BEGIN ;IF CAN'T FIND 3P BILL INFO SKIP ROLL OVER BAR*1.8*1
+9 IF DUZ(2)=""!(Y="")
SET ROLL=0
SET DUZ(2)=DUZO2
QUIT
+10 SET ROLL=1
+11 ;END
+12 SET Y=Y_"^"_DUZ(2)
+13 SET DIC=$$DIC^XBDIQ1(9002274.4)
+14 SET BARGBL=DIC_+Y_")"
+15 ; Roll to 3PB
IF $DATA(@BARGBL)
DO ROLLTPB
+16 SET DUZ(2)=DUZO2
+17 QUIT
+18 ; *********************************************************************
ROLLTPB ;
+1 ; File A/R data in payment mult of 3PB
+2 MERGE ABM=BARSUM
+3 SET X=Y
+4 ;S Z=BAR3PNM ;IM18173 BAR*1.8*1
+5 ; IEN to 3PB BILL
SET ABMP("BDFN")=+X
+6 ; Bill #
SET ABMP("BILL")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",1)
+7 ;BEGIN IM18173
+8 ;I '$D(Z) D ; Z UNDEF IFF rtn called by A/R 1.0
+9 ;. S ABMP("AR1.0")=""
+10 ;. S Y=ABM
+11 ;. K ABM
+12 ;. S ABM("AMT")=Y
+13 ;I $G(Z)]"",ABMP("BILL")'=Z D LKUP^ABMAROLL
+14 ;END IM18173
+15 IF 'ABMP("BDFN")
QUIT
+16 ; File A/R data in payment multiple of 3P BILL and complete bill
+17 DO FILE^ABMAROLL
+18 QUIT
