BZSMAWO2 ; IHS/TAO/EDE - WRITE OFF OLD BILLS [ 05/23/2003 7:42 PM ]
;;1.0;TUCSON AREA OFFICE W/O;;MAR 14, 2003
;
; This routine does the actual write off of bills based on
; the criteria setup by the calling routine.
;
START ; WRITE OFF BILLS
S BZSDDSV=^DD(9002274.4,3,0) ; save payment mult dd entry
S ^DD(9002274.4,3,0)="PAYMENT^9002274.403DA^^3;0" ;set to don't ask
D LOOPDUZ
S ^DD(9002274.4,3,0)=BZSDDSV ; restore to orig
D EN^XBVK("BAR"),EN^XBVK("AMB")
Q
;
;--------------------
LOOPDUZ ; LOOP THRU A/R BILLS BY DUZ(2)
S BZSDUZ=0
F S BZSDUZ=$O(^BARBL(BZSDUZ)) Q:'+BZSDUZ D LOOPDT
Q
;
;--------------------
LOOPDT ; LOOP THRU A/R BILLS BY DATE OF SERVICE
S BZSVISIT=0
F S BZSVISIT=$O(^BARBL(BZSDUZ,"E",BZSVISIT)) Q:'+BZSVISIT D
. Q:BZSVISIT>BZSEDOS ; skip dos after end of tf
. Q:BZSVISIT<BZSBDOS ; skip dos before beginning of tf
. D LOOPBIL
. Q
Q
;
;--------------------
LOOPBIL ; LOOP THRU A/R BILLS FOR SINGLE DATE OF SERVICE
S BZSBL2=0
F S BZSBL2=$O(^BARBL(BZSDUZ,"E",BZSVISIT,BZSBL2)) Q:'+BZSBL2 D WRITEOFF
Q
;
;--------------------
WRITEOFF ; WRITE OFF BILLS THAT MEET CRITERIA
Q:'$D(^BARBL(BZSDUZ,BZSBL2)) ; No bill data
S BZS(0)=$G(^BARBL(BZSDUZ,BZSBL2,0)) ; A/R Bill 0 node
S BZS(1)=$G(^BARBL(BZSDUZ,BZSBL2,1)) ; A/R Bill 0 node
S BZSBAL=$P(BZS(0),U,15) ; Bill Balance
S BZSAMT=$P(BZS(0),U,13) ; Billed Amount
S BZSVSTL=$P(BZS(1),U,8) ; Visit location
; Q if A/R account is not on bill
Q:$P(BZS(0),U,3)=""
; Q if visit location not in list
;I $D(BZS("LOC")),'$D(BZS("LOC",BZSVSTL)) Q
; Q if A/R account not in list
I $D(BZS("ACCT")),'$D(BZS("ACCT",$P(BZS(0),U,3))) Q
S BZSACT=$P(BZS(0),U,3) ;A/R Account
S BZSITYP=$$GET1^DIQ(90050.02,BZSACT,1.08)
I BZSBAL'>0 D Q ; Don't want 0 or credit bal
. S ^BZSTMP("BZSAWO",BZSDUZ,DT,DUZ,"CREDIT",BZSBL2)=""
I BZSAMT>20000 D Q ; May only write-off $20,000
. S ^BZSTMP("BZSAWO",BZSDUZ,DT,DUZ,"TOO HIGH",BZSBL2)=""
S DUZ(2)=BZSDUZ
S BZSTRIEN=$$NEW^BARTR ; Create new transaction
S DA=BZSTRIEN
S DIE=90050.03
S DR="2////^S X=BZSBAL" ; Credit ($$$)
S DR=DR_";4////^S X=BZSBL2" ; A/R Bill
S DR=DR_";5////^S X=$P(BZS(1),U)" ; A/R Patient
S DR=DR_";6////^S X=$P(BZS(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=BZSSECT" ; A/R Section
S DR=DR_";11////^S X=$P(BZS(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////1003" ; Adj Type (Auto write off)
S DIDEL=90050
D ^DIE ; Populate transaction file
K DIDEL,DIE,DA,DR
D TR^BARTDO(BZSTRIEN) ; Post from Trans to files
K BZSBL
S BZSCNT=BZSCNT+1
W !,$P(BZS(0),U),?25," for ",$J($FN(BZSBAL,",",2),10)," written off."
S ^BZSTMP("BZSAWO",DT,DUZ,"DONE",BZSBL2)=$P(BZS(0),U)_U_BZSBAL
D ROLLBILL ; Roll info to 3PB
Q
;
;--------------------
ROLLBILL ; UPDATE PAYMENT MULTIPLE IN 3P, MARK COMPLETE AND ROLLED
; 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=BZSBL2
K BARBL
D SETVAR^BARROLL ; Set A/R vars to roll to 3PB
D ROLL
D SETBLRL^BARROLL ; Mark bill as rolled
Q
;
;--------------------
ROLL ; ROLL A/R VARS TO 3PB
K DIE,DA,DR
S BZS3PNM=BARBL(.01)
S:(BZS3PNM["-") BZS3PNM=$P(BZS3PNM,"-")
S BZS3PDA=BARBL(17)
Q:BZS3PDA'>0
S Y=+BZS3PDA
S DIC=$$DIC^XBDIQ1(9002274.4)
S DUZO2=DUZ(2)
I DIC["DUZ(2)" S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,8)
S:'$D(^ABMDBILL(DUZ(2),"B",BZS3PNM)) DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,8)
S Y=Y_"^"_DUZ(2)
S BZSGBL=DIC_+Y_")"
I $D(@BZSGBL) D ROLLTPB ; Roll to 3PB
S DUZ(2)=DUZO2
Q
;
;--------------------
ROLLTPB ; FILE A/R DATA IN PAYMENT MULTIPLE OF 3PB
M ABM=BARSUM
S X=Y
S ABMP("BDFN")=+X ; IEN to 3PB BILL
S ABMP("BILL")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",1) ; Bill #
I ABMP("BILL")'=BZS3PNM D LKUP^ABMAROLL
I 'ABMP("BDFN") Q
; File A/R data in payment multiple of 3P BILL and complete bill
D FILE^ABMAROLL
Q
BZSMAWO2 ; IHS/TAO/EDE - WRITE OFF OLD BILLS [ 05/23/2003 7:42 PM ]
+1 ;;1.0;TUCSON AREA OFFICE W/O;;MAR 14, 2003
+2 ;
+3 ; This routine does the actual write off of bills based on
+4 ; the criteria setup by the calling routine.
+5 ;
START ; WRITE OFF BILLS
+1 ; save payment mult dd entry
SET BZSDDSV=^DD(9002274.4,3,0)
+2 ;set to don't ask
SET ^DD(9002274.4,3,0)="PAYMENT^9002274.403DA^^3;0"
+3 DO LOOPDUZ
+4 ; restore to orig
SET ^DD(9002274.4,3,0)=BZSDDSV
+5 DO EN^XBVK("BAR")
DO EN^XBVK("AMB")
+6 QUIT
+7 ;
+8 ;--------------------
LOOPDUZ ; LOOP THRU A/R BILLS BY DUZ(2)
+1 SET BZSDUZ=0
+2 FOR
SET BZSDUZ=$ORDER(^BARBL(BZSDUZ))
IF '+BZSDUZ
QUIT
DO LOOPDT
+3 QUIT
+4 ;
+5 ;--------------------
LOOPDT ; LOOP THRU A/R BILLS BY DATE OF SERVICE
+1 SET BZSVISIT=0
+2 FOR
SET BZSVISIT=$ORDER(^BARBL(BZSDUZ,"E",BZSVISIT))
IF '+BZSVISIT
QUIT
Begin DoDot:1
+3 ; skip dos after end of tf
IF BZSVISIT>BZSEDOS
QUIT
+4 ; skip dos before beginning of tf
IF BZSVISIT<BZSBDOS
QUIT
+5 DO LOOPBIL
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
+9 ;--------------------
LOOPBIL ; LOOP THRU A/R BILLS FOR SINGLE DATE OF SERVICE
+1 SET BZSBL2=0
+2 FOR
SET BZSBL2=$ORDER(^BARBL(BZSDUZ,"E",BZSVISIT,BZSBL2))
IF '+BZSBL2
QUIT
DO WRITEOFF
+3 QUIT
+4 ;
+5 ;--------------------
WRITEOFF ; WRITE OFF BILLS THAT MEET CRITERIA
+1 ; No bill data
IF '$DATA(^BARBL(BZSDUZ,BZSBL2))
QUIT
+2 ; A/R Bill 0 node
SET BZS(0)=$GET(^BARBL(BZSDUZ,BZSBL2,0))
+3 ; A/R Bill 0 node
SET BZS(1)=$GET(^BARBL(BZSDUZ,BZSBL2,1))
+4 ; Bill Balance
SET BZSBAL=$PIECE(BZS(0),U,15)
+5 ; Billed Amount
SET BZSAMT=$PIECE(BZS(0),U,13)
+6 ; Visit location
SET BZSVSTL=$PIECE(BZS(1),U,8)
+7 ; Q if A/R account is not on bill
+8 IF $PIECE(BZS(0),U,3)=""
QUIT
+9 ; Q if visit location not in list
+10 ;I $D(BZS("LOC")),'$D(BZS("LOC",BZSVSTL)) Q
+11 ; Q if A/R account not in list
+12 IF $DATA(BZS("ACCT"))
IF '$DATA(BZS("ACCT",$PIECE(BZS(0),U,3)))
QUIT
+13 ;A/R Account
SET BZSACT=$PIECE(BZS(0),U,3)
+14 SET BZSITYP=$$GET1^DIQ(90050.02,BZSACT,1.08)
+15 ; Don't want 0 or credit bal
IF BZSBAL'>0
Begin DoDot:1
+16 SET ^BZSTMP("BZSAWO",BZSDUZ,DT,DUZ,"CREDIT",BZSBL2)=""
End DoDot:1
QUIT
+17 ; May only write-off $20,000
IF BZSAMT>20000
Begin DoDot:1
+18 SET ^BZSTMP("BZSAWO",BZSDUZ,DT,DUZ,"TOO HIGH",BZSBL2)=""
End DoDot:1
QUIT
+19 SET DUZ(2)=BZSDUZ
+20 ; Create new transaction
SET BZSTRIEN=$$NEW^BARTR
+21 SET DA=BZSTRIEN
+22 SET DIE=90050.03
+23 ; Credit ($$$)
SET DR="2////^S X=BZSBAL"
+24 ; A/R Bill
SET DR=DR_";4////^S X=BZSBL2"
+25 ; A/R Patient
SET DR=DR_";5////^S X=$P(BZS(1),U)"
+26 ; A/R Account
SET DR=DR_";6////^S X=$P(BZS(0),U,3)"
+27 ; Parent Location
SET DR=DR_";8////^S X=DUZ(2)"
+28 ; Parent ASUFAC
SET DR=DR_";9////^S X=DUZ(2)"
+29 ; A/R Section
SET DR=DR_";10////^S X=BZSSECT"
+30 ; Visit location
SET DR=DR_";11////^S X=$P(BZS(1),U,8)"
+31 ; Date
SET DR=DR_";12////^S X=DT"
+32 ; A/R Entry by
SET DR=DR_";13////^S X=DUZ"
+33 ; Transaction type (Adj)
SET DR=DR_";101////43"
+34 ; Adj Category (Write off)
SET DR=DR_";102////3"
+35 ; Adj Type (Auto write off)
SET DR=DR_";103////1003"
+36 SET DIDEL=90050
+37 ; Populate transaction file
DO ^DIE
+38 KILL DIDEL,DIE,DA,DR
+39 ; Post from Trans to files
DO TR^BARTDO(BZSTRIEN)
+40 KILL BZSBL
+41 SET BZSCNT=BZSCNT+1
+42 WRITE !,$PIECE(BZS(0),U),?25," for ",$JUSTIFY($FNUMBER(BZSBAL,",",2),10)," written off."
+43 SET ^BZSTMP("BZSAWO",DT,DUZ,"DONE",BZSBL2)=$PIECE(BZS(0),U)_U_BZSBAL
+44 ; Roll info to 3PB
DO ROLLBILL
+45 QUIT
+46 ;
+47 ;--------------------
ROLLBILL ; UPDATE PAYMENT MULTIPLE IN 3P, MARK COMPLETE AND ROLLED
+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=BZSBL2
+4 KILL BARBL
+5 ; Set A/R vars to roll to 3PB
DO SETVAR^BARROLL
+6 DO ROLL
+7 ; Mark bill as rolled
DO SETBLRL^BARROLL
+8 QUIT
+9 ;
+10 ;--------------------
ROLL ; ROLL A/R VARS TO 3PB
+1 KILL DIE,DA,DR
+2 SET BZS3PNM=BARBL(.01)
+3 IF (BZS3PNM["-")
SET BZS3PNM=$PIECE(BZS3PNM,"-")
+4 SET BZS3PDA=BARBL(17)
+5 IF BZS3PDA'>0
QUIT
+6 SET Y=+BZS3PDA
+7 SET DIC=$$DIC^XBDIQ1(9002274.4)
+8 SET DUZO2=DUZ(2)
+9 IF DIC["DUZ(2)"
SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U,8)
+10 IF '$DATA(^ABMDBILL(DUZ(2),"B",BZS3PNM))
SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U,8)
+11 SET Y=Y_"^"_DUZ(2)
+12 SET BZSGBL=DIC_+Y_")"
+13 ; Roll to 3PB
IF $DATA(@BZSGBL)
DO ROLLTPB
+14 SET DUZ(2)=DUZO2
+15 QUIT
+16 ;
+17 ;--------------------
ROLLTPB ; FILE A/R DATA IN PAYMENT MULTIPLE OF 3PB
+1 MERGE ABM=BARSUM
+2 SET X=Y
+3 ; IEN to 3PB BILL
SET ABMP("BDFN")=+X
+4 ; Bill #
SET ABMP("BILL")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",1)
+5 IF ABMP("BILL")'=BZS3PNM
DO LKUP^ABMAROLL
+6 IF 'ABMP("BDFN")
QUIT
+7 ; File A/R data in payment multiple of 3P BILL and complete bill
+8 DO FILE^ABMAROLL
+9 QUIT
