BAREDBPR ; IHS/SD/SDR - AR ERA Batch/Item matching ; 01/30/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**20,21**;OCT 26,2005
Q
EN ;
I $G(DUZ(2))="" D Q
. W !!,"Check your DUZ setup."
. D EOP^BARUTL(1)
W !,"Matching ERA 835 to A/R Collection Batch & Items..."
D SELFL^BAREDP00
I Y'>0 Q
;IHS/SD/TPF 8/22/2001 BAR*1.8*21 5010
I TRNAME[("5010") D EN^BAR50BPR Q
;END BAR*1.8*21
W !,"I will begin matching the following items:"
H 1
I TRNAME["HIPAA" D Q:'+BARCKIEN
. S BARCKIEN=$$CHECK^BAREDP09(IMPDA)
;IHS/SD/TPF BAR*1.8*21 ADD PLB LISTING TO BPR OPTION PER PAGE 10 5010 SPECS
S $P(DASH,"=",81)=""
N BARNOW
D NOW^%DTC
S Y=% X ^DD("DD")
S BARNOW=Y
D SEP^BAR50PA1(IMPDA)
S PAGENO=0
D PLBHDR
S GRANDTOT=0 ;GRAND TOTAL
S DATETOT=0 ;TOTAL BY FY DATE
S LSTDATE=""
S SEGDA=0
F S SEGDA=$O(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA)) Q:'SEGDA D
.Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E)'="PLB"
.S PLBDATA=$G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1))
.S NPI=$P($G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,2)
.S FYDATE=$P($G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,3)
.I FYDATE'=LSTDATE S DATETOT=0
.S LSTDATE=FYDATE
.S X=FYDATE D DT^BAR50P02 S FYDATE=X
.;W !,$G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1))
.W !!?3,NPI
.W ?20,FYDATE
.;PLB SEPARATOR - WILL BE THE SUB-ELEMENT SEPARATOR OR VARIABLE SE
.S LENGTH=$L($G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E)
.;GET ALL THE CODES IN THE PLB SEGMENT
.S COUNT=1
.F PIECE=4:2:LENGTH D
..S PLBCODE=$P($G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,PIECE,PIECE+1)
..;W !,PLBCODE
..S CD=$P(PLBCODE,SE)
..I CD[E S CD=$P(CD,E)
..S CDAMT=$P(PLBCODE,E,2)
..S PLBREFID=$P($P(PLBCODE,E),SE,2)
..W !,COUNT
..W ?14,$J($FN(CDAMT,",",2),10)
..W ?26,CD
..S DESC=$$DESC(CD)
..W ?30,DESC
..W ?50,PLBREFID
..S DATETOT=DATETOT+CDAMT
..S GRANDTOT=GRANDTOT+CDAMT
..S COUNT=COUNT+1
.W !?10,"---------------"
.W !?14,$J($FN(DATETOT,",",2),10)
.S DATETOT=0
.;I $Y>20 D EOP^BARUTL(1)
W !?10,"---------------"
W !?14,$J($FN(GRANDTOT,",",2),10)
D EOP^BARUTL(1)
D CLNUP
Q
DESC(CD) ;EP - GET DESCRIPTION OF CODE
S TBLIEN=$O(^BARETBL("B","Adjustment Reason Code",""))
S CODEIEN=$O(^BARETBL(TBLIEN,1,"B",CD,""))
S CD=$P(^BARETBL(TBLIEN,1,CODEIEN,0),U,2)
Q CD
;END BAR*1.8*21
;
PLBHDR ;EP - PLB REPORT HEADER
S PAGENO=PAGENO+1
;W @IOF ;ADRIAN WANTED FF TAKEN OUT
W !!
W DASH
W "PLB DETAIL REPORT"
W ?45,BARNOW
W ?70,"PAGE ",PAGENO
W !,$G(BAR("HD",1))
W !,$G(BAR("HD",2))
W !,DASH
;PRINT COLUMNS
W !?5,"NPI",?20,"FY DATE"
W !,"NO",?10,"AMOUNT",?24,"CD",?30,"DESCRIPTION",?45,"REFERENCE ID"
W !,DASH
Q
; *********************************************************************
;
CLNUP ; Cleanup variables
I $G(IMPDA) L -^BAREDI("I",IMPDA) ;BAR*1.8*5 SRS-80 IHS/SD/TPF
K XBDIR,X,Y,HSTFILE,ANS,IMPDA,TRDA,DATM,SEQ,TNAME
K HSTIME,BARCOL,BARITM
Q
BAREDBPR ; IHS/SD/SDR - AR ERA Batch/Item matching ; 01/30/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**20,21**;OCT 26,2005
+2 QUIT
EN ;
+1 IF $GET(DUZ(2))=""
Begin DoDot:1
+2 WRITE !!,"Check your DUZ setup."
+3 DO EOP^BARUTL(1)
End DoDot:1
QUIT
+4 WRITE !,"Matching ERA 835 to A/R Collection Batch & Items..."
+5 DO SELFL^BAREDP00
+6 IF Y'>0
QUIT
+7 ;IHS/SD/TPF 8/22/2001 BAR*1.8*21 5010
+8 IF TRNAME[("5010")
DO EN^BAR50BPR
QUIT
+9 ;END BAR*1.8*21
+10 WRITE !,"I will begin matching the following items:"
+11 HANG 1
+12 IF TRNAME["HIPAA"
Begin DoDot:1
+13 SET BARCKIEN=$$CHECK^BAREDP09(IMPDA)
End DoDot:1
IF '+BARCKIEN
QUIT
+14 ;IHS/SD/TPF BAR*1.8*21 ADD PLB LISTING TO BPR OPTION PER PAGE 10 5010 SPECS
+15 SET $PIECE(DASH,"=",81)=""
+16 NEW BARNOW
+17 DO NOW^%DTC
+18 SET Y=%
XECUTE ^DD("DD")
+19 SET BARNOW=Y
+20 DO SEP^BAR50PA1(IMPDA)
+21 SET PAGENO=0
+22 DO PLBHDR
+23 ;GRAND TOTAL
SET GRANDTOT=0
+24 ;TOTAL BY FY DATE
SET DATETOT=0
+25 SET LSTDATE=""
+26 SET SEGDA=0
+27 FOR
SET SEGDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA))
IF 'SEGDA
QUIT
Begin DoDot:1
+28 IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E)'="PLB"
QUIT
+29 SET PLBDATA=$GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1))
+30 SET NPI=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,2)
+31 SET FYDATE=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,3)
+32 IF FYDATE'=LSTDATE
SET DATETOT=0
+33 SET LSTDATE=FYDATE
+34 SET X=FYDATE
DO DT^BAR50P02
SET FYDATE=X
+35 ;W !,$G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1))
+36 WRITE !!?3,NPI
+37 WRITE ?20,FYDATE
+38 ;PLB SEPARATOR - WILL BE THE SUB-ELEMENT SEPARATOR OR VARIABLE SE
+39 SET LENGTH=$LENGTH($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E)
+40 ;GET ALL THE CODES IN THE PLB SEGMENT
+41 SET COUNT=1
+42 FOR PIECE=4:2:LENGTH
Begin DoDot:2
+43 SET PLBCODE=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,PIECE,PIECE+1)
+44 ;W !,PLBCODE
+45 SET CD=$PIECE(PLBCODE,SE)
+46 IF CD[E
SET CD=$PIECE(CD,E)
+47 SET CDAMT=$PIECE(PLBCODE,E,2)
+48 SET PLBREFID=$PIECE($PIECE(PLBCODE,E),SE,2)
+49 WRITE !,COUNT
+50 WRITE ?14,$JUSTIFY($FNUMBER(CDAMT,",",2),10)
+51 WRITE ?26,CD
+52 SET DESC=$$DESC(CD)
+53 WRITE ?30,DESC
+54 WRITE ?50,PLBREFID
+55 SET DATETOT=DATETOT+CDAMT
+56 SET GRANDTOT=GRANDTOT+CDAMT
+57 SET COUNT=COUNT+1
End DoDot:2
+58 WRITE !?10,"---------------"
+59 WRITE !?14,$JUSTIFY($FNUMBER(DATETOT,",",2),10)
+60 SET DATETOT=0
+61 ;I $Y>20 D EOP^BARUTL(1)
End DoDot:1
+62 WRITE !?10,"---------------"
+63 WRITE !?14,$JUSTIFY($FNUMBER(GRANDTOT,",",2),10)
+64 DO EOP^BARUTL(1)
+65 DO CLNUP
+66 QUIT
DESC(CD) ;EP - GET DESCRIPTION OF CODE
+1 SET TBLIEN=$ORDER(^BARETBL("B","Adjustment Reason Code",""))
+2 SET CODEIEN=$ORDER(^BARETBL(TBLIEN,1,"B",CD,""))
+3 SET CD=$PIECE(^BARETBL(TBLIEN,1,CODEIEN,0),U,2)
+4 QUIT CD
+5 ;END BAR*1.8*21
+6 ;
PLBHDR ;EP - PLB REPORT HEADER
+1 SET PAGENO=PAGENO+1
+2 ;W @IOF ;ADRIAN WANTED FF TAKEN OUT
+3 WRITE !!
+4 WRITE DASH
+5 WRITE "PLB DETAIL REPORT"
+6 WRITE ?45,BARNOW
+7 WRITE ?70,"PAGE ",PAGENO
+8 WRITE !,$GET(BAR("HD",1))
+9 WRITE !,$GET(BAR("HD",2))
+10 WRITE !,DASH
+11 ;PRINT COLUMNS
+12 WRITE !?5,"NPI",?20,"FY DATE"
+13 WRITE !,"NO",?10,"AMOUNT",?24,"CD",?30,"DESCRIPTION",?45,"REFERENCE ID"
+14 WRITE !,DASH
+15 QUIT
+16 ; *********************************************************************
+17 ;
CLNUP ; Cleanup variables
+1 ;BAR*1.8*5 SRS-80 IHS/SD/TPF
IF $GET(IMPDA)
LOCK -^BAREDI("I",IMPDA)
+2 KILL XBDIR,X,Y,HSTFILE,ANS,IMPDA,TRDA,DATM,SEQ,TNAME
+3 KILL HSTIME,BARCOL,BARITM
+4 QUIT
