BARCLU0 ; IHS/SD/LSL - COLLECTION BATCH ENTRY FOR EOBS ; 07/22/2010
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,16,19,28**;OCT 26, 2005;Build 92
;;
; IHS/ASDS/LSL - 06/18/2001 - V1.5 Patch 1 - NOIS HQW-0201-100027
; FM 22 issue. Modified to include E in DIC(0)
;
; IHS/SD/LSL - 02/26/04 - V1.7 Patch 5
; Change CHECK prompt to CHK/EFT #
;
; IHS/SD/TMM 06/18/2010 1.8*Patch 19 - M819
; M819 - NEWITEM^BARCLU moved to ^BARCLU4 due to SAC size limitation
; *********************************************************************
;
EDITEM ; EP
; edit collection item
K DIE,BARBL
S DA=BARITDA
S DA(1)=BARCLDA
S DIE=BARDIC_BARCLDA_",1,"
D:BARX=51 EOB
D:BARX=52 CASH
D:BARX=53 CC
D:BARX=55 REFUND
D:BARX=81 CHECK
D:BARX=99 GL
Q
; *********************************************************************
;
CHECK ; EP
; for checks
S DR="11Check/EFT #;"
;S:+BARCLID(22,"I") DR=DR_"20R;" ;BAR*1.8*3 UFMS ASK TREASURYDEPOSITNUMBER ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S:+BARCLID(22,"I") DR=DR_"20////"_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)_";" ;TDN ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S:+BARCLID(12,"I") DR=DR_"12;" ;bk num
; -------------------------------
;
CACC ; EP
D CACC^BARCLU01 ;split for size
Q
; *********************************************************************
;
CC ; EP
; credit card
S DR=""
D CACC
Q
; *********************************************************************
;
GL ; EP
; general ledger entry
S DR="203;" D CACC
Q
; *********************************************************************
;
REFUND ; EP
; refund
S DR="102;Q;6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;6;5;7;8;Q;"
S:+BARSPAR(3,"I") DR=DR_"10;"
S DR=DR_"201//^S X=$G(BARBL(3));301;16//^S X=BARCLID(3)"
S DIDEL=90050
D ^DIE
K DIDEL
; -------------------------------
;
CASH ; EP
; cash col
S DR=""
D CACC
Q
; *********************************************************************
;
EOB ; EP
; ask PAYOR (A/R Account with DISV(screen)
I BARITDA'>$G(BARLAST) D Q
. W !,"A sequence error has been detected."
. W !,"Please notate exactly what you were doing"
. W !,"to provide assistance to the programmers"
. W !,BARLAST,?10,BARITDA
. D EOP^BARUTL(0)
; -------------------------------
;
EOBEDIT ;
S BARQUIT=0
K DR
S BARPAYOR=$G(BARCLIT(7))
I BARPAYOR=-1 S BARPAYOR=""
; -------------------------------
;
RESEL ;
D SPAYOR
I Y'>0 S BARQUIT=1 Q
S BARAC=+Y
S DIE=BARDIC_BARCLDA_",1,"
S DA=BARITDA
S DA(1)=BARCLDA
S DR="7////"_BARAC
D ^DIE
I +BARAC'>0 W !,"FILEING ERROR .. SELECT PAYOR ",! G RESEL
; -------------------------------
;
SAME ; EP
; loop with same payor
;
ITEMEOB ;
K BARQUIT
S DIE=BARDIC_BARCLDA_",1,"
S DA=BARITDA
S DA(1)=BARCLDA
S DR="7////^S X=BARAC;2////51;17////E"
S DIDEL=90050
D ^DIE
K DIDEL
;
D BARCLIT^BARCLU
S BARITTYP=BARCLIT(2)
W $$EN^BARVDF("IOF")
W !!,"ENTERING ",BARCL(.01)
W ?30,"TYPE: ",BARCLID(2)
;W ?50,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15),!! ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
W ?50,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15)
I +BARCLID(22,"I") D
.W !,"TDN/IPAC: ",$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
.W ?35,"TDN/IPAC AMOUNT: ",$FN($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2)
.W !,"TDN/IPAC/Deposit Date: ",$$GET1^DIQ(90051.01,BARCLDA_",",30,"E") ;BAR*1.8*16 IHS/SD/TPF 1/21/2010
W !!
;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
W "ITEM ",BARITDA
W ?20,BARCLIT(7)
W !," ^ at Check Number to ask Payor"
W !," ^ at Payor to exit entry"
S DR="11Check/EFT #;S:X="""" BARQUIT=1"
;S:+BARCLID(22,"I") DR=DR_";20R;" ;BAR*1.8*3 UFMS ASK TREASURY DEPOSIT NUMBER ;IHS/SD/SDR/ bar*1.8*4 DD item 4.1.5.1
;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S BARTDN=$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
S:+BARCLID(22,"I") DR=DR_";20////^S X=BARTDN"
;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S DIDEL=90050
S D0=$G(BARCLDA),D1=$G(BARITDA) ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
D ^DIE
K DIDEL
I +BARCLID(22,"I") W !,"TREASURY DEPOSIT/IPAC: "_BARTDN ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
;
I $D(Y) S BARQUIT=1
I $G(BARQUIT) G EOBEDIT ; return to payor question
;BEGIN BAR*1.8*16 IHS/SD/TPF 1/21/2010
N LIST,DOCARE
D CHECKDUP($$GET1^DIQ(90051.1101,BARITDA_","_BARCLDA_",",11),.LIST)
I $D(LIST) D G:DOCARE ITEMEOB
.K DIR
.S DIR(0)="Y"
.S DIR("B")="No"
.W !!,"Duplicates have been found."
.S DIR("A")="Are you sure you wish to use this check number?"
.D ^DIR
.S DOCARE='Y
K LIST,DOCARE
W !!
;END
S DR="103///@;"
S:BARCLID(12,"I") DR=DR_"12;" ;bnk num
;start old code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
;S DR=DR_"101;" ;amt
;S:BARCLID(13,"I") DR=DR_"10;" ;in/out pat
;end old code start new code 4.1.5.1
S DIDEL=90050
D ^DIE
K DIDEL
AMT S DR="101" ;amt
S:($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)["NONPAY") DR=DR_"////0" ;IHS/SD/SDR bar*1.8*4 SCR 88
D ^DIE
K DR
I +BARCLID(22,"I"),($P($G(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,1)),U))>($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)) D G AMT
.W !!,"AMOUNT OF CREDIT IS GREATER THAN TDN/IPAC OF ",$FN($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2),". PLEASE CORRECT"
S:BARCLID(13,"I") DR="10;" ;in/out pat
;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
;S:'BARSPAR(2,"I") DR=DR_"8///^S X=BARSPAR(.01)" ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S:'BARSPAR(2,"I") DR=$S($G(DR)'="":DR_"8///^S X=BARSPAR(.01)",1:"8///^S X=BARSPAR(.01)") ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
S DIDEL=90050
;D ^DIE ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
I $G(DR) D ^DIE ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
K DIDEL
;
I BARSPAR(2,"I") D EOBSUB I 1 ;multiple 3P facilities
E D INSSUB
D BARCLIT^BARCLU
D DISPLAY^BARCLU1
K BARQUIT
; -------------------------------
;
ASK ;
K DIR
S DIR(0)="S^E:EDIT;D:DELETE;C:CONTINUE"
S DIR("B")="CONTINUE"
D ^DIR
G:Y="E" EOBEDIT
I Y="D" D
. K DA
. S DIK=$$DIC^XBDIQ1(90051.1101)
. S DA=BARITDA
. S DA(1)=BARCLDA
. D ^DIK
. S BARCL(7)=BARCL(7)-1
; -------------------------------
;
EITEMEOB ;
;
FILE ;
; file entry and check counter
K DIE,DR,DA
S DIE=$$DIC^XBDIQ1(90051.01)
S DR="7///"_BARCL(7)
S DA=BARCLDA
S BARLAST=BARCL(7)
S DIDEL=90050
D ^DIE
K DIDEL
;D NEWITEM^BARCLU ;M819*DEL*TMM*20100722--moved to ^BARCLU4 due to rtn size
D NEWITEM^BARCLU4 ;get new item to enter
G SAME
; *********************************************************************
;
EOBSUB ;EP
; enter data for sub EOB locations and amounts"
;
LOOP ;EP
; loop subs for entries and amounts
K DIC,DR,DA,DIE
S DA(2)=BARCLDA
S DA(1)=BARITDA
S DIC="^BARCOL(DUZ(2),"_BARCLDA_",1,"_BARITDA_",6,"
S DIC(0)="EAQMLZ"
S DIC("P")=$P(^DD(90051.1101,601,0),U,2)
F D BARCLIT^BARCLU,DSPSUB S DIC("A")="Cr="_BARCLIT(101)_" Bal=$"_BARCLIT(202.5)_" Select Location ?",DIC(0)="AEQMLZ" D ^DIC Q:+Y'>0 D Q:+BARCLIT(202.5)=0
.S DIE=DIC
.S DA=+Y
.S DR="2///^S X=BARCLIT(202.5)+$$VAL^XBDIQ1(DIE,.DA,2);2;S BARAMT=X"
.S DIDEL=90050
.D ^DIE
.K DIDEL,DIC("P")
.D BARCLIT^BARCLU
.I BARCLIT(202.5)<0 D
.. W *7,?40,"BALANCE : ",BARCLIT(202.5)
.. D KILLSUB
.. W !,"NEGATIVE BALANCE .. ENTRY REMOVED",!
D BARCLIT^BARCLU
I +BARCLIT(202.5)'=0 D G LOOP
.W !!,"BALANCE OFF BY ",BARCLIT(202.5)
.W !!?10,"CREDITS CAN NO LONGER BE PLACED INTO THE UNDISTRIBUTED FUND ACCOUNT"
.W !?10,"PLEASE PLACE THE BALANCE INTO THE APPROPRIATE LOCATION(S)"
.H 2
; -------------------------------
;
ENDEOB ;
Q
; *********************************************************************
;
SPAYOR ; EP
; from BARCLU3
D ^XBNEW("SELPAYOR^BARCLU0:Y;BARPAYOR") ;get a payor
; returns Y from a dic call
Q
; *********************************************************************
;
SELPAYOR ; EP
; select A/R Account for Insurer only
K DIC
S DIC="^BARAC(DUZ(2),"
S DIC(0)="AEZQM"
S DIC("A")="PAYOR: "
S DIC("S")="I $P(^(0),U)[""AUTNINS"",$P(^(0),U,10)=$$VALI^XBDIQ1(200,DUZ,29)"
S DIC("B")=$G(BARPAYOR)
D ^DIC
Q
; *********************************************************************
;
INSSUB ; EP
; insert single sub node
D DELSUBS ;delete existing subs
K DIC,DR,DA,DIE
S DA(2)=BARCLDA
S DA(1)=BARITDA
S DIC=$$DIC^XBDIQ1(90051.1101601)
S DIC(0)="=EL"
S DIC("P")=$P(^DD(90051.1101,601,0),U,2)
S BART=$E(DIC,1,$L(DIC)-1)_")" K @BART
N BART
D ENP^XBDIQ1(90051.1101,"BARCLDA,BARITDA","8;101","BART(")
S X=BART(8)
S DIC("DR")="2///^S X=BART(101)"
D ^DIC
Q
; *********************************************************************
;
KILLSUB ; EP
; kill eob sub when the entry is 0
D ^XBNEW("KSUB^BARCLU0:DA*;DIE")
Q
; *********************************************************************
;
KSUB ; EP
; kill eob sub
S DIK=DIE
D ^DIK
Q
; *********************************************************************
;
DSPSUB ;
D DSPSUB^BARCLU1
Q
; *********************************************************************
;
END ;
DELSUBS ; EP
; REMOVE EOBSUBS
N BART,DIE
S DIE=$$DIC^XBDIQ1(90051.1101601)
D ENPM^XBDIQ1(90051.1101601,"BARCLDA,BARITDA,0",".01","BART(")
S BART=0
F S BART=$O(BART(BART)) Q:'BART D
. S DA=BART
. D PARSE^XBDIQ1("BARCLDA,BARITDA,DA")
. D KILLSUB
Q
;BAR*1.8*16 IHS/SD/TPF 1/21/2010
CHECKDUP(CHK,LIST) ;EP - CHECK FOR DUPLICATE CHEACKS IN A/R COLLECTION BATCH
Q:CHK=""
N CHECNUM,CHECK,COLBAT,ITEM,AMOUNT,COLNAM
K LIST
S CNT=0
S COLBAT=""
F S COLBAT=$O(^BARCOL(DUZ(2),"D",CHK,COLBAT)) Q:COLBAT="" D
.Q:BARCLDA=COLBAT
.S ITEM=""
.F S ITEM=$O(^BARCOL(DUZ(2),"D",CHK,COLBAT,ITEM)) Q:'ITEM D
..S CNT=CNT+1
..S COLNAM=$$GET1^DIQ(90051.01,COLBAT_",",.01,"E")
..S ACCOUNT=$$GET1^DIQ(90051.1101,ITEM_","_COLBAT_",",7,"E")
..S AMOUNT=$$GET1^DIQ(90051.1101,ITEM_","_COLBAT_",",101,"E")
..S LIST(CNT)=COLNAM_U_ITEM_U_ACCOUNT_U_AMOUNT
Q:'$D(LIST)
D DUPHDR(CNT)
D SHOLIST(.LIST)
Q
;
DUPHDR(CNT) ;EP - CHKDUP HEADER
W !!,"Potential duplicate"_$S(CNT>1:"s",1:"")_" found in the following batch"_$S(CNT>1:"es",1:"")_":"
Q
;
SHOLIST(LIST) ;EP - SHOW LIST OF DUPES
N CNT
S CNT=""
W !
F S CNT=$O(LIST(CNT)) Q:'CNT D
.W !,CNT,"."
.W ?3,$P(LIST(CNT),U)
.W ?34,$P(LIST(CNT),U,2)
.W ?37,$P(LIST(CNT),U,3)
.W ?65,$J($FN($P(LIST(CNT),U,4),",",2),15)
W !!
;K DIR
;S DIR(0)="E"
;D ^DIR
Q
BARCLU0 ; IHS/SD/LSL - COLLECTION BATCH ENTRY FOR EOBS ; 07/22/2010
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,16,19,28**;OCT 26, 2005;Build 92
+2 ;;
+3 ; IHS/ASDS/LSL - 06/18/2001 - V1.5 Patch 1 - NOIS HQW-0201-100027
+4 ; FM 22 issue. Modified to include E in DIC(0)
+5 ;
+6 ; IHS/SD/LSL - 02/26/04 - V1.7 Patch 5
+7 ; Change CHECK prompt to CHK/EFT #
+8 ;
+9 ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 - M819
+10 ; M819 - NEWITEM^BARCLU moved to ^BARCLU4 due to SAC size limitation
+11 ; *********************************************************************
+12 ;
EDITEM ; EP
+1 ; edit collection item
+2 KILL DIE,BARBL
+3 SET DA=BARITDA
+4 SET DA(1)=BARCLDA
+5 SET DIE=BARDIC_BARCLDA_",1,"
+6 IF BARX=51
DO EOB
+7 IF BARX=52
DO CASH
+8 IF BARX=53
DO CC
+9 IF BARX=55
DO REFUND
+10 IF BARX=81
DO CHECK
+11 IF BARX=99
DO GL
+12 QUIT
+13 ; *********************************************************************
+14 ;
CHECK ; EP
+1 ; for checks
+2 SET DR="11Check/EFT #;"
+3 ;S:+BARCLID(22,"I") DR=DR_"20R;" ;BAR*1.8*3 UFMS ASK TREASURYDEPOSITNUMBER ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+4 ;TDN ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
IF +BARCLID(22,"I")
SET DR=DR_"20////"_$PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,28)_";"
+5 ;bk num
IF +BARCLID(12,"I")
SET DR=DR_"12;"
+6 ; -------------------------------
+7 ;
CACC ; EP
+1 ;split for size
DO CACC^BARCLU01
+2 QUIT
+3 ; *********************************************************************
+4 ;
CC ; EP
+1 ; credit card
+2 SET DR=""
+3 DO CACC
+4 QUIT
+5 ; *********************************************************************
+6 ;
GL ; EP
+1 ; general ledger entry
+2 SET DR="203;"
DO CACC
+3 QUIT
+4 ; *********************************************************************
+5 ;
REFUND ; EP
+1 ; refund
+2 SET DR="102;Q;6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;6;5;7;8;Q;"
+3 IF +BARSPAR(3,"I")
SET DR=DR_"10;"
+4 SET DR=DR_"201//^S X=$G(BARBL(3));301;16//^S X=BARCLID(3)"
+5 SET DIDEL=90050
+6 DO ^DIE
+7 KILL DIDEL
+8 ; -------------------------------
+9 ;
CASH ; EP
+1 ; cash col
+2 SET DR=""
+3 DO CACC
+4 QUIT
+5 ; *********************************************************************
+6 ;
EOB ; EP
+1 ; ask PAYOR (A/R Account with DISV(screen)
+2 IF BARITDA'>$GET(BARLAST)
Begin DoDot:1
+3 WRITE !,"A sequence error has been detected."
+4 WRITE !,"Please notate exactly what you were doing"
+5 WRITE !,"to provide assistance to the programmers"
+6 WRITE !,BARLAST,?10,BARITDA
+7 DO EOP^BARUTL(0)
End DoDot:1
QUIT
+8 ; -------------------------------
+9 ;
EOBEDIT ;
+1 SET BARQUIT=0
+2 KILL DR
+3 SET BARPAYOR=$GET(BARCLIT(7))
+4 IF BARPAYOR=-1
SET BARPAYOR=""
+5 ; -------------------------------
+6 ;
RESEL ;
+1 DO SPAYOR
+2 IF Y'>0
SET BARQUIT=1
QUIT
+3 SET BARAC=+Y
+4 SET DIE=BARDIC_BARCLDA_",1,"
+5 SET DA=BARITDA
+6 SET DA(1)=BARCLDA
+7 SET DR="7////"_BARAC
+8 DO ^DIE
+9 IF +BARAC'>0
WRITE !,"FILEING ERROR .. SELECT PAYOR ",!
GOTO RESEL
+10 ; -------------------------------
+11 ;
SAME ; EP
+1 ; loop with same payor
+2 ;
ITEMEOB ;
+1 KILL BARQUIT
+2 SET DIE=BARDIC_BARCLDA_",1,"
+3 SET DA=BARITDA
+4 SET DA(1)=BARCLDA
+5 SET DR="7////^S X=BARAC;2////51;17////E"
+6 SET DIDEL=90050
+7 DO ^DIE
+8 KILL DIDEL
+9 ;
+10 DO BARCLIT^BARCLU
+11 SET BARITTYP=BARCLIT(2)
+12 WRITE $$EN^BARVDF("IOF")
+13 WRITE !!,"ENTERING ",BARCL(.01)
+14 WRITE ?30,"TYPE: ",BARCLID(2)
+15 ;W ?50,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15),!! ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+16 ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+17 WRITE ?50,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15)
+18 IF +BARCLID(22,"I")
Begin DoDot:1
+19 WRITE !,"TDN/IPAC: ",$PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
+20 WRITE ?35,"TDN/IPAC AMOUNT: ",$FNUMBER($PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2)
+21 ;BAR*1.8*16 IHS/SD/TPF 1/21/2010
WRITE !,"TDN/IPAC/Deposit Date: ",$$GET1^DIQ(90051.01,BARCLDA_",",30,"E")
End DoDot:1
+22 WRITE !!
+23 ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+24 WRITE "ITEM ",BARITDA
+25 WRITE ?20,BARCLIT(7)
+26 WRITE !," ^ at Check Number to ask Payor"
+27 WRITE !," ^ at Payor to exit entry"
+28 SET DR="11Check/EFT #;S:X="""" BARQUIT=1"
+29 ;S:+BARCLID(22,"I") DR=DR_";20R;" ;BAR*1.8*3 UFMS ASK TREASURY DEPOSIT NUMBER ;IHS/SD/SDR/ bar*1.8*4 DD item 4.1.5.1
+30 ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+31 SET BARTDN=$PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
+32 IF +BARCLID(22,"I")
SET DR=DR_";20////^S X=BARTDN"
+33 ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+34 SET DIDEL=90050
+35 ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
SET D0=$GET(BARCLDA)
SET D1=$GET(BARITDA)
+36 DO ^DIE
+37 KILL DIDEL
+38 ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
IF +BARCLID(22,"I")
WRITE !,"TREASURY DEPOSIT/IPAC: "_BARTDN
+39 ;
+40 IF $DATA(Y)
SET BARQUIT=1
+41 ; return to payor question
IF $GET(BARQUIT)
GOTO EOBEDIT
+42 ;BEGIN BAR*1.8*16 IHS/SD/TPF 1/21/2010
+43 NEW LIST,DOCARE
+44 DO CHECKDUP($$GET1^DIQ(90051.1101,BARITDA_","_BARCLDA_",",11),.LIST)
+45 IF $DATA(LIST)
Begin DoDot:1
+46 KILL DIR
+47 SET DIR(0)="Y"
+48 SET DIR("B")="No"
+49 WRITE !!,"Duplicates have been found."
+50 SET DIR("A")="Are you sure you wish to use this check number?"
+51 DO ^DIR
+52 SET DOCARE='Y
End DoDot:1
IF DOCARE
GOTO ITEMEOB
+53 KILL LIST,DOCARE
+54 WRITE !!
+55 ;END
+56 SET DR="103///@;"
+57 ;bnk num
IF BARCLID(12,"I")
SET DR=DR_"12;"
+58 ;start old code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+59 ;S DR=DR_"101;" ;amt
+60 ;S:BARCLID(13,"I") DR=DR_"10;" ;in/out pat
+61 ;end old code start new code 4.1.5.1
+62 SET DIDEL=90050
+63 DO ^DIE
+64 KILL DIDEL
AMT ;amt
SET DR="101"
+1 ;IHS/SD/SDR bar*1.8*4 SCR 88
IF ($PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,28)["NONPAY")
SET DR=DR_"////0"
+2 DO ^DIE
+3 KILL DR
+4 IF +BARCLID(22,"I")
IF ($PIECE($GET(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,1)),U))>($PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,29))
Begin DoDot:1
+5 WRITE !!,"AMOUNT OF CREDIT IS GREATER THAN TDN/IPAC OF ",$FNUMBER($PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2),". PLEASE CORRECT"
End DoDot:1
GOTO AMT
+6 ;in/out pat
IF BARCLID(13,"I")
SET DR="10;"
+7 ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+8 ;S:'BARSPAR(2,"I") DR=DR_"8///^S X=BARSPAR(.01)" ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+9 ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
IF 'BARSPAR(2,"I")
SET DR=$SELECT($GET(DR)'="":DR_"8///^S X=BARSPAR(.01)",1:"8///^S X=BARSPAR(.01)")
+10 SET DIDEL=90050
+11 ;D ^DIE ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+12 ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
IF $GET(DR)
DO ^DIE
+13 KILL DIDEL
+14 ;
+15 ;multiple 3P facilities
IF BARSPAR(2,"I")
DO EOBSUB
IF 1
+16 IF '$TEST
DO INSSUB
+17 DO BARCLIT^BARCLU
+18 DO DISPLAY^BARCLU1
+19 KILL BARQUIT
+20 ; -------------------------------
+21 ;
ASK ;
+1 KILL DIR
+2 SET DIR(0)="S^E:EDIT;D:DELETE;C:CONTINUE"
+3 SET DIR("B")="CONTINUE"
+4 DO ^DIR
+5 IF Y="E"
GOTO EOBEDIT
+6 IF Y="D"
Begin DoDot:1
+7 KILL DA
+8 SET DIK=$$DIC^XBDIQ1(90051.1101)
+9 SET DA=BARITDA
+10 SET DA(1)=BARCLDA
+11 DO ^DIK
+12 SET BARCL(7)=BARCL(7)-1
End DoDot:1
+13 ; -------------------------------
+14 ;
EITEMEOB ;
+1 ;
FILE ;
+1 ; file entry and check counter
+2 KILL DIE,DR,DA
+3 SET DIE=$$DIC^XBDIQ1(90051.01)
+4 SET DR="7///"_BARCL(7)
+5 SET DA=BARCLDA
+6 SET BARLAST=BARCL(7)
+7 SET DIDEL=90050
+8 DO ^DIE
+9 KILL DIDEL
+10 ;D NEWITEM^BARCLU ;M819*DEL*TMM*20100722--moved to ^BARCLU4 due to rtn size
+11 ;get new item to enter
DO NEWITEM^BARCLU4
+12 GOTO SAME
+13 ; *********************************************************************
+14 ;
EOBSUB ;EP
+1 ; enter data for sub EOB locations and amounts"
+2 ;
LOOP ;EP
+1 ; loop subs for entries and amounts
+2 KILL DIC,DR,DA,DIE
+3 SET DA(2)=BARCLDA
+4 SET DA(1)=BARITDA
+5 SET DIC="^BARCOL(DUZ(2),"_BARCLDA_",1,"_BARITDA_",6,"
+6 SET DIC(0)="EAQMLZ"
+7 SET DIC("P")=$PIECE(^DD(90051.1101,601,0),U,2)
+8 FOR
DO BARCLIT^BARCLU
DO DSPSUB
SET DIC("A")="Cr="_BARCLIT(101)_" Bal=$"_BARCLIT(202.5)_" Select Location ?"
SET DIC(0)="AEQMLZ"
DO ^DIC
IF +Y'>0
QUIT
Begin DoDot:1
+9 SET DIE=DIC
+10 SET DA=+Y
+11 SET DR="2///^S X=BARCLIT(202.5)+$$VAL^XBDIQ1(DIE,.DA,2);2;S BARAMT=X"
+12 SET DIDEL=90050
+13 DO ^DIE
+14 KILL DIDEL,DIC("P")
+15 DO BARCLIT^BARCLU
+16 IF BARCLIT(202.5)<0
Begin DoDot:2
+17 WRITE *7,?40,"BALANCE : ",BARCLIT(202.5)
+18 DO KILLSUB
+19 WRITE !,"NEGATIVE BALANCE .. ENTRY REMOVED",!
End DoDot:2
End DoDot:1
IF +BARCLIT(202.5)=0
QUIT
+20 DO BARCLIT^BARCLU
+21 IF +BARCLIT(202.5)'=0
Begin DoDot:1
+22 WRITE !!,"BALANCE OFF BY ",BARCLIT(202.5)
+23 WRITE !!?10,"CREDITS CAN NO LONGER BE PLACED INTO THE UNDISTRIBUTED FUND ACCOUNT"
+24 WRITE !?10,"PLEASE PLACE THE BALANCE INTO THE APPROPRIATE LOCATION(S)"
+25 HANG 2
End DoDot:1
GOTO LOOP
+26 ; -------------------------------
+27 ;
ENDEOB ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
SPAYOR ; EP
+1 ; from BARCLU3
+2 ;get a payor
DO ^XBNEW("SELPAYOR^BARCLU0:Y;BARPAYOR")
+3 ; returns Y from a dic call
+4 QUIT
+5 ; *********************************************************************
+6 ;
SELPAYOR ; EP
+1 ; select A/R Account for Insurer only
+2 KILL DIC
+3 SET DIC="^BARAC(DUZ(2),"
+4 SET DIC(0)="AEZQM"
+5 SET DIC("A")="PAYOR: "
+6 SET DIC("S")="I $P(^(0),U)[""AUTNINS"",$P(^(0),U,10)=$$VALI^XBDIQ1(200,DUZ,29)"
+7 SET DIC("B")=$GET(BARPAYOR)
+8 DO ^DIC
+9 QUIT
+10 ; *********************************************************************
+11 ;
INSSUB ; EP
+1 ; insert single sub node
+2 ;delete existing subs
DO DELSUBS
+3 KILL DIC,DR,DA,DIE
+4 SET DA(2)=BARCLDA
+5 SET DA(1)=BARITDA
+6 SET DIC=$$DIC^XBDIQ1(90051.1101601)
+7 SET DIC(0)="=EL"
+8 SET DIC("P")=$PIECE(^DD(90051.1101,601,0),U,2)
+9 SET BART=$EXTRACT(DIC,1,$LENGTH(DIC)-1)_")"
KILL @BART
+10 NEW BART
+11 DO ENP^XBDIQ1(90051.1101,"BARCLDA,BARITDA","8;101","BART(")
+12 SET X=BART(8)
+13 SET DIC("DR")="2///^S X=BART(101)"
+14 DO ^DIC
+15 QUIT
+16 ; *********************************************************************
+17 ;
KILLSUB ; EP
+1 ; kill eob sub when the entry is 0
+2 DO ^XBNEW("KSUB^BARCLU0:DA*;DIE")
+3 QUIT
+4 ; *********************************************************************
+5 ;
KSUB ; EP
+1 ; kill eob sub
+2 SET DIK=DIE
+3 DO ^DIK
+4 QUIT
+5 ; *********************************************************************
+6 ;
DSPSUB ;
+1 DO DSPSUB^BARCLU1
+2 QUIT
+3 ; *********************************************************************
+4 ;
END ;
DELSUBS ; EP
+1 ; REMOVE EOBSUBS
+2 NEW BART,DIE
+3 SET DIE=$$DIC^XBDIQ1(90051.1101601)
+4 DO ENPM^XBDIQ1(90051.1101601,"BARCLDA,BARITDA,0",".01","BART(")
+5 SET BART=0
+6 FOR
SET BART=$ORDER(BART(BART))
IF 'BART
QUIT
Begin DoDot:1
+7 SET DA=BART
+8 DO PARSE^XBDIQ1("BARCLDA,BARITDA,DA")
+9 DO KILLSUB
End DoDot:1
+10 QUIT
+11 ;BAR*1.8*16 IHS/SD/TPF 1/21/2010
CHECKDUP(CHK,LIST) ;EP - CHECK FOR DUPLICATE CHEACKS IN A/R COLLECTION BATCH
+1 IF CHK=""
QUIT
+2 NEW CHECNUM,CHECK,COLBAT,ITEM,AMOUNT,COLNAM
+3 KILL LIST
+4 SET CNT=0
+5 SET COLBAT=""
+6 FOR
SET COLBAT=$ORDER(^BARCOL(DUZ(2),"D",CHK,COLBAT))
IF COLBAT=""
QUIT
Begin DoDot:1
+7 IF BARCLDA=COLBAT
QUIT
+8 SET ITEM=""
+9 FOR
SET ITEM=$ORDER(^BARCOL(DUZ(2),"D",CHK,COLBAT,ITEM))
IF 'ITEM
QUIT
Begin DoDot:2
+10 SET CNT=CNT+1
+11 SET COLNAM=$$GET1^DIQ(90051.01,COLBAT_",",.01,"E")
+12 SET ACCOUNT=$$GET1^DIQ(90051.1101,ITEM_","_COLBAT_",",7,"E")
+13 SET AMOUNT=$$GET1^DIQ(90051.1101,ITEM_","_COLBAT_",",101,"E")
+14 SET LIST(CNT)=COLNAM_U_ITEM_U_ACCOUNT_U_AMOUNT
End DoDot:2
End DoDot:1
+15 IF '$DATA(LIST)
QUIT
+16 DO DUPHDR(CNT)
+17 DO SHOLIST(.LIST)
+18 QUIT
+19 ;
DUPHDR(CNT) ;EP - CHKDUP HEADER
+1 WRITE !!,"Potential duplicate"_$SELECT(CNT>1:"s",1:"")_" found in the following batch"_$SELECT(CNT>1:"es",1:"")_":"
+2 QUIT
+3 ;
SHOLIST(LIST) ;EP - SHOW LIST OF DUPES
+1 NEW CNT
+2 SET CNT=""
+3 WRITE !
+4 FOR
SET CNT=$ORDER(LIST(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+5 WRITE !,CNT,"."
+6 WRITE ?3,$PIECE(LIST(CNT),U)
+7 WRITE ?34,$PIECE(LIST(CNT),U,2)
+8 WRITE ?37,$PIECE(LIST(CNT),U,3)
+9 WRITE ?65,$JUSTIFY($FNUMBER($PIECE(LIST(CNT),U,4),",",2),15)
End DoDot:1
+10 WRITE !!
+11 ;K DIR
+12 ;S DIR(0)="E"
+13 ;D ^DIR
+14 QUIT
