BARPRMKP ; IHS/SD/LSL - Post Remark Codes ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,21**;OCT 26, 2005
;
; IHS/SD/LSL - 02/13/04 - V1.7 Patch 5
; Routine created. Post Remark Codes.
;
Q
; ********************************************************************
;
EN ; EP
D ^BARVKL0 ; kill namespace variables
S BARESIG="" ; BAR electronic signature flag
D SIG^XUSESIG Q:X1="" ; elec sig test - Q if fail
S BARESIG=1 ; passed elec sig test
S (BARDONE,BARCOL,BARITM)=0
I '$D(BARUSR) D INIT^BARUTL ; Initialize BAR environment
D BATCHITM ; Ask Collection Batch/Item
I '+BARCOL!'+BARITM D MSG ; Double check no batch/item
I +BARDONE D XIT Q
I +BARCOL,+BARITM,+$P(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2) D FAC
S BARBDONE=0
F D BILLS Q:+BARBDONE ; Ask bills and codes and post
D XIT
Q
;*********************************************************************
;
BATCHITM ;
; Ask Collection Batch and Item (not required)
D BATCH^BARFPST ; Ask Collection Batch
I +BARCOL D ITEM^BARFPST ; If batch, ask item
Q
; ********************************************************************
;
MSG ;
; If no batch/item, give user chance to select.
K DIR
S DIR("A")="A valid collection batch and item was not entered. Continue"
S DIR("B")="N"
S DIR(0)="Y"
D ^DIR
Q:+Y
;
K DIR
S DIR("A")="Do you want to enter a new collection batch and item"
S DIR("B")="Y"
S DIR(0)="Y"
I '+Y S BARDONE=1 Q
K BARCOL,BARITM
D BATCHITM
I '+BARCOL!'+BARITM S BARDONE=1
Q
; ********************************************************************
;
FAC ;
; I multiple EOB site parameter, do...
D FAC^BARFPST ;eob
I Y>0 D
. S BAREOB=+Y
. S BAREOB(0)=Y(0)
. D EBAL^BARPST(BAREOB)
Q
; ********************************************************************
;
BILLS ;
; Loop bills, select remark codes and post
D SELBILL
;Q:'+BARBL
Q:'+$G(BARBL) ;BAR*1.8*3
;Q:+BARBDONE
Q:+$G(BARBDONE) ;BAR*1.8*3
S BARRDONE=0
K BARMK
F D SELREM Q:+BARRDONE
Q:'$D(BARMK) ; No remark codes to post
D REVIEW ; Review selection
I '+BARANS D Q
. W !!,"Remark Codes not posted!"
. K DIR
. D EOP^BARUTL(1)
D POSTCD ; Post remark code
K DIR
D EOP^BARUTL(1)
Q
; ********************************************************************
;
SELBILL ; EP
; Ask user for bill
K BARFPASS,DIC,DD,D0,X,Y,BARZ
W $$EN^BARVDF("IOF")
W !
; IHS/SD/PKD 1.8*21 HEAT20490 4/6/11 Bypass checking for Open Session
;S BARFPASS=$$GETBIL^BARFPST3 ; Get bills by bill, patient, or DOS
S BARFPASS=$$GETBIL2^BARFPST3 ; Get bills by bill, patient, or DOS, skip OPEN status check
; end 1.8*21
I BARFPASS=0 S BARBDONE=1 Q ; No bill selected; End loop
S BARPASS=$P(BARFPASS,U,1,3) ; Patient^DOS Start^DOS End
; If no A/R Bill IEN
I '+$P(BARFPASS,U,4) D FINDBIL^BARFPST3
I '+$P(BARFPASS,U,4) Q ; bill not found - ask again
S BARBL=$P(BARFPASS,U,4)
Q
; ********************************************************************
;
SELREM ;
; Select Remark codes
W !
K DIC,DR,DA,Y,X
S DIC="^BARMKCD("
S DIC(0)="AEMQZ"
S DIC("A")="Select Remark Code: "
I $D(BARMK) S DIC("A")="Select Additional Remark Code: "
K DD,D0
D ^DIC
I +Y>0 S BARMK(+Y)="" Q
S BARRDONE=1
Q
; ********************************************************************
;
REVIEW ;
; Display stuff to post...
S $P(BARSTAR,"*",81)=""
D GETS^DIQ(90050.01,BARBL,".01;3;7.2;15;17.2;18;101:103;108","IE","BARDAT")
M BARDATA=BARDAT(90050.01,BARBL_",")
I '$D(BAREOB) S BAREOB=BARDATA(108,"I")
W $$EN^BARVDF("IOF")
W !?1,"BILL #: ",$E(BARDATA(.01,"E"),1,25)
W ?36,"DATE BILLED:",?50,BARDATA(18,"E")
W !,"PATIENT: ",$E(BARDATA(101,"E"),1,25)
W ?36,"AGE OF BILL:",?50,$J(BARDATA(7.2,"E"),5)," DAYS"
W !?2,"CHART: ",$P($G(^AUPNPAT(BARDATA(101,"I"),41,BAREOB,0)),U,2)
W ?36,"BILL STATUS:",?50,BARDATA(17.2,"E")
W !!?4,"DOS: ",BARDATA(102,"E")
W ?39,"A/R ACCT:",?50,$E(BARDATA(3,"E"),1,30)
I BARDATA(102,"I")'=BARDATA(103,"I") W !?5,"TO: ",BARDATA(103,"E")
W !,BARSTAR
S I=0
F S I=$O(BARMK(I)) Q:'+I D
. S BARMK(I)=$G(^BARMKCD(I,0))
. W !,$P(BARMK(I),U)
. W !,$P(BARMK(I),U,2),!
W BARSTAR
K DIR
S DIR(0)="Y"
S DIR("A")="Post these remark codes to this bill"
S DIR("B")="Y"
D ^DIR
S BARANS=+Y
Q
; ********************************************************************
;
POSTCD ;
K BARDR
; Post selected remark codes to selected bill.
S BARDR="4////^S X=BARBL" ; A/R Bill
S BARDR=BARDR_";5////^S X=BARDATA(101,""I"")" ; A/R Patient
S BARDR=BARDR_";6////^S X=BARDATA(3,""I"")" ; A/R Account
S BARDR=BARDR_";8////^S X=DUZ(2)" ; Parent Location
S BARDR=BARDR_";9////^S X=DUZ(2)" ; Parent ASUFAC
; Force A/R section to Business Office
S BARDR=BARDR_";10////8" ; A/R Section
S BARDR=BARDR_";11////^S X=BAREOB" ; Visit Location
S BARDR=BARDR_";12////^S X=DT" ; Date
S BARDR=BARDR_";13////^S X=DUZ" ; Entry by
S BARDR=BARDR_";101////505" ; Tran Type = Remark Code
S BARDR=BARDR_";107////^S X=BARMKCD"
I +BARCOL,+BARITM D ; If collection batch/item
. S BARDR=BARDR_";14////^S X=BARCOL"
. S BARDR=BARDR_";15////^S X=BARITM"
;
S DIE=90050.03
S DIDEL=90050
S BARMKCD=0
W !
F S BARMKCD=$O(BARMK(BARMKCD)) Q:'+BARMKCD D
. K DR,DA
. W !,"Posting Remark Code ",$$GET1^DIQ(90056.23,BARMKCD,.01)
. S BARTRIEN=$$NEW^BARTR ; Create New Transaction
. I +BARTRIEN<1 D MSG^BARTR(BARBL) Q
. ; Populate Transaction file
. S DA=BARTRIEN ; IEN to A/R TRANSACTION
. S DR=BARDR
. D ^DIE
K DIDEL,DIE,DA,DR,DIR
Q
; ********************************************************************
;
XIT ;
W $$EN^BARVDF("IOF")
D ^BARVKL0
Q
BARPRMKP ; IHS/SD/LSL - Post Remark Codes ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,21**;OCT 26, 2005
+2 ;
+3 ; IHS/SD/LSL - 02/13/04 - V1.7 Patch 5
+4 ; Routine created. Post Remark Codes.
+5 ;
+6 QUIT
+7 ; ********************************************************************
+8 ;
EN ; EP
+1 ; kill namespace variables
DO ^BARVKL0
+2 ; BAR electronic signature flag
SET BARESIG=""
+3 ; elec sig test - Q if fail
DO SIG^XUSESIG
IF X1=""
QUIT
+4 ; passed elec sig test
SET BARESIG=1
+5 SET (BARDONE,BARCOL,BARITM)=0
+6 ; Initialize BAR environment
IF '$DATA(BARUSR)
DO INIT^BARUTL
+7 ; Ask Collection Batch/Item
DO BATCHITM
+8 ; Double check no batch/item
IF '+BARCOL!'+BARITM
DO MSG
+9 IF +BARDONE
DO XIT
QUIT
+10 IF +BARCOL
IF +BARITM
IF +$PIECE(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2)
DO FAC
+11 SET BARBDONE=0
+12 ; Ask bills and codes and post
FOR
DO BILLS
IF +BARBDONE
QUIT
+13 DO XIT
+14 QUIT
+15 ;*********************************************************************
+16 ;
BATCHITM ;
+1 ; Ask Collection Batch and Item (not required)
+2 ; Ask Collection Batch
DO BATCH^BARFPST
+3 ; If batch, ask item
IF +BARCOL
DO ITEM^BARFPST
+4 QUIT
+5 ; ********************************************************************
+6 ;
MSG ;
+1 ; If no batch/item, give user chance to select.
+2 KILL DIR
+3 SET DIR("A")="A valid collection batch and item was not entered. Continue"
+4 SET DIR("B")="N"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 IF +Y
QUIT
+8 ;
+9 KILL DIR
+10 SET DIR("A")="Do you want to enter a new collection batch and item"
+11 SET DIR("B")="Y"
+12 SET DIR(0)="Y"
+13 IF '+Y
SET BARDONE=1
QUIT
+14 KILL BARCOL,BARITM
+15 DO BATCHITM
+16 IF '+BARCOL!'+BARITM
SET BARDONE=1
+17 QUIT
+18 ; ********************************************************************
+19 ;
FAC ;
+1 ; I multiple EOB site parameter, do...
+2 ;eob
DO FAC^BARFPST
+3 IF Y>0
Begin DoDot:1
+4 SET BAREOB=+Y
+5 SET BAREOB(0)=Y(0)
+6 DO EBAL^BARPST(BAREOB)
End DoDot:1
+7 QUIT
+8 ; ********************************************************************
+9 ;
BILLS ;
+1 ; Loop bills, select remark codes and post
+2 DO SELBILL
+3 ;Q:'+BARBL
+4 ;BAR*1.8*3
IF '+$GET(BARBL)
QUIT
+5 ;Q:+BARBDONE
+6 ;BAR*1.8*3
IF +$GET(BARBDONE)
QUIT
+7 SET BARRDONE=0
+8 KILL BARMK
+9 FOR
DO SELREM
IF +BARRDONE
QUIT
+10 ; No remark codes to post
IF '$DATA(BARMK)
QUIT
+11 ; Review selection
DO REVIEW
+12 IF '+BARANS
Begin DoDot:1
+13 WRITE !!,"Remark Codes not posted!"
+14 KILL DIR
+15 DO EOP^BARUTL(1)
End DoDot:1
QUIT
+16 ; Post remark code
DO POSTCD
+17 KILL DIR
+18 DO EOP^BARUTL(1)
+19 QUIT
+20 ; ********************************************************************
+21 ;
SELBILL ; EP
+1 ; Ask user for bill
+2 KILL BARFPASS,DIC,DD,D0,X,Y,BARZ
+3 WRITE $$EN^BARVDF("IOF")
+4 WRITE !
+5 ; IHS/SD/PKD 1.8*21 HEAT20490 4/6/11 Bypass checking for Open Session
+6 ;S BARFPASS=$$GETBIL^BARFPST3 ; Get bills by bill, patient, or DOS
+7 ; Get bills by bill, patient, or DOS, skip OPEN status check
SET BARFPASS=$$GETBIL2^BARFPST3
+8 ; end 1.8*21
+9 ; No bill selected; End loop
IF BARFPASS=0
SET BARBDONE=1
QUIT
+10 ; Patient^DOS Start^DOS End
SET BARPASS=$PIECE(BARFPASS,U,1,3)
+11 ; If no A/R Bill IEN
+12 IF '+$PIECE(BARFPASS,U,4)
DO FINDBIL^BARFPST3
+13 ; bill not found - ask again
IF '+$PIECE(BARFPASS,U,4)
QUIT
+14 SET BARBL=$PIECE(BARFPASS,U,4)
+15 QUIT
+16 ; ********************************************************************
+17 ;
SELREM ;
+1 ; Select Remark codes
+2 WRITE !
+3 KILL DIC,DR,DA,Y,X
+4 SET DIC="^BARMKCD("
+5 SET DIC(0)="AEMQZ"
+6 SET DIC("A")="Select Remark Code: "
+7 IF $DATA(BARMK)
SET DIC("A")="Select Additional Remark Code: "
+8 KILL DD,D0
+9 DO ^DIC
+10 IF +Y>0
SET BARMK(+Y)=""
QUIT
+11 SET BARRDONE=1
+12 QUIT
+13 ; ********************************************************************
+14 ;
REVIEW ;
+1 ; Display stuff to post...
+2 SET $PIECE(BARSTAR,"*",81)=""
+3 DO GETS^DIQ(90050.01,BARBL,".01;3;7.2;15;17.2;18;101:103;108","IE","BARDAT")
+4 MERGE BARDATA=BARDAT(90050.01,BARBL_",")
+5 IF '$DATA(BAREOB)
SET BAREOB=BARDATA(108,"I")
+6 WRITE $$EN^BARVDF("IOF")
+7 WRITE !?1,"BILL #: ",$EXTRACT(BARDATA(.01,"E"),1,25)
+8 WRITE ?36,"DATE BILLED:",?50,BARDATA(18,"E")
+9 WRITE !,"PATIENT: ",$EXTRACT(BARDATA(101,"E"),1,25)
+10 WRITE ?36,"AGE OF BILL:",?50,$JUSTIFY(BARDATA(7.2,"E"),5)," DAYS"
+11 WRITE !?2,"CHART: ",$PIECE($GET(^AUPNPAT(BARDATA(101,"I"),41,BAREOB,0)),U,2)
+12 WRITE ?36,"BILL STATUS:",?50,BARDATA(17.2,"E")
+13 WRITE !!?4,"DOS: ",BARDATA(102,"E")
+14 WRITE ?39,"A/R ACCT:",?50,$EXTRACT(BARDATA(3,"E"),1,30)
+15 IF BARDATA(102,"I")'=BARDATA(103,"I")
WRITE !?5,"TO: ",BARDATA(103,"E")
+16 WRITE !,BARSTAR
+17 SET I=0
+18 FOR
SET I=$ORDER(BARMK(I))
IF '+I
QUIT
Begin DoDot:1
+19 SET BARMK(I)=$GET(^BARMKCD(I,0))
+20 WRITE !,$PIECE(BARMK(I),U)
+21 WRITE !,$PIECE(BARMK(I),U,2),!
End DoDot:1
+22 WRITE BARSTAR
+23 KILL DIR
+24 SET DIR(0)="Y"
+25 SET DIR("A")="Post these remark codes to this bill"
+26 SET DIR("B")="Y"
+27 DO ^DIR
+28 SET BARANS=+Y
+29 QUIT
+30 ; ********************************************************************
+31 ;
POSTCD ;
+1 KILL BARDR
+2 ; Post selected remark codes to selected bill.
+3 ; A/R Bill
SET BARDR="4////^S X=BARBL"
+4 ; A/R Patient
SET BARDR=BARDR_";5////^S X=BARDATA(101,""I"")"
+5 ; A/R Account
SET BARDR=BARDR_";6////^S X=BARDATA(3,""I"")"
+6 ; Parent Location
SET BARDR=BARDR_";8////^S X=DUZ(2)"
+7 ; Parent ASUFAC
SET BARDR=BARDR_";9////^S X=DUZ(2)"
+8 ; Force A/R section to Business Office
+9 ; A/R Section
SET BARDR=BARDR_";10////8"
+10 ; Visit Location
SET BARDR=BARDR_";11////^S X=BAREOB"
+11 ; Date
SET BARDR=BARDR_";12////^S X=DT"
+12 ; Entry by
SET BARDR=BARDR_";13////^S X=DUZ"
+13 ; Tran Type = Remark Code
SET BARDR=BARDR_";101////505"
+14 SET BARDR=BARDR_";107////^S X=BARMKCD"
+15 ; If collection batch/item
IF +BARCOL
IF +BARITM
Begin DoDot:1
+16 SET BARDR=BARDR_";14////^S X=BARCOL"
+17 SET BARDR=BARDR_";15////^S X=BARITM"
End DoDot:1
+18 ;
+19 SET DIE=90050.03
+20 SET DIDEL=90050
+21 SET BARMKCD=0
+22 WRITE !
+23 FOR
SET BARMKCD=$ORDER(BARMK(BARMKCD))
IF '+BARMKCD
QUIT
Begin DoDot:1
+24 KILL DR,DA
+25 WRITE !,"Posting Remark Code ",$$GET1^DIQ(90056.23,BARMKCD,.01)
+26 ; Create New Transaction
SET BARTRIEN=$$NEW^BARTR
+27 IF +BARTRIEN<1
DO MSG^BARTR(BARBL)
QUIT
+28 ; Populate Transaction file
+29 ; IEN to A/R TRANSACTION
SET DA=BARTRIEN
+30 SET DR=BARDR
+31 DO ^DIE
End DoDot:1
+32 KILL DIDEL,DIE,DA,DR,DIR
+33 QUIT
+34 ; ********************************************************************
+35 ;
XIT ;
+1 WRITE $$EN^BARVDF("IOF")
+2 DO ^BARVKL0
+3 QUIT
