BARUFEX3 ; IHS/SD/TPF - CONTINUATION OF EXPORT TO PROCESS PAYMENTS ;10/31/08
;;1.8;IHS ACCOUNTS RECEIVABLE;**4,6,7,8,23**;OCT 26, 2005
;NEW ROUTINE ;ITEM 1 OF SCR58 1/2/2008
;BAR*1.8*4 DD ITEM 4.1.1
;
REVERSAL() ;EP; CHECK REVERSAL DATES AND FIX IF POSSIBLE
; RETURNS ORIGINAL SCHEDULE NUMBER IF REVERSAL
;
; FIX ANY TRANSACTION HAS A 0 REVERSAL DATE
I $P($G(^BARTR(DUZ(2),TRDATE,1)),U,10)=0 D DEPOP ;CLEAN BAD DATA
;
; FIX TRANTYPE NOT = PAYMENT WITH A REVERSAL DATE
I TRANTYPE='"PAYMENT",($P($G(^BARTR(DUZ(2),TRDATE,1)),U,10)) D Q ""
.D DEPOP
;
; FIX TRANTYPE = PAYMENT WITH A REVERSAL DATE AND A POSITIVE AMT
I (ARCRDEB>0!(ARCRDEB=0)),$P($G(^BARTR(DUZ(2),TRDATE,1)),U,10) D Q ""
.D DEPOP
;
; ONLY LOOK AT PAYMENTS
I TRANTYPE'="PAYMENT" Q ""
;
; CHECK FOR BATCH
I ARCOLITM=""!(ARCOLIN="") D Q "" ;NOT OK
ERR23 .D ERR^BARUFEXU(23) ;NO BATCH IN TX
.S ARBILL=""
;
; CHECK BOB FOR CODES
N SCHED,BARFLG,BARZ0
S BARZ0=$G(^BARBOB("BARZ",BARDUZ,DUZ(2),ARCOLIN,ARCOLITM,TRDATE))
S BARFLG=$P(BARZ0,U,5) ;PAIR OR -ERROR FLAG
S SCHED=$$IPAC^BARUFEX4(ARCOLIN,ARCOLITM,TRDATE_",")
I '$$CKIPAC(SCHED) Q "" ;BAD IPAC ERROR 5
IGNORE I BARFLG="-I" D Q "" ;PERMANENTLY IGNORABLE PAIR
.D SETI
.D ERR^BARUFEXU("I")
.S ARBILL=""
I BARFLG=1 D POP Q SCHED ;ORIGINAL NOT IN BILL, BUT PAIRED IN BATCH/ITEM
I BARFLG=2 D POP Q SCHED ;SIMPLE REVERSAL ALREADY PAIRED
ERRNEG I $E(BARFLG)="-" D Q "" ;ONE OF THE MINUS CODES
.D ERR^BARUFEXU(-BARFLG)
.S ARBILL=""
;
;CHECK +DOLLAR PAYMENTS FOR REVERSALS THEN QUIT
I ARCRDEB>0 D Q SCHED
.S BAROK=$$COLCK^BARUFEX4(BARDUZ) ;BATCH/ITEM CHECK
.I 'BAROK S (ARBILL,SCHED)="" ;DIDN'T FIND MATCH
;
DIAG ;NOTHING SHOULD REACH THIS POINT AFTER NEW CODING
DIAG1 W !!,"*** ERROR **** ENTERING CHECK FOR ERA OR MANUAL REVERSALS "
W !?5,UDUZ," ",TRDATE," ",ARBILLIN," ",BARZ0
S ARBILL=""
Q ""
;
POP ;POPULATE THE REVERSAL FIELDS
S SCHED=$P(BARZ0,U,2) ;GET MATCHED TDN/IPAC
S DA=TRDATE
S DIE="^BARTR("_DUZ(2)_","
;S DR="110////"_$P($P(BARZ0,U,8),".",1) ;MRS:BAR*1.8*6 IM29571
S DR="110////"_$P(BARZ0,U,11) ;MRS:BAR*1.8*6 IM29571
S DR=DR_";111////"_SCHED
D ^DIE
K DIR,DR,DIC,DA,DIE
Q
SETI ;POPULATE THE IGNORE TRANSACTION FIELD
S DA=TRDATE
S DIE="^BARTR("_DUZ(2)_","
S DR="112////I"
D ^DIE
K DIR,DR,DIC,DA,DIE
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
;
GOODIPAC(X) ;EP - INPUT TRANSFORM FOR TREASURY SCHEDULE NUMBER/IPAC
N Z
I X="NONPAYMENT" Q 1
I X="PRE-UFMS_COLLECTIONS" Q 1
S Z=$$UPC^BARUTL(X)
S Z=$TR(Z,"-,")
I Z["NON" Q 0 ;CHECK FOR NON IN ANY FORM
I $L(X)>5,$L(X)<21,X?.UN Q 1 ;MIN/MAX MIXED ALPHA/NUMERIC ;MRS:BAR*1.8*7 IM30201
I $L(X)<6!($L(X)>20) Q 0 ;MIN/MAX CHECK ;MRS:BAR*1.8*7 IM30201
;RE-WRITTEN TO ALLOW FY# PREFIX ;MRS:BAR*1.8*8 D150
;I $E(X,1,2)?1U1"-",$E(X,3,20)?.UN Q 1 ;IPAC WITH DASH AND MIXED ALPHA/NUMERIC ;MRS:BAR*1.8*7 IM30201;MRS:BAR*1.8*8
N ZZ
S ZZ=X
I $E(Z,1,2)="FY" S ZZ=$E(X,4,20) ;ALLOW FY# PREFIX ;MRS:BAR*1.8*8 D150
I $E(ZZ,1,2)?1U1"-",$E(ZZ,3,20)?.UN Q 1 ;MRS:BAR*1.8*8 D150
I X?.UN Q 1 ;STRAIGHT MIXED ALPHA/NUMERIC ;MRS:BAR*1.8*7 IM30201
Q 0
;
FINDREV ;EP - FIND REVERSALS ON THE SYSTEM - THIS IS FOR TESTING ONLY
N TEMPDUZ2,TRDATE,REVDATE,SCHEDNUM,ARCOL,ARITEM,SOURCE
N TRANTYPE,CREDDEB
S TEMPDUZ2=DUZ(2)
S DUZ(2)=1
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 FACILITY=$$GET1^DIQ(9999999.06,DUZ(2)_",",.01,"E")
.S TRDATE=0
.F S TRDATE=$O(^BARTR(DUZ(2),TRDATE)) Q:'TRDATE D
..S REVDATE=$$GET1^DIQ(90050.03,TRDATE_",",110)
..S SCHEDNUM=$$GET1^DIQ(90050.03,TRDATE_",",111)
..Q:SCHEDNUM=""&(REVDATE="")
..S SOURCE=$$GET1^DIQ(90050.03,TRDATE_",",106)
..S ARBILL=$$GET1^DIQ(90050.03,TRDATE_",",4)
..S TRANTYPE=$$GET1^DIQ(90050.03,TRDATE_",",101)
..S ARCOL=$$GET1^DIQ(90050.03,TRDATE_",",14)
..S ARITEM=$$GET1^DIQ(90050.03,TRDATE_",",15)
..S ARCRDEB=$$GET1^DIQ(90050.03,TRDATE,3.5,"E")
..W !!!,"FACILITY: ",FACILITY
..W !,"BILL: ",ARBILL
..W !,"TRDATE: ",TRDATE
..W !,"TRANTYPE: ",TRANTYPE
..W !,"REVDATE: ",REVDATE
..W !,"SCHEDNUM: ",SCHEDNUM
..W !,"ARCOL: ",ARCOL
..W !,"ARITEM: ",ARITEM
..W !,"SOURCE: ",SOURCE
..W !,"CREDIT-DEBIT: ",ARCRDEB
S DUZ(2)=TEMPDUZ2
Q
CKIPAC(X) ;
;ENTERS WITH X = SCHEDULE NUMBER
;
I '$$GOODIPAC(X) D Q 0 ;STILL NOT AN ACCEPTABLE SCHEDULE # FORMAT
ERR5 .D ERR^BARUFEXU(5) ;Bad schedule number
.S ARBILL=""
Q 1
BARUFEX3 ; IHS/SD/TPF - CONTINUATION OF EXPORT TO PROCESS PAYMENTS ;10/31/08
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,6,7,8,23**;OCT 26, 2005
+2 ;NEW ROUTINE ;ITEM 1 OF SCR58 1/2/2008
+3 ;BAR*1.8*4 DD ITEM 4.1.1
+4 ;
REVERSAL() ;EP; CHECK REVERSAL DATES AND FIX IF POSSIBLE
+1 ; RETURNS ORIGINAL SCHEDULE NUMBER IF REVERSAL
+2 ;
+3 ; FIX ANY TRANSACTION HAS A 0 REVERSAL DATE
+4 ;CLEAN BAD DATA
IF $PIECE($GET(^BARTR(DUZ(2),TRDATE,1)),U,10)=0
DO DEPOP
+5 ;
+6 ; FIX TRANTYPE NOT = PAYMENT WITH A REVERSAL DATE
+7 IF TRANTYPE='"PAYMENT"
IF ($PIECE($GET(^BARTR(DUZ(2),TRDATE,1)),U,10))
Begin DoDot:1
+8 DO DEPOP
End DoDot:1
QUIT ""
+9 ;
+10 ; FIX TRANTYPE = PAYMENT WITH A REVERSAL DATE AND A POSITIVE AMT
+11 IF (ARCRDEB>0!(ARCRDEB=0))
IF $PIECE($GET(^BARTR(DUZ(2),TRDATE,1)),U,10)
Begin DoDot:1
+12 DO DEPOP
End DoDot:1
QUIT ""
+13 ;
+14 ; ONLY LOOK AT PAYMENTS
+15 IF TRANTYPE'="PAYMENT"
QUIT ""
+16 ;
+17 ; CHECK FOR BATCH
+18 ;NOT OK
IF ARCOLITM=""!(ARCOLIN="")
Begin DoDot:1
ERR23 ;NO BATCH IN TX
DO ERR^BARUFEXU(23)
+1 SET ARBILL=""
End DoDot:1
QUIT ""
+2 ;
+3 ; CHECK BOB FOR CODES
+4 NEW SCHED,BARFLG,BARZ0
+5 SET BARZ0=$GET(^BARBOB("BARZ",BARDUZ,DUZ(2),ARCOLIN,ARCOLITM,TRDATE))
+6 ;PAIR OR -ERROR FLAG
SET BARFLG=$PIECE(BARZ0,U,5)
+7 SET SCHED=$$IPAC^BARUFEX4(ARCOLIN,ARCOLITM,TRDATE_",")
+8 ;BAD IPAC ERROR 5
IF '$$CKIPAC(SCHED)
QUIT ""
IGNORE ;PERMANENTLY IGNORABLE PAIR
IF BARFLG="-I"
Begin DoDot:1
+1 DO SETI
+2 DO ERR^BARUFEXU("I")
+3 SET ARBILL=""
End DoDot:1
QUIT ""
+4 ;ORIGINAL NOT IN BILL, BUT PAIRED IN BATCH/ITEM
IF BARFLG=1
DO POP
QUIT SCHED
+5 ;SIMPLE REVERSAL ALREADY PAIRED
IF BARFLG=2
DO POP
QUIT SCHED
ERRNEG ;ONE OF THE MINUS CODES
IF $EXTRACT(BARFLG)="-"
Begin DoDot:1
+1 DO ERR^BARUFEXU(-BARFLG)
+2 SET ARBILL=""
End DoDot:1
QUIT ""
+3 ;
+4 ;CHECK +DOLLAR PAYMENTS FOR REVERSALS THEN QUIT
+5 IF ARCRDEB>0
Begin DoDot:1
+6 ;BATCH/ITEM CHECK
SET BAROK=$$COLCK^BARUFEX4(BARDUZ)
+7 ;DIDN'T FIND MATCH
IF 'BAROK
SET (ARBILL,SCHED)=""
End DoDot:1
QUIT SCHED
+8 ;
DIAG ;NOTHING SHOULD REACH THIS POINT AFTER NEW CODING
DIAG1 WRITE !!,"*** ERROR **** ENTERING CHECK FOR ERA OR MANUAL REVERSALS "
+1 WRITE !?5,UDUZ," ",TRDATE," ",ARBILLIN," ",BARZ0
+2 SET ARBILL=""
+3 QUIT ""
+4 ;
POP ;POPULATE THE REVERSAL FIELDS
+1 ;GET MATCHED TDN/IPAC
SET SCHED=$PIECE(BARZ0,U,2)
+2 SET DA=TRDATE
+3 SET DIE="^BARTR("_DUZ(2)_","
+4 ;S DR="110////"_$P($P(BARZ0,U,8),".",1) ;MRS:BAR*1.8*6 IM29571
+5 ;MRS:BAR*1.8*6 IM29571
SET DR="110////"_$PIECE(BARZ0,U,11)
+6 SET DR=DR_";111////"_SCHED
+7 DO ^DIE
+8 KILL DIR,DR,DIC,DA,DIE
+9 QUIT
SETI ;POPULATE THE IGNORE TRANSACTION FIELD
+1 SET DA=TRDATE
+2 SET DIE="^BARTR("_DUZ(2)_","
+3 SET DR="112////I"
+4 DO ^DIE
+5 KILL DIR,DR,DIC,DA,DIE
+6 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
+9 ;
GOODIPAC(X) ;EP - INPUT TRANSFORM FOR TREASURY SCHEDULE NUMBER/IPAC
+1 NEW Z
+2 IF X="NONPAYMENT"
QUIT 1
+3 IF X="PRE-UFMS_COLLECTIONS"
QUIT 1
+4 SET Z=$$UPC^BARUTL(X)
+5 SET Z=$TRANSLATE(Z,"-,")
+6 ;CHECK FOR NON IN ANY FORM
IF Z["NON"
QUIT 0
+7 ;MIN/MAX MIXED ALPHA/NUMERIC ;MRS:BAR*1.8*7 IM30201
IF $LENGTH(X)>5
IF $LENGTH(X)<21
IF X?.UN
QUIT 1
+8 ;MIN/MAX CHECK ;MRS:BAR*1.8*7 IM30201
IF $LENGTH(X)<6!($LENGTH(X)>20)
QUIT 0
+9 ;RE-WRITTEN TO ALLOW FY# PREFIX ;MRS:BAR*1.8*8 D150
+10 ;I $E(X,1,2)?1U1"-",$E(X,3,20)?.UN Q 1 ;IPAC WITH DASH AND MIXED ALPHA/NUMERIC ;MRS:BAR*1.8*7 IM30201;MRS:BAR*1.8*8
+11 NEW ZZ
+12 SET ZZ=X
+13 ;ALLOW FY# PREFIX ;MRS:BAR*1.8*8 D150
IF $EXTRACT(Z,1,2)="FY"
SET ZZ=$EXTRACT(X,4,20)
+14 ;MRS:BAR*1.8*8 D150
IF $EXTRACT(ZZ,1,2)?1U1"-"
IF $EXTRACT(ZZ,3,20)?.UN
QUIT 1
+15 ;STRAIGHT MIXED ALPHA/NUMERIC ;MRS:BAR*1.8*7 IM30201
IF X?.UN
QUIT 1
+16 QUIT 0
+17 ;
FINDREV ;EP - FIND REVERSALS ON THE SYSTEM - THIS IS FOR TESTING ONLY
+1 NEW TEMPDUZ2,TRDATE,REVDATE,SCHEDNUM,ARCOL,ARITEM,SOURCE
+2 NEW TRANTYPE,CREDDEB
+3 SET TEMPDUZ2=DUZ(2)
+4 SET DUZ(2)=1
+5 FOR
SET DUZ(2)=$ORDER(^BARTR(DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:1
+6 IF '$$IHS^BARUFUT(DUZ(2))
QUIT
+7 ;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;P.OTT
+8 SET FACILITY=$$GET1^DIQ(9999999.06,DUZ(2)_",",.01,"E")
+9 SET TRDATE=0
+10 FOR
SET TRDATE=$ORDER(^BARTR(DUZ(2),TRDATE))
IF 'TRDATE
QUIT
Begin DoDot:2
+11 SET REVDATE=$$GET1^DIQ(90050.03,TRDATE_",",110)
+12 SET SCHEDNUM=$$GET1^DIQ(90050.03,TRDATE_",",111)
+13 IF SCHEDNUM=""&(REVDATE="")
QUIT
+14 SET SOURCE=$$GET1^DIQ(90050.03,TRDATE_",",106)
+15 SET ARBILL=$$GET1^DIQ(90050.03,TRDATE_",",4)
+16 SET TRANTYPE=$$GET1^DIQ(90050.03,TRDATE_",",101)
+17 SET ARCOL=$$GET1^DIQ(90050.03,TRDATE_",",14)
+18 SET ARITEM=$$GET1^DIQ(90050.03,TRDATE_",",15)
+19 SET ARCRDEB=$$GET1^DIQ(90050.03,TRDATE,3.5,"E")
+20 WRITE !!!,"FACILITY: ",FACILITY
+21 WRITE !,"BILL: ",ARBILL
+22 WRITE !,"TRDATE: ",TRDATE
+23 WRITE !,"TRANTYPE: ",TRANTYPE
+24 WRITE !,"REVDATE: ",REVDATE
+25 WRITE !,"SCHEDNUM: ",SCHEDNUM
+26 WRITE !,"ARCOL: ",ARCOL
+27 WRITE !,"ARITEM: ",ARITEM
+28 WRITE !,"SOURCE: ",SOURCE
+29 WRITE !,"CREDIT-DEBIT: ",ARCRDEB
End DoDot:2
End DoDot:1
+30 SET DUZ(2)=TEMPDUZ2
+31 QUIT
CKIPAC(X) ;
+1 ;ENTERS WITH X = SCHEDULE NUMBER
+2 ;
+3 ;STILL NOT AN ACCEPTABLE SCHEDULE # FORMAT
IF '$$GOODIPAC(X)
Begin DoDot:1
ERR5 ;Bad schedule number
DO ERR^BARUFEXU(5)
+1 SET ARBILL=""
End DoDot:1
QUIT 0
+2 QUIT 1
