BARUFEX5 ; IHS/SD/TPF - CONTINUATION OF EXPORT -- BUILD BOB FILE ; 09/17/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**4,5,6,7,23**;OCT 26, 2005
;NEW ROUTINE; ITEM 1 OF SCR58 1/2/2008 ;MRS:BAR*1.8*4 DD ITEM 4.1.1
;HEAT54733 APR 2012 P.OTT bug fix <SUBSCRIPT>SETORIG+2^BARUFEX5
;HEAT93190 DEC 2012 P.OTTIS NOHEAT MARK / IGNORE DUPLICATE GHOST BILLS (SAME PAT, BUT MISSING CLAIM IN 3PB)
;NOHEAT MAR 2013 P.OTTIS ADDED NEW VA billing
;
PRE(BARBG,BARDUZ) ;EP;
;
; ENTERS WITH TRANSACTION BEGIN DATE
; AND BARDUZ = DUZ OF USER
;
K ^BARBOB("BARZ",BARDUZ)
K ^BARBOB("BARZZ",BARDUZ)
K ^BARZZZ("BARZ") ;MRS:BAR*1.8*6
D NOW^%DTC
S PRELIVLM=3071001 ;FOR RELEASE
S ^BARBOB("BARZ",BARDUZ,"BEGIN")=%
N BARX,BARY,BARZ,BARIDT,BART,BARBDA,BARTX,BAR,BARREV,BARFLG,TRDATE
S SAFEDUZ=DUZ(2)
S BARTOTX=0 ;XTMP COUNTER
;BEGIN EXCLUSION CHECKS
D SETZZ(BARDUZ) ;BUILD FILE OF PAYMENTS IN DATE RANGE
S DUZ(2)=0
F S DUZ(2)=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2))) Q:'DUZ(2) D
.S BARBDA=0
.F S BARBDA=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA)) Q:'BARBDA D
..S BARBILL=$G(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA))
..Q:'BARBILL ;BILL HAS DA BUT NOT NAME
..S BARBL0=$G(^BARBL(DUZ(2),BARBDA,0))
..S ABMDUZ2=$P(BARBL0,U,22)
..Q:'ABMDUZ2 ;NO 3P DUZ(2)
..S ABMIEN=$P(BARBL0,U,17)
..Q:'ABMIEN ;NO 3P BILL IEN
..I $$BILL^ABMUEAPI(ABMDUZ2,ABMIEN)<1 Q ;3P EXCLUSION
.. Q:'$$IHS^BARUFUT(ABMDUZ2)
..;;;Q:'$$IHSERA^BARUFUT(ABMDUZ2) ;P.OTT
..S BARACCT=$$GETBACC^BARUFEXU(BARBDA) ;A/R BILL, A/R ACCOUNT
..Q:'BARACCT ;NO INSURER
..S D0=BARACCT
..S BARITYP=$$VALI^BARVPM(8) ;GET 'VIP INSURER TYPE' CODE (NUMBER)
..I BARITYP="I"!(BARITYP="T") Q ;EXCLUDE 'INDIAN' OR 'THIRD PARTY BILLING' PER MEETING OF 5/4/2007
..; Check 3P transmitted date
..S BARPLOC=$$GETPLOC ;A/R BILL, PARENT LOCATION
..Q:'BARPLOC
..;S UFMSSUFC=$$PRELIVE(ABMDUZ2,ABMIEN,BARITYP,BARPLOC) ;MRS:BAR*1.8*7
..;I UFMSSUFC="" Q ;MRS:BAR*1.8*7
..;
TX ..;NOW HAVE A BILL TO CHECK
..S TRDATE=0
..F S TRDATE=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)) Q:'TRDATE D
...S IENS=TRDATE_","
...S BARPAY=$$GET1^DIQ(90050.03,IENS,3.5,"E") ;CREDIT - DEBIT
...Q:BARPAY=0 ;DON'T LOOK AT 0 PAYMENTS
...S BARTX0=$G(^BARTR(DUZ(2),TRDATE,0))
...S BARCB=$P(BARTX0,U,14) ;COLLECTION BATCH IEN;GET EXTERNAL NAME LATER
...S BARCI=$P(BARTX0,U,15) ;COLLECTION ITEM
...I BARCB=""!(BARCI="") Q ;NOT IN BATCH/ITEM
...S BARZZ0=^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)
...S BARFLG=$S(BARZZ0]"":BARZZ0,1:0) ;CHECK FOR -25 CODE FLAG
...S (BARREV,BAROTX)="" ;INIT ORIGINAL TX
...S BARIPAC=$$IPAC^BARUFEX4(BARCB,BARCI,IENS) ;SCHEDULE NUMBER/IPAC
...D CLEAN
...I BARPAY<0,BARFLG'=-25 D
....S BARXPAC=$$REV(BARBDA,BARPAY,BARIPAC) ;CHECK REVERSAL
....;RETURNS CODE_U_RESCHED_U_ORIGTX
....S BARFLG=$P(BARXPAC,U) ;WHAT FOUND FLAG
....S BARIPAC=$P(BARXPAC,U,2)
....I BARFLG=2 D ;SIMPLE REVERSAL
.....S BAROTX=$P(BARXPAC,U,3) ;ORIGINAL TRANSACTION
.....I BAROTX="" QUIT ;P.OTT
.....D SETORIG(BAROTX,.BARFLG) ;RETURNS ORIGINAL REFERENCES
.....S ^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)=2
....I $E(BARFLG)="-" D CODE(BARBDA,BARFLG)
...S ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)=BARPAY_U_BARIPAC_U_BARBDA_U_BARBILL_U_BARFLG
D COLCK ;CHECK BATCH/ITEM FOR PAIRS
D NOW^%DTC
S ^BARBOB("BARZ",BARDUZ,"END")=%
S DUZ(2)=SAFEDUZ
Q
;
SETORIG(TRDT,BARFLG) ;FLAG ORIGINAL PAYMENT WHEN SIMPLE REVERSAL IS FOUND
N BARO0,BAROCB,BAROCI
S BARO0=$G(^BARTR(DUZ(2),TRDT,0))
S BAROCB=$P(BARO0,U,14) ;COLLECTION BATCH IEN;GET EXTERNAL NAME LATER
Q:'BAROCB
S BAROCI=$P(BARO0,U,15) ;COLLECTION ITEM
Q:'BAROCI
S BARFLG=BARFLG_U_BARCB_U_BARCI_U_TRDATE
S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BAROCB,BAROCI,TRDT),U,5)=BARFLG
S BARFLG=BARFLG_U_BAROCB_U_BAROCI_U_TRDT
S ^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDT)=2
Q
;
COLCK ; NOW BEGIN PAIRS CHECK IN COLLECTION BATCH/ITEM
;
N BARCB,BARCI,TRDATE,BARNEG,BAR,BARPAY,BAR7
S DUZ(2)=0
F S DUZ(2)=$O(^BARBOB("BARZ",BARDUZ,DUZ(2))) Q:'DUZ(2) D
.S BARCB=0
.F S BARCB=$O(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB)) Q:'BARCB D
..S BARCI=0
..F S BARCI=$O(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)) Q:'BARCI D
...S (TRDATE,BARNEG,BAR7)=0
...K BAR ;CLEAR LOCAL ARRAY
...F S TRDATE=$O(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)) Q:'TRDATE D
....S BAR0=^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)
....S BARDA=$P(BAR0,U,3)
....S BARFLG=$P(BAR0,U,5)
....S BARFLGZ=$G(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARDA,TRDATE))
....I BARFLG=0,BARFLGZ'="" S BARFLG=BARFLGZ
....I $E(BARFLG)="-" D
.....S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE),U,5)=BARFLG
.....S $P(BAR0,U,5)=BARFLG
.....S BAR7=3
....S BARAMT=$P(BAR0,U,1)
....I BARAMT<0 S BARNEG=1
....S BAR(TRDATE)=BAR0
...I BARNEG D PAIRS(.BAR,BAR7) Q ;REVERSAL FOUND
...S BARFLG=$S(BAR7'=0:2,1:1)
...S ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)=BARFLG
Q
;
PAIRS(BAR,BAR7) ;LOOK FOR OK PAIRS OF PAYMENTS AND REVERSALS
;BAR STRING = BARPAY_U_BARIPAC_U_BARBDA_U_BARBILL_U_BARFLG
; I BARFLG=-4 or -7 ;MULTIPLE MATCHES -- DON'T PAIR
; I BARFLG=-3 or -6 ;ORIGINAL NOT FOUND -- PAIR
;ADDED CHECK FOR PERMANENT IGNORABLE PAIRS
; DEF: FIRST PAYMENT IS A REVERSAL
; SECOND PAYMENT MATCHES REVERSAL
; AND BOTH ARE IN SAME BILL AND BATCH/ITEM
;
N BARI,BARJ,BARCNT
S ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)=BAR7 ;REVERSALS IN BATCH
S BARCNT=0
;
AGAIN S BARI=0
I S BARI=$O(BAR(BARI))
Q:'BARI
S BARCNT=BARCNT+1
S BARIFLG=$P(BAR(BARI),U,5)
I BARIFLG=2 K BAR(BARI) G I ;FLAGGED AS SIMPLE TX/REV
I BARIFLG=-4!(BARIFLG=-7)!(BARIFLG=-25) K BAR(BARI) G I ;COMPLEX OR DUPLICATE
S BARJ=0
J S BARJ=$O(BAR(BARJ))
I 'BARJ G I
S BARJFLG=$P(BAR(BARJ),U,5)
I BARJFLG=2 K BAR(BARJ) G J ;FLAGGED AS ORIGINAL TX OR REV
I BARJFLG=-4!(BARJFLG=-7)!(BARJFLG=-25) K BAR(BARI) G I ;COMPLEX OR DUPLICATE
I $P(BAR(BARI),U,1,3)=$P(BAR(BARJ),U,1,3) G J ;DON'T CHECK SELF
;CHECK AMOUNT
S BARIAMT=$P(BAR(BARI),U)
S BARJAMT=$P(BAR(BARJ),U)
I BARIAMT'=-BARJAMT G J ;ABSOLUTE AMOUNTS DON'T MATCH
;CHECK TREAS SCHED #
I $P(BAR(BARI),U,2)=$P(BAR(BARJ),U,2) D G AGAIN ;KEEP CHECKING
.I BARCNT=1 D Q:'$D(BAR(BARI))
..I $P(BAR(BARI),U,3)'=$P(BAR(BARJ),U,3) Q ;NOT MATCHING BILLS
..I BARIAMT<0,BARJAMT>0 D PAIR("-I") ;FOUND IGNORABLE PAIR
.D PAIR(1)
G J
;
PAIR(Z) ;FOUND A MATCH -- FLAG TRANSACTIONS AS GOOD TO GO OR CODE "-I"
N FLG
S FLG=Z_U_BARCB_U_BARCI_U_BARJ
S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,BARI),U,5)=FLG
K BAR(BARI) ;REMOVE ENTRY
S FLG=Z_U_BARCB_U_BARCI_U_BARI
S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,BARJ),U,5)=FLG
K BAR(BARJ)
Q
;
REV(BARBDA,BARPAY,TIPAC) ; FIND SIMPLE REVERSAL SCHEDULE NUMBER ;HEAVILY MODIFIED FOR BAR*1.8*5 IM29449
N Y,Z,SCHED,CODE,BARRDT,BARRTDN,BARR1
S Y=""
S BARR1=$G(^BARTR(DUZ(2),TRDATE,1))
I $P(BARR1,U,12)="I" Q "I" ;IGNORE TRANSACTION MRS:BAR*1.8*6 IM29571
S BARRDT=$P(BARR1,U,10) ;REVERSAL DATE/TIME
I BARRDT]"" D ;GET MATCHED TRANSACTION ;NEW CHECK FOR MATCHES BAR*1.8*5 IM29571
.I BARRDT'["." S BARRDT="" Q ;IMCOMPLETE TX DATE; CHECK FURTHER
.S BARRTDN=$P(BARR1,U,11) ;REVERSAL TDN/IPAC
.;S:BARRTDN="" BARRTDN="PRE MODIFICATIONS" ;LEAVE BLANK;MRS:BAR*1.8*6
.I '$G(^BARTR(DUZ(2),BARRDT,0)) S REV=0 Q
.S TAMT=$$GET1^DIQ(90050.03,BARRDT_",",3.5,"E")
.I +$G(BARPAY)'=-TAMT S REV=0 Q
.S REV=$P(BARRDT,".")_U_BARRTDN_U_BARRDT
;
I BARRDT="" D
.S REV=$$FINDTRAN(BARBDA,BARPAY) ;FIND ORIGINAL RECEIPT
.; RETURNS REVDATE_U_RESCHED_U_ORIGTX, NUMBER OF MULTIPLES, OR 0 IF CAN'T FIND
S SCHED=$P(REV,U,2)
S Y=$P($G(^BARTR(DUZ(2),TRDATE,1)),U,6)
;
I 'REV D Q CODE_U_TIPAC ;CAN'T FIND THE ORIGINAL DATE
.S CODE=$S(Y="e":-3,1:-6)
I REV'[U D Q CODE_U_TIPAC ;MATCHES/REV ARE>1, NOT STRING
.S CODE=$S(Y="e":-4,1:-7)
Q 2_U_$P(REV,U,2,3) ;RETURN SCHED AND ORIGINAL TX
;
PRELIVE(ABMDUZ2,ABMIEN,BARITYP,BARPLOC) ;
Q ;MRS:BAR*1.8*7
N TPBAPDT,TPBEXDT
S UFMSSUFC=""
S TPBAPDT=$$APPRDTTM^ABMUEAPI(ABMDUZ2,ABMIEN) ;API 3P APPROVAL DATE
I TPBAPDT="" Q UFMSSUFC
;
;Prelive logic for 'APPLY TO' or ASUFACASUFAC3PIEN string
;If Date/Time Approved < 10/1/2007 then UFMSSUFC=$$PRELIVE instead
;If this is true there will be no delay send at all
;
;I TPBAPDT<PRELIVLM D Q UFMSSUFC ;IHS/SD/SDR bar*1.8*4 SCR100
S BAR08DT=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5) ;IHS/SD/SDR bar*1.8*4 SCR100
I TPBAPDT<PRELIVLM!(TPBAPDT<BAR08DT) D Q UFMSSUFC ;IHS/SD/SDR bar*1.8*4 SCR100
.S BARAREA=$$GET1^DIQ(9999999.06,BARPLOC_",",.04,"I") ;LOCATION, AREA PTR
.S PRELIV=$$PRELIVE^BARUFUT1(BARAREA,BARITYP)
.S UFMSSUFC=PRELIV
;
S UFMSSUFC=$$TRANSMIT^ABMUEAPI(ABMDUZ2,ABMIEN)
S:UFMSSUFC=-1 UFMSSUFC=""
Q UFMSSUFC
;
GETPLOC() ;
N BARPLOC,BARVLOC
S BARPLOC=$P(BARBL0,U,8) ;A/R BILL, PARENT LOCATION
I BARPLOC Q BARPLOC
I 'BARPLOC D ;Not found/or bad location
.S BARVLOC=$P($G(^BARBL(DUZ(2),BARBDA,1)),U,8) ;A/R BILL, VISIT LOCATION
.S BARPLOC=$$PARENT^BARUFEXU
Q BARPLOC
;
SETZZ(BARDUZ) ;CHECK FOR AT LEAST ONE PAYMENT IN DATE RANGE
N X,Y,Z,BARBILL,DUP,BARNUM,TRANTYPE
S DUZ(2)=0 F S DUZ(2)=$O(^BARTR(DUZ(2))) Q:'DUZ(2) D
. Q:'$$IHS^BARUFUT(DUZ(2))
. ;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;P.OTT
.S BARBEG=$$BARBEG(DUZ(2))
.S X=0
.F S X=$O(^BARTR(DUZ(2),"AC",X)) Q:'X D
..S Y=$O(^BARTR(DUZ(2),"AC",X,""),-1)
..I Y'>BARBEG Q ;NO TRANSACTIONS IN DATE RANGE
..S Y=0
..F S Y=$O(^BARTR(DUZ(2),"AC",X,Y)) Q:'Y D
...I $P($G(^BARTR(DUZ(2),Y,1)),U,12)="I" D Q ;FLAGGED AS IGNORABLE:MRS:BAR*1.8*6 IM29571
....S ^BARBOB("BARZZ",BARDUZ,DUZ(2),"I",X)="" ;MRS:BAR*1.8*6 IM29571
...S IENS=Y_","
...S TRANTYPE=$$GET1^DIQ(90050.03,IENS_",",101,"E") ;TRANSACTION TYPE
...Q:TRANTYPE'="PAYMENT" ;ONLY WANT PAYMENTS
...S BARBILL=$$GET1^DIQ(90050.03,IENS,4,"E") ;A/R BILL
...S DUP=$$DUP(BARBILL) ;CHECK FOR DUPLICATE BILLS
...S ^BARBOB("BARZZ",BARDUZ,DUZ(2),X)=BARBILL
...S ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=DUP
Q
;
CODE(X,Z) ;FLAG ALL TRANSACTIONS FOR BILL WITH CODE -7 AND -4
; ENTERS WITH X = BARBILL DA
; Z = CODE = -7 = MULTIPLE MAN TX W/IN BILL
; -6 = CANNOT FIND ORIG TX W/IN BILL
; -3 = SAME AS -6 FOR ERA TX
; -4 = SAME AS -7 FOR ERA TX
N Y
S Y=0
F S Y=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)) Q:'Y D
.I Z'=-25 Q:^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=2 ;HAS SIMPLE REVERSAL
.Q:^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=-25 ;DUPLICATE BILL
.S ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=Z
Q
DUP(ZZ) ;EP-CHECK FOR DUPLICATE BILLS
; ENTERS WITH BILL NUMBER
I ZZ="" Q ""
N YY,CNT
I '$D(^BARBL(DUZ(2),"B",ZZ)) Q ""
S (CNT,YY)=0
F S YY=$O(^BARBL(DUZ(2),"B",ZZ,YY)) Q:'YY D
. I $D(^BARBOB("BARZZ",BARDUZ,DUZ(2),"I",YY)) Q ;IGNORABLE;MRS:BAR*1.8*6 IM29571
. S CNT=CNT+1
;------------>P.OTT: RETURNS DUP="" FOR MANAGABLE DUP, -26 FOR GHOST
;;;***** NOTE: TMP DISABLED FOR P23 DEC 30 2012 ***
;;;I CNT=2 D FNDD Q QVAL ;CHECK IF ONE OF THESE 2 IS 'GHOST' (NONEX IN 3PB) ?
;;;***** NOTE: TMP DISABLED FOR P23 DEC 30 2012 ***
;<------------P.OTT
I CNT>1 Q -25 ;DUPLICATE
Q ""
FNDD ;
NEW YY1,YY2,BAR3PEIN,BARDUZ3P,QVAL D
. S YY1=$O(^BARBL(DUZ(2),"B",ZZ,0))
. S BAR3PEIN=$P($G(^BARBL(DUZ(2),YY1,0)),"^",17)
. S BARDUZ3P=$P($G(^BARBL(DUZ(2),YY1,0)),"^",22)
. I BAR3PEIN="" S QVAL="" Q
. I BARDUZ3P="" S QVAL="" Q
. I '$D(^ABMDBILL(BARDUZ3P,BAR3PEIN,0)) S QVAL=-26 Q ;GHOST
. S YY2=$O(^BARBL(DUZ(2),"B",ZZ,YY1))
. S BAR3PEIN=$P($G(^BARBL(DUZ(2),YY2,0)),"^",17)
. S BARDUZ3P=$P($G(^BARBL(DUZ(2),YY2,0)),"^",22)
. I BAR3PEIN="" S QVAL="" Q
. I BARDUZ3P="" S QVAL="" Q
. I '$D(^ABMDBILL(BARDUZ3P,BAR3PEIN,0)) S QVAL=-26 Q ;GHOST
. S QVAL=""
. QUIT
Q
BARBEG(X) ;SET BEGINING DATE FROM NOT SET CROSS-REFERENCE
;
N Z
S:BARBG="" BARBG=3070930
S Z=$O(^BARSESS(X,"NS",""))
I Z=""!(Z>BARBG) S Z=BARBG ;IF NO NS X-REF, OR BARBG<NS, USE SESS DATE
Q Z-1
FINDTRAN(BARBLIEN,AMOUNT) ;EP -HEAVILY MODIFIED FOR NEW MATCHING;MRS:BAR*1.8*6 IM29571
;AMOUNT SHOULD BE A NEGATIVE NUMBER
Q:'BARBLIEN 0
N TRANS,TAMOUNT,FOUND,REVDATE,COLDA,ITEMDA,REVSCHED,REVERSAL,BARFLG
S BARFLG=^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRDATE)
I BARFLG=2 D Q $P(REVDATE,".")_U_REVSCHED ;ALREADY MATCHED
.S BARTR0=^BARTR(DUZ(2),TRDATE,1)
.S REVDATE=$P(BARTR0,U,10)
.S REVSCHED=$P(BARTR0,U,11)
S AMOUNT=-AMOUNT ;SET TO ABSOLUTE VALUE
S FOUND=0
S REVERSAL=0 ;NUMBER OF REVERSALS ALREADY SET UP FOR THIS AMOUNT. if even one sent to "ns"
S TRANS=TRDATE ;WORK BACK TO EARLIER TRANSACTIONS
;CHECK FOR MULTIPLES; REVERSAL CAN NOT APPLY TO A FUTURE PAYMENT
F S TRANS=$O(^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRANS),-1) Q:'TRANS D ;CHECK FOR MULTIPLES; REVERSAL CAN NOT APPLY TO A FUTURE PAYMENT
.S BARFLG=^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRANS)
.Q:BARFLG=2 ;ALREADY MATCHED
.S TAMOUNT=$$GET1^DIQ(90050.03,TRANS_",",3.5,"E")
.I TAMOUNT=-AMOUNT,$$GET1^DIQ(90050.03,TRANS_",",110,"I") S REVERSAL=REVERSAL+1
.I TAMOUNT=AMOUNT S FOUND=FOUND+1 D
..S REVDATE=$$GET1^DIQ(90050.03,TRANS_",",.01,"I")
..S COLDA=$$GET1^DIQ(90050.03,TRANS_",",14,"I")
..S ITEMDA=$$GET1^DIQ(90050.03,TRANS_",",15,"I")
..S REVSCHED=$$GET1^DIQ(90051.1101,ITEMDA_","_COLDA_",",20,"I")
..S:REVSCHED="" REVSCHED="PRE-UFMS_COLLECTIONS"
..S REVSCHED=REVSCHED_U_TRANS ;CAPTURE ORIGINAL TX
I REVERSAL>0 S FOUND=0
I FOUND=1 Q $P(REVDATE,".")_U_REVSCHED
Q FOUND
;
CLEAN ;CHECK FOR AND CLEAN POSSIBLE BAD DATA
;FIX ANY TRANSACTION HAS A 0 REVERSAL DATE
I $P($G(^BARTR(DUZ(2),TRDATE,1)),U,10)=0 D DEPOP Q
;
; FIX TRANTYPE = PAYMENT WITH A REVERSAL DATE AND A POSITIVE AMT
I (BARPAY>0!(BARPAY=0)),$P($G(^BARTR(DUZ(2),TRDATE,1)),U,10) D
.D DEPOP
Q
DEPOP ;EP - DE POPULATE IF REVERSAL DATES NOT FOUND
;ONLY FOR BETA SITES
K DIR,DIE,DIC,DA,DR
S DA=TRDATE
S DR="110///@;111///@"
S DIE="^BARTR("_DUZ(2)_","
D ^DIE
K DIR,DIE,DIC,DA,DR
Q
BARUFEX5 ; IHS/SD/TPF - CONTINUATION OF EXPORT -- BUILD BOB FILE ; 09/17/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,5,6,7,23**;OCT 26, 2005
+2 ;NEW ROUTINE; ITEM 1 OF SCR58 1/2/2008 ;MRS:BAR*1.8*4 DD ITEM 4.1.1
+3 ;HEAT54733 APR 2012 P.OTT bug fix <SUBSCRIPT>SETORIG+2^BARUFEX5
+4 ;HEAT93190 DEC 2012 P.OTTIS NOHEAT MARK / IGNORE DUPLICATE GHOST BILLS (SAME PAT, BUT MISSING CLAIM IN 3PB)
+5 ;NOHEAT MAR 2013 P.OTTIS ADDED NEW VA billing
+6 ;
PRE(BARBG,BARDUZ) ;EP;
+1 ;
+2 ; ENTERS WITH TRANSACTION BEGIN DATE
+3 ; AND BARDUZ = DUZ OF USER
+4 ;
+5 KILL ^BARBOB("BARZ",BARDUZ)
+6 KILL ^BARBOB("BARZZ",BARDUZ)
+7 ;MRS:BAR*1.8*6
KILL ^BARZZZ("BARZ")
+8 DO NOW^%DTC
+9 ;FOR RELEASE
SET PRELIVLM=3071001
+10 SET ^BARBOB("BARZ",BARDUZ,"BEGIN")=%
+11 NEW BARX,BARY,BARZ,BARIDT,BART,BARBDA,BARTX,BAR,BARREV,BARFLG,TRDATE
+12 SET SAFEDUZ=DUZ(2)
+13 ;XTMP COUNTER
SET BARTOTX=0
+14 ;BEGIN EXCLUSION CHECKS
+15 ;BUILD FILE OF PAYMENTS IN DATE RANGE
DO SETZZ(BARDUZ)
+16 SET DUZ(2)=0
+17 FOR
SET DUZ(2)=$ORDER(^BARBOB("BARZZ",BARDUZ,DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:1
+18 SET BARBDA=0
+19 FOR
SET BARBDA=$ORDER(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA))
IF 'BARBDA
QUIT
Begin DoDot:2
+20 SET BARBILL=$GET(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA))
+21 ;BILL HAS DA BUT NOT NAME
IF 'BARBILL
QUIT
+22 SET BARBL0=$GET(^BARBL(DUZ(2),BARBDA,0))
+23 SET ABMDUZ2=$PIECE(BARBL0,U,22)
+24 ;NO 3P DUZ(2)
IF 'ABMDUZ2
QUIT
+25 SET ABMIEN=$PIECE(BARBL0,U,17)
+26 ;NO 3P BILL IEN
IF 'ABMIEN
QUIT
+27 ;3P EXCLUSION
IF $$BILL^ABMUEAPI(ABMDUZ2,ABMIEN)<1
QUIT
+28 IF '$$IHS^BARUFUT(ABMDUZ2)
QUIT
+29 ;;;Q:'$$IHSERA^BARUFUT(ABMDUZ2) ;P.OTT
+30 ;A/R BILL, A/R ACCOUNT
SET BARACCT=$$GETBACC^BARUFEXU(BARBDA)
+31 ;NO INSURER
IF 'BARACCT
QUIT
+32 SET D0=BARACCT
+33 ;GET 'VIP INSURER TYPE' CODE (NUMBER)
SET BARITYP=$$VALI^BARVPM(8)
+34 ;EXCLUDE 'INDIAN' OR 'THIRD PARTY BILLING' PER MEETING OF 5/4/2007
IF BARITYP="I"!(BARITYP="T")
QUIT
+35 ; Check 3P transmitted date
+36 ;A/R BILL, PARENT LOCATION
SET BARPLOC=$$GETPLOC
+37 IF 'BARPLOC
QUIT
+38 ;S UFMSSUFC=$$PRELIVE(ABMDUZ2,ABMIEN,BARITYP,BARPLOC) ;MRS:BAR*1.8*7
+39 ;I UFMSSUFC="" Q ;MRS:BAR*1.8*7
+40 ;
TX ;NOW HAVE A BILL TO CHECK
+1 SET TRDATE=0
+2 FOR
SET TRDATE=$ORDER(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE))
IF 'TRDATE
QUIT
Begin DoDot:3
+3 SET IENS=TRDATE_","
+4 ;CREDIT - DEBIT
SET BARPAY=$$GET1^DIQ(90050.03,IENS,3.5,"E")
+5 ;DON'T LOOK AT 0 PAYMENTS
IF BARPAY=0
QUIT
+6 SET BARTX0=$GET(^BARTR(DUZ(2),TRDATE,0))
+7 ;COLLECTION BATCH IEN;GET EXTERNAL NAME LATER
SET BARCB=$PIECE(BARTX0,U,14)
+8 ;COLLECTION ITEM
SET BARCI=$PIECE(BARTX0,U,15)
+9 ;NOT IN BATCH/ITEM
IF BARCB=""!(BARCI="")
QUIT
+10 SET BARZZ0=^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)
+11 ;CHECK FOR -25 CODE FLAG
SET BARFLG=$SELECT(BARZZ0]"":BARZZ0,1:0)
+12 ;INIT ORIGINAL TX
SET (BARREV,BAROTX)=""
+13 ;SCHEDULE NUMBER/IPAC
SET BARIPAC=$$IPAC^BARUFEX4(BARCB,BARCI,IENS)
+14 DO CLEAN
+15 IF BARPAY<0
IF BARFLG'=-25
Begin DoDot:4
+16 ;CHECK REVERSAL
SET BARXPAC=$$REV(BARBDA,BARPAY,BARIPAC)
+17 ;RETURNS CODE_U_RESCHED_U_ORIGTX
+18 ;WHAT FOUND FLAG
SET BARFLG=$PIECE(BARXPAC,U)
+19 SET BARIPAC=$PIECE(BARXPAC,U,2)
+20 ;SIMPLE REVERSAL
IF BARFLG=2
Begin DoDot:5
+21 ;ORIGINAL TRANSACTION
SET BAROTX=$PIECE(BARXPAC,U,3)
+22 ;P.OTT
IF BAROTX=""
QUIT
+23 ;RETURNS ORIGINAL REFERENCES
DO SETORIG(BAROTX,.BARFLG)
+24 SET ^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)=2
End DoDot:5
+25 IF $EXTRACT(BARFLG)="-"
DO CODE(BARBDA,BARFLG)
End DoDot:4
+26 SET ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)=BARPAY_U_BARIPAC_U_BARBDA_U_BARBILL_U_BARFLG
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;CHECK BATCH/ITEM FOR PAIRS
DO COLCK
+28 DO NOW^%DTC
+29 SET ^BARBOB("BARZ",BARDUZ,"END")=%
+30 SET DUZ(2)=SAFEDUZ
+31 QUIT
+32 ;
SETORIG(TRDT,BARFLG) ;FLAG ORIGINAL PAYMENT WHEN SIMPLE REVERSAL IS FOUND
+1 NEW BARO0,BAROCB,BAROCI
+2 SET BARO0=$GET(^BARTR(DUZ(2),TRDT,0))
+3 ;COLLECTION BATCH IEN;GET EXTERNAL NAME LATER
SET BAROCB=$PIECE(BARO0,U,14)
+4 IF 'BAROCB
QUIT
+5 ;COLLECTION ITEM
SET BAROCI=$PIECE(BARO0,U,15)
+6 IF 'BAROCI
QUIT
+7 SET BARFLG=BARFLG_U_BARCB_U_BARCI_U_TRDATE
+8 SET $PIECE(^BARBOB("BARZ",BARDUZ,DUZ(2),BAROCB,BAROCI,TRDT),U,5)=BARFLG
+9 SET BARFLG=BARFLG_U_BAROCB_U_BAROCI_U_TRDT
+10 SET ^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDT)=2
+11 QUIT
+12 ;
COLCK ; NOW BEGIN PAIRS CHECK IN COLLECTION BATCH/ITEM
+1 ;
+2 NEW BARCB,BARCI,TRDATE,BARNEG,BAR,BARPAY,BAR7
+3 SET DUZ(2)=0
+4 FOR
SET DUZ(2)=$ORDER(^BARBOB("BARZ",BARDUZ,DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:1
+5 SET BARCB=0
+6 FOR
SET BARCB=$ORDER(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB))
IF 'BARCB
QUIT
Begin DoDot:2
+7 SET BARCI=0
+8 FOR
SET BARCI=$ORDER(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI))
IF 'BARCI
QUIT
Begin DoDot:3
+9 SET (TRDATE,BARNEG,BAR7)=0
+10 ;CLEAR LOCAL ARRAY
KILL BAR
+11 FOR
SET TRDATE=$ORDER(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE))
IF 'TRDATE
QUIT
Begin DoDot:4
+12 SET BAR0=^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)
+13 SET BARDA=$PIECE(BAR0,U,3)
+14 SET BARFLG=$PIECE(BAR0,U,5)
+15 SET BARFLGZ=$GET(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARDA,TRDATE))
+16 IF BARFLG=0
IF BARFLGZ'=""
SET BARFLG=BARFLGZ
+17 IF $EXTRACT(BARFLG)="-"
Begin DoDot:5
+18 SET $PIECE(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE),U,5)=BARFLG
+19 SET $PIECE(BAR0,U,5)=BARFLG
+20 SET BAR7=3
End DoDot:5
+21 SET BARAMT=$PIECE(BAR0,U,1)
+22 IF BARAMT<0
SET BARNEG=1
+23 SET BAR(TRDATE)=BAR0
End DoDot:4
+24 ;REVERSAL FOUND
IF BARNEG
DO PAIRS(.BAR,BAR7)
QUIT
+25 SET BARFLG=$SELECT(BAR7'=0:2,1:1)
+26 SET ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)=BARFLG
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
PAIRS(BAR,BAR7) ;LOOK FOR OK PAIRS OF PAYMENTS AND REVERSALS
+1 ;BAR STRING = BARPAY_U_BARIPAC_U_BARBDA_U_BARBILL_U_BARFLG
+2 ; I BARFLG=-4 or -7 ;MULTIPLE MATCHES -- DON'T PAIR
+3 ; I BARFLG=-3 or -6 ;ORIGINAL NOT FOUND -- PAIR
+4 ;ADDED CHECK FOR PERMANENT IGNORABLE PAIRS
+5 ; DEF: FIRST PAYMENT IS A REVERSAL
+6 ; SECOND PAYMENT MATCHES REVERSAL
+7 ; AND BOTH ARE IN SAME BILL AND BATCH/ITEM
+8 ;
+9 NEW BARI,BARJ,BARCNT
+10 ;REVERSALS IN BATCH
SET ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)=BAR7
+11 SET BARCNT=0
+12 ;
AGAIN SET BARI=0
I SET BARI=$ORDER(BAR(BARI))
+1 IF 'BARI
QUIT
+2 SET BARCNT=BARCNT+1
+3 SET BARIFLG=$PIECE(BAR(BARI),U,5)
+4 ;FLAGGED AS SIMPLE TX/REV
IF BARIFLG=2
KILL BAR(BARI)
GOTO I
+5 ;COMPLEX OR DUPLICATE
IF BARIFLG=-4!(BARIFLG=-7)!(BARIFLG=-25)
KILL BAR(BARI)
GOTO I
+6 SET BARJ=0
J SET BARJ=$ORDER(BAR(BARJ))
+1 IF 'BARJ
GOTO I
+2 SET BARJFLG=$PIECE(BAR(BARJ),U,5)
+3 ;FLAGGED AS ORIGINAL TX OR REV
IF BARJFLG=2
KILL BAR(BARJ)
GOTO J
+4 ;COMPLEX OR DUPLICATE
IF BARJFLG=-4!(BARJFLG=-7)!(BARJFLG=-25)
KILL BAR(BARI)
GOTO I
+5 ;DON'T CHECK SELF
IF $PIECE(BAR(BARI),U,1,3)=$PIECE(BAR(BARJ),U,1,3)
GOTO J
+6 ;CHECK AMOUNT
+7 SET BARIAMT=$PIECE(BAR(BARI),U)
+8 SET BARJAMT=$PIECE(BAR(BARJ),U)
+9 ;ABSOLUTE AMOUNTS DON'T MATCH
IF BARIAMT'=-BARJAMT
GOTO J
+10 ;CHECK TREAS SCHED #
+11 ;KEEP CHECKING
IF $PIECE(BAR(BARI),U,2)=$PIECE(BAR(BARJ),U,2)
Begin DoDot:1
+12 IF BARCNT=1
Begin DoDot:2
+13 ;NOT MATCHING BILLS
IF $PIECE(BAR(BARI),U,3)'=$PIECE(BAR(BARJ),U,3)
QUIT
+14 ;FOUND IGNORABLE PAIR
IF BARIAMT<0
IF BARJAMT>0
DO PAIR("-I")
End DoDot:2
IF '$DATA(BAR(BARI))
QUIT
+15 DO PAIR(1)
End DoDot:1
GOTO AGAIN
+16 GOTO J
+17 ;
PAIR(Z) ;FOUND A MATCH -- FLAG TRANSACTIONS AS GOOD TO GO OR CODE "-I"
+1 NEW FLG
+2 SET FLG=Z_U_BARCB_U_BARCI_U_BARJ
+3 SET $PIECE(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,BARI),U,5)=FLG
+4 ;REMOVE ENTRY
KILL BAR(BARI)
+5 SET FLG=Z_U_BARCB_U_BARCI_U_BARI
+6 SET $PIECE(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,BARJ),U,5)=FLG
+7 KILL BAR(BARJ)
+8 QUIT
+9 ;
REV(BARBDA,BARPAY,TIPAC) ; FIND SIMPLE REVERSAL SCHEDULE NUMBER ;HEAVILY MODIFIED FOR BAR*1.8*5 IM29449
+1 NEW Y,Z,SCHED,CODE,BARRDT,BARRTDN,BARR1
+2 SET Y=""
+3 SET BARR1=$GET(^BARTR(DUZ(2),TRDATE,1))
+4 ;IGNORE TRANSACTION MRS:BAR*1.8*6 IM29571
IF $PIECE(BARR1,U,12)="I"
QUIT "I"
+5 ;REVERSAL DATE/TIME
SET BARRDT=$PIECE(BARR1,U,10)
+6 ;GET MATCHED TRANSACTION ;NEW CHECK FOR MATCHES BAR*1.8*5 IM29571
IF BARRDT]""
Begin DoDot:1
+7 ;IMCOMPLETE TX DATE; CHECK FURTHER
IF BARRDT'["."
SET BARRDT=""
QUIT
+8 ;REVERSAL TDN/IPAC
SET BARRTDN=$PIECE(BARR1,U,11)
+9 ;S:BARRTDN="" BARRTDN="PRE MODIFICATIONS" ;LEAVE BLANK;MRS:BAR*1.8*6
+10 IF '$GET(^BARTR(DUZ(2),BARRDT,0))
SET REV=0
QUIT
+11 SET TAMT=$$GET1^DIQ(90050.03,BARRDT_",",3.5,"E")
+12 IF +$GET(BARPAY)'=-TAMT
SET REV=0
QUIT
+13 SET REV=$PIECE(BARRDT,".")_U_BARRTDN_U_BARRDT
End DoDot:1
+14 ;
+15 IF BARRDT=""
Begin DoDot:1
+16 ;FIND ORIGINAL RECEIPT
SET REV=$$FINDTRAN(BARBDA,BARPAY)
+17 ; RETURNS REVDATE_U_RESCHED_U_ORIGTX, NUMBER OF MULTIPLES, OR 0 IF CAN'T FIND
End DoDot:1
+18 SET SCHED=$PIECE(REV,U,2)
+19 SET Y=$PIECE($GET(^BARTR(DUZ(2),TRDATE,1)),U,6)
+20 ;
+21 ;CAN'T FIND THE ORIGINAL DATE
IF 'REV
Begin DoDot:1
+22 SET CODE=$SELECT(Y="e":-3,1:-6)
End DoDot:1
QUIT CODE_U_TIPAC
+23 ;MATCHES/REV ARE>1, NOT STRING
IF REV'[U
Begin DoDot:1
+24 SET CODE=$SELECT(Y="e":-4,1:-7)
End DoDot:1
QUIT CODE_U_TIPAC
+25 ;RETURN SCHED AND ORIGINAL TX
QUIT 2_U_$PIECE(REV,U,2,3)
+26 ;
PRELIVE(ABMDUZ2,ABMIEN,BARITYP,BARPLOC) ;
+1 ;MRS:BAR*1.8*7
QUIT
+2 NEW TPBAPDT,TPBEXDT
+3 SET UFMSSUFC=""
+4 ;API 3P APPROVAL DATE
SET TPBAPDT=$$APPRDTTM^ABMUEAPI(ABMDUZ2,ABMIEN)
+5 IF TPBAPDT=""
QUIT UFMSSUFC
+6 ;
+7 ;Prelive logic for 'APPLY TO' or ASUFACASUFAC3PIEN string
+8 ;If Date/Time Approved < 10/1/2007 then UFMSSUFC=$$PRELIVE instead
+9 ;If this is true there will be no delay send at all
+10 ;
+11 ;I TPBAPDT<PRELIVLM D Q UFMSSUFC ;IHS/SD/SDR bar*1.8*4 SCR100
+12 ;IHS/SD/SDR bar*1.8*4 SCR100
SET BAR08DT=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5)
+13 ;IHS/SD/SDR bar*1.8*4 SCR100
IF TPBAPDT<PRELIVLM!(TPBAPDT<BAR08DT)
Begin DoDot:1
+14 ;LOCATION, AREA PTR
SET BARAREA=$$GET1^DIQ(9999999.06,BARPLOC_",",.04,"I")
+15 SET PRELIV=$$PRELIVE^BARUFUT1(BARAREA,BARITYP)
+16 SET UFMSSUFC=PRELIV
End DoDot:1
QUIT UFMSSUFC
+17 ;
+18 SET UFMSSUFC=$$TRANSMIT^ABMUEAPI(ABMDUZ2,ABMIEN)
+19 IF UFMSSUFC=-1
SET UFMSSUFC=""
+20 QUIT UFMSSUFC
+21 ;
GETPLOC() ;
+1 NEW BARPLOC,BARVLOC
+2 ;A/R BILL, PARENT LOCATION
SET BARPLOC=$PIECE(BARBL0,U,8)
+3 IF BARPLOC
QUIT BARPLOC
+4 ;Not found/or bad location
IF 'BARPLOC
Begin DoDot:1
+5 ;A/R BILL, VISIT LOCATION
SET BARVLOC=$PIECE($GET(^BARBL(DUZ(2),BARBDA,1)),U,8)
+6 SET BARPLOC=$$PARENT^BARUFEXU
End DoDot:1
+7 QUIT BARPLOC
+8 ;
SETZZ(BARDUZ) ;CHECK FOR AT LEAST ONE PAYMENT IN DATE RANGE
+1 NEW X,Y,Z,BARBILL,DUP,BARNUM,TRANTYPE
+2 SET DUZ(2)=0
FOR
SET DUZ(2)=$ORDER(^BARTR(DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:1
+3 IF '$$IHS^BARUFUT(DUZ(2))
QUIT
+4 ;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;P.OTT
+5 SET BARBEG=$$BARBEG(DUZ(2))
+6 SET X=0
+7 FOR
SET X=$ORDER(^BARTR(DUZ(2),"AC",X))
IF 'X
QUIT
Begin DoDot:2
+8 SET Y=$ORDER(^BARTR(DUZ(2),"AC",X,""),-1)
+9 ;NO TRANSACTIONS IN DATE RANGE
IF Y'>BARBEG
QUIT
+10 SET Y=0
+11 FOR
SET Y=$ORDER(^BARTR(DUZ(2),"AC",X,Y))
IF 'Y
QUIT
Begin DoDot:3
+12 ;FLAGGED AS IGNORABLE:MRS:BAR*1.8*6 IM29571
IF $PIECE($GET(^BARTR(DUZ(2),Y,1)),U,12)="I"
Begin DoDot:4
+13 ;MRS:BAR*1.8*6 IM29571
SET ^BARBOB("BARZZ",BARDUZ,DUZ(2),"I",X)=""
End DoDot:4
QUIT
+14 SET IENS=Y_","
+15 ;TRANSACTION TYPE
SET TRANTYPE=$$GET1^DIQ(90050.03,IENS_",",101,"E")
+16 ;ONLY WANT PAYMENTS
IF TRANTYPE'="PAYMENT"
QUIT
+17 ;A/R BILL
SET BARBILL=$$GET1^DIQ(90050.03,IENS,4,"E")
+18 ;CHECK FOR DUPLICATE BILLS
SET DUP=$$DUP(BARBILL)
+19 SET ^BARBOB("BARZZ",BARDUZ,DUZ(2),X)=BARBILL
+20 SET ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=DUP
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
CODE(X,Z) ;FLAG ALL TRANSACTIONS FOR BILL WITH CODE -7 AND -4
+1 ; ENTERS WITH X = BARBILL DA
+2 ; Z = CODE = -7 = MULTIPLE MAN TX W/IN BILL
+3 ; -6 = CANNOT FIND ORIG TX W/IN BILL
+4 ; -3 = SAME AS -6 FOR ERA TX
+5 ; -4 = SAME AS -7 FOR ERA TX
+6 NEW Y
+7 SET Y=0
+8 FOR
SET Y=$ORDER(^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y))
IF 'Y
QUIT
Begin DoDot:1
+9 ;HAS SIMPLE REVERSAL
IF Z'=-25
IF ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=2
QUIT
+10 ;DUPLICATE BILL
IF ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=-25
QUIT
+11 SET ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=Z
End DoDot:1
+12 QUIT
DUP(ZZ) ;EP-CHECK FOR DUPLICATE BILLS
+1 ; ENTERS WITH BILL NUMBER
+2 IF ZZ=""
QUIT ""
+3 NEW YY,CNT
+4 IF '$DATA(^BARBL(DUZ(2),"B",ZZ))
QUIT ""
+5 SET (CNT,YY)=0
+6 FOR
SET YY=$ORDER(^BARBL(DUZ(2),"B",ZZ,YY))
IF 'YY
QUIT
Begin DoDot:1
+7 ;IGNORABLE;MRS:BAR*1.8*6 IM29571
IF $DATA(^BARBOB("BARZZ",BARDUZ,DUZ(2),"I",YY))
QUIT
+8 SET CNT=CNT+1
End DoDot:1
+9 ;------------>P.OTT: RETURNS DUP="" FOR MANAGABLE DUP, -26 FOR GHOST
+10 ;;;***** NOTE: TMP DISABLED FOR P23 DEC 30 2012 ***
+11 ;;;I CNT=2 D FNDD Q QVAL ;CHECK IF ONE OF THESE 2 IS 'GHOST' (NONEX IN 3PB) ?
+12 ;;;***** NOTE: TMP DISABLED FOR P23 DEC 30 2012 ***
+13 ;<------------P.OTT
+14 ;DUPLICATE
IF CNT>1
QUIT -25
+15 QUIT ""
FNDD ;
+1 NEW YY1,YY2,BAR3PEIN,BARDUZ3P,QVAL
Begin DoDot:1
+2 SET YY1=$ORDER(^BARBL(DUZ(2),"B",ZZ,0))
+3 SET BAR3PEIN=$PIECE($GET(^BARBL(DUZ(2),YY1,0)),"^",17)
+4 SET BARDUZ3P=$PIECE($GET(^BARBL(DUZ(2),YY1,0)),"^",22)
+5 IF BAR3PEIN=""
SET QVAL=""
QUIT
+6 IF BARDUZ3P=""
SET QVAL=""
QUIT
+7 ;GHOST
IF '$DATA(^ABMDBILL(BARDUZ3P,BAR3PEIN,0))
SET QVAL=-26
QUIT
+8 SET YY2=$ORDER(^BARBL(DUZ(2),"B",ZZ,YY1))
+9 SET BAR3PEIN=$PIECE($GET(^BARBL(DUZ(2),YY2,0)),"^",17)
+10 SET BARDUZ3P=$PIECE($GET(^BARBL(DUZ(2),YY2,0)),"^",22)
+11 IF BAR3PEIN=""
SET QVAL=""
QUIT
+12 IF BARDUZ3P=""
SET QVAL=""
QUIT
+13 ;GHOST
IF '$DATA(^ABMDBILL(BARDUZ3P,BAR3PEIN,0))
SET QVAL=-26
QUIT
+14 SET QVAL=""
+15 QUIT
End DoDot:1
+16 QUIT
BARBEG(X) ;SET BEGINING DATE FROM NOT SET CROSS-REFERENCE
+1 ;
+2 NEW Z
+3 IF BARBG=""
SET BARBG=3070930
+4 SET Z=$ORDER(^BARSESS(X,"NS",""))
+5 ;IF NO NS X-REF, OR BARBG<NS, USE SESS DATE
IF Z=""!(Z>BARBG)
SET Z=BARBG
+6 QUIT Z-1
FINDTRAN(BARBLIEN,AMOUNT) ;EP -HEAVILY MODIFIED FOR NEW MATCHING;MRS:BAR*1.8*6 IM29571
+1 ;AMOUNT SHOULD BE A NEGATIVE NUMBER
+2 IF 'BARBLIEN
QUIT 0
+3 NEW TRANS,TAMOUNT,FOUND,REVDATE,COLDA,ITEMDA,REVSCHED,REVERSAL,BARFLG
+4 SET BARFLG=^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRDATE)
+5 ;ALREADY MATCHED
IF BARFLG=2
Begin DoDot:1
+6 SET BARTR0=^BARTR(DUZ(2),TRDATE,1)
+7 SET REVDATE=$PIECE(BARTR0,U,10)
+8 SET REVSCHED=$PIECE(BARTR0,U,11)
End DoDot:1
QUIT $PIECE(REVDATE,".")_U_REVSCHED
+9 ;SET TO ABSOLUTE VALUE
SET AMOUNT=-AMOUNT
+10 SET FOUND=0
+11 ;NUMBER OF REVERSALS ALREADY SET UP FOR THIS AMOUNT. if even one sent to "ns"
SET REVERSAL=0
+12 ;WORK BACK TO EARLIER TRANSACTIONS
SET TRANS=TRDATE
+13 ;CHECK FOR MULTIPLES; REVERSAL CAN NOT APPLY TO A FUTURE PAYMENT
+14 ;CHECK FOR MULTIPLES; REVERSAL CAN NOT APPLY TO A FUTURE PAYMENT
FOR
SET TRANS=$ORDER(^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRANS),-1)
IF 'TRANS
QUIT
Begin DoDot:1
+15 SET BARFLG=^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRANS)
+16 ;ALREADY MATCHED
IF BARFLG=2
QUIT
+17 SET TAMOUNT=$$GET1^DIQ(90050.03,TRANS_",",3.5,"E")
+18 IF TAMOUNT=-AMOUNT
IF $$GET1^DIQ(90050.03,TRANS_",",110,"I")
SET REVERSAL=REVERSAL+1
+19 IF TAMOUNT=AMOUNT
SET FOUND=FOUND+1
Begin DoDot:2
+20 SET REVDATE=$$GET1^DIQ(90050.03,TRANS_",",.01,"I")
+21 SET COLDA=$$GET1^DIQ(90050.03,TRANS_",",14,"I")
+22 SET ITEMDA=$$GET1^DIQ(90050.03,TRANS_",",15,"I")
+23 SET REVSCHED=$$GET1^DIQ(90051.1101,ITEMDA_","_COLDA_",",20,"I")
+24 IF REVSCHED=""
SET REVSCHED="PRE-UFMS_COLLECTIONS"
+25 ;CAPTURE ORIGINAL TX
SET REVSCHED=REVSCHED_U_TRANS
End DoDot:2
End DoDot:1
+26 IF REVERSAL>0
SET FOUND=0
+27 IF FOUND=1
QUIT $PIECE(REVDATE,".")_U_REVSCHED
+28 QUIT FOUND
+29 ;
CLEAN ;CHECK FOR AND CLEAN POSSIBLE BAD DATA
+1 ;FIX ANY TRANSACTION HAS A 0 REVERSAL DATE
+2 IF $PIECE($GET(^BARTR(DUZ(2),TRDATE,1)),U,10)=0
DO DEPOP
QUIT
+3 ;
+4 ; FIX TRANTYPE = PAYMENT WITH A REVERSAL DATE AND A POSITIVE AMT
+5 IF (BARPAY>0!(BARPAY=0))
IF $PIECE($GET(^BARTR(DUZ(2),TRDATE,1)),U,10)
Begin DoDot:1
+6 DO DEPOP
End DoDot:1
+7 QUIT
DEPOP ;EP - DE POPULATE IF REVERSAL DATES NOT FOUND
+1 ;ONLY FOR BETA SITES
+2 KILL DIR,DIE,DIC,DA,DR
+3 SET DA=TRDATE
+4 SET DR="110///@;111///@"
+5 SET DIE="^BARTR("_DUZ(2)_","
+6 DO ^DIE
+7 KILL DIR,DIE,DIC,DA,DR
+8 QUIT
