BARPUC.m

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