BARPUC ; IHS/SD/LSL - UN-ALLOCATED CASH JAN 16,1997 ; 01/26/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,7,9,10,17,21,23**;OCT 26, 2005
;MAR 2013 P.OTTIS ADDED NEW VA billing
; ********************************************
;
EN ;EP - Unallocated Posting
S BARESIG=""
D SIG^XUSESIG
Q:X1="" ;elec signature test
S BARESIG=1
D RAYGO^BARPST ;ROLLOVER QUESTION-
;
ENTRY ;
S REIMBURS=0 ;BAR*1.8*4 SCR? 2 REIMBURSEMENT MODE
S TRANSFER=0 ;BAR*1.8*4 UFMS SCR? TRANSFER MODE
D ^BARVKL0 ;KILL OFF BAR* VARIABLES
K ^TMP($J,"BARVL")
I '$D(BARUSR) D INIT^BARUTL ;INITIALIZE VARIABLES
W !!
;
GETTX ;
;** list open u/c transactions and get selection from user
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
K BARVL
K BARTX
S (BARCNT,BARTX)=0
S BARTT=$O(^BARTBL("B","UN-ALLOCATED",""))
F S BARTX=$O(^BARTR(DUZ(2),"AGL","O",BARTX)) Q:'BARTX D
. Q:$$GET1^DIQ(90050.03,BARTX,101,"I")'=BARTT
. Q:'$$CKDATE^BARPST($P(^BARTR(DUZ(2),BARTX,0),U,14),0,"COLLECTION") ;IGNORE OLD BATCHES;MRS;BAR*1.8*6 DD 4.2.4
. S ^TMP($J,"BARVL",BARTX)=""
I '$D(^TMP($J,"BARVL")) D G EXIT
. W *7,"No open UNALLOCATED CASH transactions on file!"
. D EOP^BARUTL(0)
;;; routine ^BARPTR finds g/l transactions and returns selected trx.
S BARTR=$$EN^BARPTR()
I +BARTR=0 G EXIT
;
LOADTX ;
; ** get u/c transaction detail
K BARTX
S DR="2;6;14;15;105"
S DA=+BARTR
S DIC="^BARTR(DUZ(2),"
S DIQ(0)="0I"
S DIQ="BARTX("
D ENP^XBDIQ1(DIC,DA,DR,DIQ,DIQ(0))
S BARCLV(17)=$$GET1^DIQ(90051.01,BARTX(14,"I"),17) ;A/R COLLECTION BATCH, BATCH POSTING BALANCE
S BARITV(19)=$$GET1^DIQ(90051.01,BARTX(15,"I")_","_BARTX(14,"I")_",",19) ;A/R COLLECTION BATCH,POSTABLE TOTAL
;
CHOOSE ;
D TOP^BARPTR
W ?3,$J(BARTX(2,"I"),8,2)
W ?15,$E(BARTX(6),1,30)
W ?47,BARTX(14),!
S BARPRTQ=0 ; PRINT COMMENTS ON LETTER VARIABLE PKD BAR 1.8.17
K DIR
S DIR(0)="SAO^1:Post to A/R Bill;2:Refund;3:Unbilled Reimb;4:Transfers;5:Add Item Message;6:Exit"
S DIR("A")="Action (1=Post to an A/R Bill, 2=Refund, 3=Unbilled Reimbursement, 4=Transfer to another facility, 5=Add Item Message, 6=Exit): " ;BAR*1.8*P17
I $$IHS^BARUFUT(DUZ(2)) D ;MRS:BAR*1.8*7 TO131 REQ_11
. ;;;I $$IHSERA^BARUFUT(DUZ(2)) D ;MRS:BAR*1.8*7 TO131 REQ_11
. S DIR(0)="SAO^1:Post to A/R Bill;2:Refund;3:Transfers;4:Add Item Message;5:Exit"
. S DIR("A")="Action (1=Post to an A/R Bill, 2=Refund, 3=Transfer to another facility, 4=Add Item Message, 5=Exit): " ;BAR*1.8*P17
D ^DIR
N STR
S STR=$P($E($P(DIR("A"),Y,2),2,99),",") ; Get the Action Choice
I $D(DIRUT) G ENTRY
I Y=1 G GETBILL
I Y=2 D REFUND G ENTRY
I STR["Unbilled Reimb" D REIMBURS S REIMBURS=1 G ENTRY
I STR["Transfer" D TRANSFER G ENTRY
I STR["Item Message" D ITMSG^BARPUC2 G ENTRY ; Adding Item Msg per Adrian
G EXIT
;--------------------------------
;
GETBILL ;
S BARPASS=$$EN^BARPST1()
I +BARPASS=0 G EXIT
S BARCNT=$$EN^BARPUC2(BARPASS)
I +BARCNT=0 W *7,!!,"No bills in this date range!",!! G EN
D EN^BARPUC3
G ENTRY
;
EXIT ;
K ^TMP($J,"BARVL")
D ^BARVKL0
Q
;
REFUND ;
N BARAMT,BARAC,BARTT
;
AMT ;
S BARDEF=BARTX(2)
W !!!,"Refund Amount: "
W $J(BARDEF,0,2)_"// "
R X:DTIME
I X="" S X=+BARDEF
S X=$$AMT^BARPUCU(X,0,BARDEF)
I X="^" Q
I X="?" W *7," Must be a valid number!" G AMT
S BARAMT=X
;
REFTO ;
S DIC="^BARAC(DUZ(2),"
S DIC(0)="AEMQ"
S DIC("B")=BARTX(6)
S DIC("A")="A/R Account: "
S DIC("S")="I $P(^(0),U)'[(""AUTTLOC"")" ;BAR*1.8*3 UFMS
K DD,DO
D ^DIC
K DIC
I +Y<0 G AMT
S BARAC=+Y
;
REFPST ;** post refund
N DIC,DR,DA
S BARTT=39
; correct posting of refunds
S BARCAT=19
S (BARATYP,BARX,BARJ)=0
F S BARX=$O(^BARTBL("D",BARCAT,BARX)) Q:'BARX D Q:BARJ>1
.S BARJ=BARJ+1
.Q:BARJ>1
.S BARATYP=BARX
S DIC=90052.02
S DIC(0)="AEMNQZ"
S DIC("A")="Adjustment Type: "
S DIC("S")="I $P(^(0),U,2)=BARCAT,(Y<1000)" ;BAR*1.8*4 LATE REQUEST PER SANDRA 11/27/2007
K DD,DO
D ^DIC
K DIC
I +Y<0 D G AMT
. K BARAMT
. W *7,!!
S BARATYP=+Y
S NEWEXTYP=$P(Y,U,2)
S NEWTYP=$P(Y,U)
;
ASKREF ;EP - VERIFY ENTRY
N ASKREF
K DIR
S DIR("A",1)="You have entered "_BARAMT_" as a Refund to "_$$GET1^DIQ(90050.02,BARAC_",",.01,"E")_"." ;IHS/SD/TPF; BAR*1.8*6 IM30170
S DIR("A")="Would you like to Post this or Print the Finance Letter"
S DIR("B")="L"
S DIR(0)="SO^P:POST IT;L:PRINT FINANCE LETTER"
D ^DIR
I $D(DTOUT)!$D(DUOUT) G REFUND
S ASKREF=Y
S BARCHK=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",11,"E")
S BARSCHED=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")
I ASKREF="L" D Q ; If comments exist, give option to print BAR1.8*17 PKD 2/24/2010
. D PRTQ^BARPUC2 ; Question
. D LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,BARTX(6),"REFUND LETTER",NEWTYP_" "_NEWEXTYP) Q
W !!
K DIR
S DIR(0)="Y"
S DIR("B")="N"
S DIR("A")="ARE YOU SURE YOU WISH TO POST THIS NOW?"
D ^DIR
G:'Y!$D(DTOUT)!$D(DUOUT) ASKREF
K ASKREF
;CONTINMUE ON TO POST THE REFUND
;
REIMCONT ;EP - REIMBURSEMENT CONTINUED
TRANCONT ;EP - TRANSFER CONTINUED
S DR="3////^S X=BARAMT"
S DR=DR_";6////^S X=BARAC"
S DR=DR_";12////^S X=DT"
S DR=DR_";13////^S X=DUZ"
S DR=DR_";101////^S X=BARTT"
S:'REIMBURS&'(TRANSFER) DR=DR_";102///^S X=+BARCAT" ;BAR*1.8*4 UFMS SCR56
S:'REIMBURS&'(TRANSFER) DR=DR_";103///^S X=+BARATYP"
S DR=DR_";201////^S X=+BARTX(""ID"")"
S DR=DR_";14////^S X=BARTX(14,""I"")"
S DR=DR_";15////^S X=BARTX(15,""I"")"
S DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)"
;
PX ;
S X=$$NEW^BARTR
I X<1 D G:'REIMBURS&'(TRANSFER) REFUND Q
. W !!,"The system couldn't create a "_$S($G(REIMBURS):"REIMBURSEMENT",$G(TRANSFER):"TRANSFER",1:"REFUND")_" transaction. Please try again.",!
S DA=X
S DIE=90050.03
S DIDEL=90050
D ^DIE
K DIDEL
;
;** Update account
N BARUNAC
S BARUNAC=$$GET1^DIQ(90050.03,+BARTX("ID"),6,"I")
S BARTX(304)=$$GET1^DIQ(90050.02,BARUNAC,304,"I")
S DIE="^BARAC(DUZ(2),"
S DA=BARUNAC
S DR="304////^S X=BARTX(304)-BARAMT" ;UNALLOCATED
S DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)" ;A/R SERVICE
S DIDEL=90050
D ^DIE
K DIDEL
;
; UPDATE TRANSFER TO ACCOUNT
I $G(TRANSFER) D
.S TBARACAM=$$GET1^DIQ(90050.02,TBARAC_",",301,"I") ;A/R CURRENT BALANCE FOR TRANSFER TO ACCT
.S DIE="^BARAC(DUZ(2),"
.S DA=TBARAC
.S DR="301////^S X=TBARACAM+BARAMT" ;ADD THE TRANSFERRED AMOUNT
.S DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)"
.S DIDEL=90050
.D ^DIE
.K DIDEL
;
G:REIMBURS!(TRANSFER) FINISH ;IHS/SD/TPF BAR*1.8*3 UFMS SCR2
;
;** update collection batch
; Next 9 lines of code to post refund amount to a batch,
; if the transaction record has a batch/item number defined
I BARTX(14,"I")'>0 G FINISH
S DA=BARTX(15,"I") ;A/R COLLECTION ITEM
S DA(1)=BARTX(14,"I") ;A/R COLLECTION BATCH
S BARITRF=$$GET1^DIQ(90051.1101,.DA,106,"I")
S BARITRF=BARITRF+BARAMT
K DA,DIE,DIC,DR
S DIE=$$DIC^XBDIQ1(90051.1101)
S DA=BARTX(15,"I")
S DA(1)=BARTX(14,"I")
;THIS IS A COMPUTED FIELD OFF OF $$ITT^BARCBC I DON'T THINK THIS DOES
;ANYTHING
S DR="106////^S X=BARITRF" ;ITEM REFUNDED UNDER ITEM SUBFILE
S DIDEL=90050
D ^DIE
K DIDEL
;
FINISH ;
K DR,DIC
I (+BARTX(2,"I"))-(+BARAMT)'=0 D G CLOSE
. D ENP^XBDIQ1("^BARTR(DUZ(2),",+BARTX("ID"),"6;8;10;11;14;15;101;104;105","BARSIB(","0I")
. S BARREM=(+BARTX(2,"I"))-(+BARAMT)
. S DIC="^BARTR(DUZ(2),"
. S DIC(0)="L"
. S DLAYGO=90050
. L +^BARTR(DUZ(2)):2
. F D NOW^%DTC S X=% I '$D(^BARTR(DUZ(2),"B",X)) L -^BARTR(DUZ(2)) D ^DIC K DLAYGO Q
. S BARSIB=+Y
. I BARSIB<1 D G FINISH
. . W !,"Couldn't create a new UN-ALLOCATED transaction. The system is trying again.",!
. S DA=BARSIB
. S DIE="^BARTR(DUZ(2),"
. S DR="2////^S X=BARREM"
. S DR=DR_";12////^S X=DT"
. S DR=DR_";13////^S X=DUZ"
. S DR=DR_";201////^S X=+BARTX(""ID"")"
. S DR=DR_";6////^S X=BARSIB(6,""I"")"
. S DR=DR_";8////^S X=BARSIB(8,""I"")"
. S DR=DR_";10////^S X=BARSIB(10,""I"")"
. S DR=DR_";11////^S X=BARSIB(11,""I"")"
. S DR=DR_";14////^S X=BARSIB(14,""I"")"
. S DR=DR_";15////^S X=BARSIB(15,""I"")"
. S DR=DR_";101////^S X=BARSIB(101,""I"")"
. S DR=DR_";104////^S X=BARSIB(104,""I"")"
. S DR=DR_";105////^S X=BARSIB(105,""I"")"
. S DIDEL=90050
. D ^DIE
. K DIDEL
. S DIE="^BARTR(DUZ(2),"
. S DR="2////^S X=BARAMT"
. S DR=DR_";105////^S X=""R"""
. S DR=DR_";202////^S X=+BARSIB"
. S DA=+BARTX("ID")
. S DIDEL=90050
. D ^DIE
. K DIDEL
. Q
I (+BARTX(2,"I"))-(+BARAMT)=0 D
. S DIE="^BARTR(DUZ(2),"
. S DR="105////^S X=""R"""
. S DA=+BARTX("ID")
. S DIDEL=90050
. D ^DIE
. K DIDEL
;
CLOSE ;
K ^BARTMP($J)
K BARTX,BARREM,BARSIB,BARTR,BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV
Q
REIMBURS ;EP - PROCESS REIMBURSEMENTS
S REIMBURS=1 ;REIMBURSEMENT MODE
K DIR
S DIR(0)="NO^.01:"_$G(BARTX(2))_":2"
S DIR("A")="Unbilled Reimbursement Amount: "
S DIR("B")=$G(BARTX(2))
D ^DIR
Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)
I Y>BARTX(2) W !,"YOU CANNOT ENTER AN AMOUNT EXCEEDING THE UNALLOCATED AMOUNT!!" K DIR S DIR(0)="E" D ^DIR G REIMBURS
S NEWVALUE=Y
;
ASKTYP ;EP - ASK TYPE
K DIR,DIE,DIC,DR,DA,X
S DIC="^BARTBL("
S DIC(0)="AEQZ"
S DIC("A")="Unbilled Reimbursement Type: "
S DIC("S")="I $P(^(0),U,2)=23"
D ^DIC
G:Y<0 REIMBURS
S BARTT=+Y
S BARATYP=""
S BARCAT=""
S NEWTYP=+Y
S EXNEWTYP=$P(Y,U,2)
ASKVER ;EP - VERIFY ENTRY
N ASKVER
K DIR
S DIR("A",1)="You have entered "_NEWVALUE_" as an Unbilled Reimbursement to "_EXNEWTYP_"."
S DIR("A")="Would you like to Post this or Print the Finance Letter"
S DIR("B")="L"
S DIR(0)="SO^P:POST IT;L:PRINT FINANCE LETTER"
D ^DIR
I $D(DTOUT)!$D(DUOUT) K NEWTYP,EXNEWTYP,NEWVALUE G REIMBURS
S ASKVER=Y
S BARAMT=NEWVALUE
S BARSIB(101,"I")=NEWTYP
S BARAC=BARTX(6,"I")
S BARCHK=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",11,"E")
S BARSCHED=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")
;I ASKVER="L" D LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,BARTX(6),"UNBILLED REIMBURSEMENT LETTER") Q ;PRINT REIMBURSMENT LETTER
I ASKVER="L" D Q
. D PRTQ^BARPUC2 ; Question to print comments
. D LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,BARTX(6),"UNBILLED REIMBURSEMENT LETTER",NEWTYP_" "_EXNEWTYP) Q ;PRINT REIMBURSMENT LETTER ;BAR*1.8*4
W !!
K DIR
S DIR(0)="Y"
S DIR("B")="N"
S DIR("A")="ARE YOU SURE YOU WISH TO POST THIS NOW?"
D ^DIR
G:'Y!$D(DTOUT)!$D(DUOUT) ASKVER
D REIMCONT
K ASKVER
Q
;
TRANSFER ;EP - PROCESS TRANSFERS
S BARTT=560
S BARATYP=""
S BARCAT=""
S TRANSFER=1 ;TRANSFER MODE
K DIR
S DIR(0)="NO^.01:"_$G(BARTX(2))_":2"
S DIR("A")="Transfer Amount: "
S DIR("B")=$G(BARTX(2))
W !!
D ^DIR
Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)
I Y>BARTX(2) W !,"YOU CANNOT ENTER AN AMOUNT EXCEEDING THE UNALLOCATED AMOUNT!!" K DIR S DIR(0)="E" D ^DIR G TRANSFER
S NEWVALUE=Y
;
ASKACCT ;EP - TRANSFER TO WHAT A/R ACCOUNT
K DIR,DIC,DIE,DA,X
S DIC="^BARAC(DUZ(2),"
S DIC(0)="AMEZQ"
S DIC("S")="I $P(^(0),U)[(""AUTTLOC"")"
W !
D ^DIC
G:Y<0 TRANSFER
S TBARAC=$P($P(Y,U,2),";") ;TRANSFER TO ACCOUNT
S TEXBARAC=$$GET1^DIQ(9999999.06,TBARAC_",",.01,"E")
;
ASKVERT ;EP - VERIFY ENTRY
K DIR
N ASKVERT
S DIR("A",1)="You are transferring "_NEWVALUE_" to "_TEXBARAC_"."
S DIR("A")="Would you like to Post this or Print Finance Letter"
S DIR("B")="L"
S DIR(0)="SO^P:POST IT;L:PRINT FINANCE LETTER"
W !
D ^DIR
I $D(DTOUT)!$D(DUOUT) K NEWVALUE,EXBARAC G TRANSFER
S ASKVERT=Y
S BARAMT=NEWVALUE
S BARSIB(101,"I")=560
S BARAC=BARTX(6,"I")
S BARCHK=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",11,"E")
S BARSCHED=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")
I ASKVERT="L" D Q
. D PRTQ^BARPUC2 ; Question to print comments
. D LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,TEXBARAC,"TRANSFER LETTER") Q ;PRINT TRANSFER LETTER
W !!
K DIR
S DIR(0)="Y"
S DIR("B")="N"
S DIR("A")="ARE YOU SURE YOU WISH TO POST THIS NOW?"
D ^DIR
G:'Y!$D(DTOUT)!$D(DUOUT) ASKVERT
D REIMCONT
Q
; ********************************************************************
;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
;AND MAPS INSURER TYPE CODE TO CATEGORY (IE: W --> OTHER)
H ;;PRIVATE INSURANCE;;HMO
M ;;PRIVATE INSURANCE;;MEDICARE SUPPL.
D ;;MEDICAID;;MEDICAID FI
R ;;MEDICARE;;MEDICARE FI
P ;;PRIVATE INSURANCE;;PRIVATE INSURANCE
W ;;OTHER;;WORKMEN'S COMP
C ;;OTHER;;CHAMPUS
N ;;OTHER;;NON-BENEFICIARY (NON-INDIAN)
I ;;OTHER;;INDIAN PATIENT
K ;;MEDICAID;;CHIP (KIDSCARE)
T ;;OTHER;;THIRD PARTY LIABILITY
G ;;OTHER;;GUARANTOR
MD ;;MEDICARE;;MCR PART D
MH ;;MEDICARE;;MEDICARE HMO
MMC ;;MEDICARE;;MCR MANAGED CARE
TSI ;;OTHER;;TRIBAL SELF INSURED
SEP ;;OTHER;;STATE EXCHANGE PLAN
FPL ;;MEDICAID;;FPL 133 PERCENT
MC ;;MEDICARE;;MCR PART C
F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
V ;;VETERAN;;VETERANS MEDICAL BENEFITS
;;***END OF TABLE**
BARPUC ; IHS/SD/LSL - UN-ALLOCATED CASH JAN 16,1997 ; 01/26/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,7,9,10,17,21,23**;OCT 26, 2005
+2 ;MAR 2013 P.OTTIS ADDED NEW VA billing
+3 ; ********************************************
+4 ;
EN ;EP - Unallocated Posting
+1 SET BARESIG=""
+2 DO SIG^XUSESIG
+3 ;elec signature test
IF X1=""
QUIT
+4 SET BARESIG=1
+5 ;ROLLOVER QUESTION-
DO RAYGO^BARPST
+6 ;
ENTRY ;
+1 ;BAR*1.8*4 SCR? 2 REIMBURSEMENT MODE
SET REIMBURS=0
+2 ;BAR*1.8*4 UFMS SCR? TRANSFER MODE
SET TRANSFER=0
+3 ;KILL OFF BAR* VARIABLES
DO ^BARVKL0
+4 KILL ^TMP($JOB,"BARVL")
+5 ;INITIALIZE VARIABLES
IF '$DATA(BARUSR)
DO INIT^BARUTL
+6 WRITE !!
+7 ;
GETTX ;
+1 ;** list open u/c transactions and get selection from user
+2 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+3 KILL BARVL
+4 KILL BARTX
+5 SET (BARCNT,BARTX)=0
+6 SET BARTT=$ORDER(^BARTBL("B","UN-ALLOCATED",""))
+7 FOR
SET BARTX=$ORDER(^BARTR(DUZ(2),"AGL","O",BARTX))
IF 'BARTX
QUIT
Begin DoDot:1
+8 IF $$GET1^DIQ(90050.03,BARTX,101,"I")'=BARTT
QUIT
+9 ;IGNORE OLD BATCHES;MRS;BAR*1.8*6 DD 4.2.4
IF '$$CKDATE^BARPST($PIECE(^BARTR(DUZ(2),BARTX,0),U,14),0,"COLLECTION")
QUIT
+10 SET ^TMP($JOB,"BARVL",BARTX)=""
End DoDot:1
+11 IF '$DATA(^TMP($JOB,"BARVL"))
Begin DoDot:1
+12 WRITE *7,"No open UNALLOCATED CASH transactions on file!"
+13 DO EOP^BARUTL(0)
End DoDot:1
GOTO EXIT
+14 ;;; routine ^BARPTR finds g/l transactions and returns selected trx.
+15 SET BARTR=$$EN^BARPTR()
+16 IF +BARTR=0
GOTO EXIT
+17 ;
LOADTX ;
+1 ; ** get u/c transaction detail
+2 KILL BARTX
+3 SET DR="2;6;14;15;105"
+4 SET DA=+BARTR
+5 SET DIC="^BARTR(DUZ(2),"
+6 SET DIQ(0)="0I"
+7 SET DIQ="BARTX("
+8 DO ENP^XBDIQ1(DIC,DA,DR,DIQ,DIQ(0))
+9 ;A/R COLLECTION BATCH, BATCH POSTING BALANCE
SET BARCLV(17)=$$GET1^DIQ(90051.01,BARTX(14,"I"),17)
+10 ;A/R COLLECTION BATCH,POSTABLE TOTAL
SET BARITV(19)=$$GET1^DIQ(90051.01,BARTX(15,"I")_","_BARTX(14,"I")_",",19)
+11 ;
CHOOSE ;
+1 DO TOP^BARPTR
+2 WRITE ?3,$JUSTIFY(BARTX(2,"I"),8,2)
+3 WRITE ?15,$EXTRACT(BARTX(6),1,30)
+4 WRITE ?47,BARTX(14),!
+5 ; PRINT COMMENTS ON LETTER VARIABLE PKD BAR 1.8.17
SET BARPRTQ=0
+6 KILL DIR
+7 SET DIR(0)="SAO^1:Post to A/R Bill;2:Refund;3:Unbilled Reimb;4:Transfers;5:Add Item Message;6:Exit"
+8 ;BAR*1.8*P17
SET DIR("A")="Action (1=Post to an A/R Bill, 2=Refund, 3=Unbilled Reimbursement, 4=Transfer to another facility, 5=Add Item Message, 6=Exit): "
+9 ;MRS:BAR*1.8*7 TO131 REQ_11
IF $$IHS^BARUFUT(DUZ(2))
Begin DoDot:1
+10 ;;;I $$IHSERA^BARUFUT(DUZ(2)) D ;MRS:BAR*1.8*7 TO131 REQ_11
+11 SET DIR(0)="SAO^1:Post to A/R Bill;2:Refund;3:Transfers;4:Add Item Message;5:Exit"
+12 ;BAR*1.8*P17
SET DIR("A")="Action (1=Post to an A/R Bill, 2=Refund, 3=Transfer to another facility, 4=Add Item Message, 5=Exit): "
End DoDot:1
+13 DO ^DIR
+14 NEW STR
+15 ; Get the Action Choice
SET STR=$PIECE($EXTRACT($PIECE(DIR("A"),Y,2),2,99),",")
+16 IF $DATA(DIRUT)
GOTO ENTRY
+17 IF Y=1
GOTO GETBILL
+18 IF Y=2
DO REFUND
GOTO ENTRY
+19 IF STR["Unbilled Reimb"
DO REIMBURS
SET REIMBURS=1
GOTO ENTRY
+20 IF STR["Transfer"
DO TRANSFER
GOTO ENTRY
+21 ; Adding Item Msg per Adrian
IF STR["Item Message"
DO ITMSG^BARPUC2
GOTO ENTRY
+22 GOTO EXIT
+23 ;--------------------------------
+24 ;
GETBILL ;
+1 SET BARPASS=$$EN^BARPST1()
+2 IF +BARPASS=0
GOTO EXIT
+3 SET BARCNT=$$EN^BARPUC2(BARPASS)
+4 IF +BARCNT=0
WRITE *7,!!,"No bills in this date range!",!!
GOTO EN
+5 DO EN^BARPUC3
+6 GOTO ENTRY
+7 ;
EXIT ;
+1 KILL ^TMP($JOB,"BARVL")
+2 DO ^BARVKL0
+3 QUIT
+4 ;
REFUND ;
+1 NEW BARAMT,BARAC,BARTT
+2 ;
AMT ;
+1 SET BARDEF=BARTX(2)
+2 WRITE !!!,"Refund Amount: "
+3 WRITE $JUSTIFY(BARDEF,0,2)_"// "
+4 READ X:DTIME
+5 IF X=""
SET X=+BARDEF
+6 SET X=$$AMT^BARPUCU(X,0,BARDEF)
+7 IF X="^"
QUIT
+8 IF X="?"
WRITE *7," Must be a valid number!"
GOTO AMT
+9 SET BARAMT=X
+10 ;
REFTO ;
+1 SET DIC="^BARAC(DUZ(2),"
+2 SET DIC(0)="AEMQ"
+3 SET DIC("B")=BARTX(6)
+4 SET DIC("A")="A/R Account: "
+5 ;BAR*1.8*3 UFMS
SET DIC("S")="I $P(^(0),U)'[(""AUTTLOC"")"
+6 KILL DD,DO
+7 DO ^DIC
+8 KILL DIC
+9 IF +Y<0
GOTO AMT
+10 SET BARAC=+Y
+11 ;
REFPST ;** post refund
+1 NEW DIC,DR,DA
+2 SET BARTT=39
+3 ; correct posting of refunds
+4 SET BARCAT=19
+5 SET (BARATYP,BARX,BARJ)=0
+6 FOR
SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
IF 'BARX
QUIT
Begin DoDot:1
+7 SET BARJ=BARJ+1
+8 IF BARJ>1
QUIT
+9 SET BARATYP=BARX
End DoDot:1
IF BARJ>1
QUIT
+10 SET DIC=90052.02
+11 SET DIC(0)="AEMNQZ"
+12 SET DIC("A")="Adjustment Type: "
+13 ;BAR*1.8*4 LATE REQUEST PER SANDRA 11/27/2007
SET DIC("S")="I $P(^(0),U,2)=BARCAT,(Y<1000)"
+14 KILL DD,DO
+15 DO ^DIC
+16 KILL DIC
+17 IF +Y<0
Begin DoDot:1
+18 KILL BARAMT
+19 WRITE *7,!!
End DoDot:1
GOTO AMT
+20 SET BARATYP=+Y
+21 SET NEWEXTYP=$PIECE(Y,U,2)
+22 SET NEWTYP=$PIECE(Y,U)
+23 ;
ASKREF ;EP - VERIFY ENTRY
+1 NEW ASKREF
+2 KILL DIR
+3 ;IHS/SD/TPF; BAR*1.8*6 IM30170
SET DIR("A",1)="You have entered "_BARAMT_" as a Refund to "_$$GET1^DIQ(90050.02,BARAC_",",.01,"E")_"."
+4 SET DIR("A")="Would you like to Post this or Print the Finance Letter"
+5 SET DIR("B")="L"
+6 SET DIR(0)="SO^P:POST IT;L:PRINT FINANCE LETTER"
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO REFUND
+9 SET ASKREF=Y
+10 SET BARCHK=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",11,"E")
+11 SET BARSCHED=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")
+12 ; If comments exist, give option to print BAR1.8*17 PKD 2/24/2010
IF ASKREF="L"
Begin DoDot:1
+13 ; Question
DO PRTQ^BARPUC2
+14 DO LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,BARTX(6),"REFUND LETTER",NEWTYP_" "_NEWEXTYP)
QUIT
End DoDot:1
QUIT
+15 WRITE !!
+16 KILL DIR
+17 SET DIR(0)="Y"
+18 SET DIR("B")="N"
+19 SET DIR("A")="ARE YOU SURE YOU WISH TO POST THIS NOW?"
+20 DO ^DIR
+21 IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
GOTO ASKREF
+22 KILL ASKREF
+23 ;CONTINMUE ON TO POST THE REFUND
+24 ;
REIMCONT ;EP - REIMBURSEMENT CONTINUED
TRANCONT ;EP - TRANSFER CONTINUED
+1 SET DR="3////^S X=BARAMT"
+2 SET DR=DR_";6////^S X=BARAC"
+3 SET DR=DR_";12////^S X=DT"
+4 SET DR=DR_";13////^S X=DUZ"
+5 SET DR=DR_";101////^S X=BARTT"
+6 ;BAR*1.8*4 UFMS SCR56
IF 'REIMBURS&'(TRANSFER)
SET DR=DR_";102///^S X=+BARCAT"
+7 IF 'REIMBURS&'(TRANSFER)
SET DR=DR_";103///^S X=+BARATYP"
+8 SET DR=DR_";201////^S X=+BARTX(""ID"")"
+9 SET DR=DR_";14////^S X=BARTX(14,""I"")"
+10 SET DR=DR_";15////^S X=BARTX(15,""I"")"
+11 SET DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)"
+12 ;
PX ;
+1 SET X=$$NEW^BARTR
+2 IF X<1
Begin DoDot:1
+3 WRITE !!,"The system couldn't create a "_$SELECT($GET(REIMBURS):"REIMBURSEMENT",$GET(TRANSFER):"TRANSFER",1:"REFUND")_" transaction. Please try again.",!
End DoDot:1
IF 'REIMBURS&'(TRANSFER)
GOTO REFUND
QUIT
+4 SET DA=X
+5 SET DIE=90050.03
+6 SET DIDEL=90050
+7 DO ^DIE
+8 KILL DIDEL
+9 ;
+10 ;** Update account
+11 NEW BARUNAC
+12 SET BARUNAC=$$GET1^DIQ(90050.03,+BARTX("ID"),6,"I")
+13 SET BARTX(304)=$$GET1^DIQ(90050.02,BARUNAC,304,"I")
+14 SET DIE="^BARAC(DUZ(2),"
+15 SET DA=BARUNAC
+16 ;UNALLOCATED
SET DR="304////^S X=BARTX(304)-BARAMT"
+17 ;A/R SERVICE
SET DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)"
+18 SET DIDEL=90050
+19 DO ^DIE
+20 KILL DIDEL
+21 ;
+22 ; UPDATE TRANSFER TO ACCOUNT
+23 IF $GET(TRANSFER)
Begin DoDot:1
+24 ;A/R CURRENT BALANCE FOR TRANSFER TO ACCT
SET TBARACAM=$$GET1^DIQ(90050.02,TBARAC_",",301,"I")
+25 SET DIE="^BARAC(DUZ(2),"
+26 SET DA=TBARAC
+27 ;ADD THE TRANSFERRED AMOUNT
SET DR="301////^S X=TBARACAM+BARAMT"
+28 SET DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)"
+29 SET DIDEL=90050
+30 DO ^DIE
+31 KILL DIDEL
End DoDot:1
+32 ;
+33 ;IHS/SD/TPF BAR*1.8*3 UFMS SCR2
IF REIMBURS!(TRANSFER)
GOTO FINISH
+34 ;
+35 ;** update collection batch
+36 ; Next 9 lines of code to post refund amount to a batch,
+37 ; if the transaction record has a batch/item number defined
+38 IF BARTX(14,"I")'>0
GOTO FINISH
+39 ;A/R COLLECTION ITEM
SET DA=BARTX(15,"I")
+40 ;A/R COLLECTION BATCH
SET DA(1)=BARTX(14,"I")
+41 SET BARITRF=$$GET1^DIQ(90051.1101,.DA,106,"I")
+42 SET BARITRF=BARITRF+BARAMT
+43 KILL DA,DIE,DIC,DR
+44 SET DIE=$$DIC^XBDIQ1(90051.1101)
+45 SET DA=BARTX(15,"I")
+46 SET DA(1)=BARTX(14,"I")
+47 ;THIS IS A COMPUTED FIELD OFF OF $$ITT^BARCBC I DON'T THINK THIS DOES
+48 ;ANYTHING
+49 ;ITEM REFUNDED UNDER ITEM SUBFILE
SET DR="106////^S X=BARITRF"
+50 SET DIDEL=90050
+51 DO ^DIE
+52 KILL DIDEL
+53 ;
FINISH ;
+1 KILL DR,DIC
+2 IF (+BARTX(2,"I"))-(+BARAMT)'=0
Begin DoDot:1
+3 DO ENP^XBDIQ1("^BARTR(DUZ(2),",+BARTX("ID"),"6;8;10;11;14;15;101;104;105","BARSIB(","0I")
+4 SET BARREM=(+BARTX(2,"I"))-(+BARAMT)
+5 SET DIC="^BARTR(DUZ(2),"
+6 SET DIC(0)="L"
+7 SET DLAYGO=90050
+8 LOCK +^BARTR(DUZ(2)):2
+9 FOR
DO NOW^%DTC
SET X=%
IF '$DATA(^BARTR(DUZ(2),"B",X))
LOCK -^BARTR(DUZ(2))
DO ^DIC
KILL DLAYGO
QUIT
+10 SET BARSIB=+Y
+11 IF BARSIB<1
Begin DoDot:2
+12 WRITE !,"Couldn't create a new UN-ALLOCATED transaction. The system is trying again.",!
End DoDot:2
GOTO FINISH
+13 SET DA=BARSIB
+14 SET DIE="^BARTR(DUZ(2),"
+15 SET DR="2////^S X=BARREM"
+16 SET DR=DR_";12////^S X=DT"
+17 SET DR=DR_";13////^S X=DUZ"
+18 SET DR=DR_";201////^S X=+BARTX(""ID"")"
+19 SET DR=DR_";6////^S X=BARSIB(6,""I"")"
+20 SET DR=DR_";8////^S X=BARSIB(8,""I"")"
+21 SET DR=DR_";10////^S X=BARSIB(10,""I"")"
+22 SET DR=DR_";11////^S X=BARSIB(11,""I"")"
+23 SET DR=DR_";14////^S X=BARSIB(14,""I"")"
+24 SET DR=DR_";15////^S X=BARSIB(15,""I"")"
+25 SET DR=DR_";101////^S X=BARSIB(101,""I"")"
+26 SET DR=DR_";104////^S X=BARSIB(104,""I"")"
+27 SET DR=DR_";105////^S X=BARSIB(105,""I"")"
+28 SET DIDEL=90050
+29 DO ^DIE
+30 KILL DIDEL
+31 SET DIE="^BARTR(DUZ(2),"
+32 SET DR="2////^S X=BARAMT"
+33 SET DR=DR_";105////^S X=""R"""
+34 SET DR=DR_";202////^S X=+BARSIB"
+35 SET DA=+BARTX("ID")
+36 SET DIDEL=90050
+37 DO ^DIE
+38 KILL DIDEL
+39 QUIT
End DoDot:1
GOTO CLOSE
+40 IF (+BARTX(2,"I"))-(+BARAMT)=0
Begin DoDot:1
+41 SET DIE="^BARTR(DUZ(2),"
+42 SET DR="105////^S X=""R"""
+43 SET DA=+BARTX("ID")
+44 SET DIDEL=90050
+45 DO ^DIE
+46 KILL DIDEL
End DoDot:1
+47 ;
CLOSE ;
+1 KILL ^BARTMP($JOB)
+2 KILL BARTX,BARREM,BARSIB,BARTR,BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV
+3 QUIT
REIMBURS ;EP - PROCESS REIMBURSEMENTS
+1 ;REIMBURSEMENT MODE
SET REIMBURS=1
+2 KILL DIR
+3 SET DIR(0)="NO^.01:"_$GET(BARTX(2))_":2"
+4 SET DIR("A")="Unbilled Reimbursement Amount: "
+5 SET DIR("B")=$GET(BARTX(2))
+6 DO ^DIR
+7 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+8 IF Y>BARTX(2)
WRITE !,"YOU CANNOT ENTER AN AMOUNT EXCEEDING THE UNALLOCATED AMOUNT!!"
KILL DIR
SET DIR(0)="E"
DO ^DIR
GOTO REIMBURS
+9 SET NEWVALUE=Y
+10 ;
ASKTYP ;EP - ASK TYPE
+1 KILL DIR,DIE,DIC,DR,DA,X
+2 SET DIC="^BARTBL("
+3 SET DIC(0)="AEQZ"
+4 SET DIC("A")="Unbilled Reimbursement Type: "
+5 SET DIC("S")="I $P(^(0),U,2)=23"
+6 DO ^DIC
+7 IF Y<0
GOTO REIMBURS
+8 SET BARTT=+Y
+9 SET BARATYP=""
+10 SET BARCAT=""
+11 SET NEWTYP=+Y
+12 SET EXNEWTYP=$PIECE(Y,U,2)
ASKVER ;EP - VERIFY ENTRY
+1 NEW ASKVER
+2 KILL DIR
+3 SET DIR("A",1)="You have entered "_NEWVALUE_" as an Unbilled Reimbursement to "_EXNEWTYP_"."
+4 SET DIR("A")="Would you like to Post this or Print the Finance Letter"
+5 SET DIR("B")="L"
+6 SET DIR(0)="SO^P:POST IT;L:PRINT FINANCE LETTER"
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL NEWTYP,EXNEWTYP,NEWVALUE
GOTO REIMBURS
+9 SET ASKVER=Y
+10 SET BARAMT=NEWVALUE
+11 SET BARSIB(101,"I")=NEWTYP
+12 SET BARAC=BARTX(6,"I")
+13 SET BARCHK=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",11,"E")
+14 SET BARSCHED=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")
+15 ;I ASKVER="L" D LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,BARTX(6),"UNBILLED REIMBURSEMENT LETTER") Q ;PRINT REIMBURSMENT LETTER
+16 IF ASKVER="L"
Begin DoDot:1
+17 ; Question to print comments
DO PRTQ^BARPUC2
+18 ;PRINT REIMBURSMENT LETTER ;BAR*1.8*4
DO LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,BARTX(6),"UNBILLED REIMBURSEMENT LETTER",NEWTYP_" "_EXNEWTYP)
QUIT
End DoDot:1
QUIT
+19 WRITE !!
+20 KILL DIR
+21 SET DIR(0)="Y"
+22 SET DIR("B")="N"
+23 SET DIR("A")="ARE YOU SURE YOU WISH TO POST THIS NOW?"
+24 DO ^DIR
+25 IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
GOTO ASKVER
+26 DO REIMCONT
+27 KILL ASKVER
+28 QUIT
+29 ;
TRANSFER ;EP - PROCESS TRANSFERS
+1 SET BARTT=560
+2 SET BARATYP=""
+3 SET BARCAT=""
+4 ;TRANSFER MODE
SET TRANSFER=1
+5 KILL DIR
+6 SET DIR(0)="NO^.01:"_$GET(BARTX(2))_":2"
+7 SET DIR("A")="Transfer Amount: "
+8 SET DIR("B")=$GET(BARTX(2))
+9 WRITE !!
+10 DO ^DIR
+11 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+12 IF Y>BARTX(2)
WRITE !,"YOU CANNOT ENTER AN AMOUNT EXCEEDING THE UNALLOCATED AMOUNT!!"
KILL DIR
SET DIR(0)="E"
DO ^DIR
GOTO TRANSFER
+13 SET NEWVALUE=Y
+14 ;
ASKACCT ;EP - TRANSFER TO WHAT A/R ACCOUNT
+1 KILL DIR,DIC,DIE,DA,X
+2 SET DIC="^BARAC(DUZ(2),"
+3 SET DIC(0)="AMEZQ"
+4 SET DIC("S")="I $P(^(0),U)[(""AUTTLOC"")"
+5 WRITE !
+6 DO ^DIC
+7 IF Y<0
GOTO TRANSFER
+8 ;TRANSFER TO ACCOUNT
SET TBARAC=$PIECE($PIECE(Y,U,2),";")
+9 SET TEXBARAC=$$GET1^DIQ(9999999.06,TBARAC_",",.01,"E")
+10 ;
ASKVERT ;EP - VERIFY ENTRY
+1 KILL DIR
+2 NEW ASKVERT
+3 SET DIR("A",1)="You are transferring "_NEWVALUE_" to "_TEXBARAC_"."
+4 SET DIR("A")="Would you like to Post this or Print Finance Letter"
+5 SET DIR("B")="L"
+6 SET DIR(0)="SO^P:POST IT;L:PRINT FINANCE LETTER"
+7 WRITE !
+8 DO ^DIR
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL NEWVALUE,EXBARAC
GOTO TRANSFER
+10 SET ASKVERT=Y
+11 SET BARAMT=NEWVALUE
+12 SET BARSIB(101,"I")=560
+13 SET BARAC=BARTX(6,"I")
+14 SET BARCHK=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",11,"E")
+15 SET BARSCHED=$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")
+16 IF ASKVERT="L"
Begin DoDot:1
+17 ; Question to print comments
DO PRTQ^BARPUC2
+18 ;PRINT TRANSFER LETTER
DO LETTER^BARUFLTR(BARAMT,BARTX(14),BARCHK,BARSCHED,TEXBARAC,"TRANSFER LETTER")
QUIT
End DoDot:1
QUIT
+19 WRITE !!
+20 KILL DIR
+21 SET DIR(0)="Y"
+22 SET DIR("B")="N"
+23 SET DIR("A")="ARE YOU SURE YOU WISH TO POST THIS NOW?"
+24 DO ^DIR
+25 IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
GOTO ASKVERT
+26 DO REIMCONT
+27 QUIT
+28 ; ********************************************************************
+29 ;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
+30 ;AND MAPS INSURER TYPE CODE TO CATEGORY (IE: W --> OTHER)
H ;;PRIVATE INSURANCE;;HMO
M ;;PRIVATE INSURANCE;;MEDICARE SUPPL.
D ;;MEDICAID;;MEDICAID FI
R ;;MEDICARE;;MEDICARE FI
P ;;PRIVATE INSURANCE;;PRIVATE INSURANCE
W ;;OTHER;;WORKMEN'S COMP
C ;;OTHER;;CHAMPUS
N ;;OTHER;;NON-BENEFICIARY (NON-INDIAN)
I ;;OTHER;;INDIAN PATIENT
K ;;MEDICAID;;CHIP (KIDSCARE)
T ;;OTHER;;THIRD PARTY LIABILITY
G ;;OTHER;;GUARANTOR
MD ;;MEDICARE;;MCR PART D
MH ;;MEDICARE;;MEDICARE HMO
MMC ;;MEDICARE;;MCR MANAGED CARE
TSI ;;OTHER;;TRIBAL SELF INSURED
SEP ;;OTHER;;STATE EXCHANGE PLAN
FPL ;;MEDICAID;;FPL 133 PERCENT
MC ;;MEDICARE;;MCR PART C
F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
V ;;VETERAN;;VETERANS MEDICAL BENEFITS
+1 ;;***END OF TABLE**
