BAR50BPR ; IHS/SD/SDR - AR ERA Batch/Item matching ; 01/30/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**20,21**;OCT 26,2005
Q
EN ;
;IHS/SD/TPF 8/22/2011 BAR*1.8*21
;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^BAR50P00
;I Y'>0 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^BAR50P09(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
BAR50BPR ; 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 ;IHS/SD/TPF 8/22/2011 BAR*1.8*21
+2 ;I $G(DUZ(2))="" D Q
+3 ;. W !!,"Check your DUZ setup."
+4 ;. D EOP^BARUTL(1)
+5 ;W !,"Matching ERA 835 to A/R Collection Batch & Items..."
+6 ;D SELFL^BAR50P00
+7 ;I Y'>0 Q
+8 ;END BAR*1.8*21
+9 WRITE !,"I will begin matching the following items:"
+10 HANG 1
+11 IF TRNAME["HIPAA"
Begin DoDot:1
+12 SET BARCKIEN=$$CHECK^BAR50P09(IMPDA)
End DoDot:1
IF '+BARCKIEN
QUIT
+13 ;IHS/SD/TPF BAR*1.8*21 ADD PLB LISTING TO BPR OPTION PER PAGE 10 5010 SPECS
+14 SET $PIECE(DASH,"=",81)=""
+15 NEW BARNOW
+16 DO NOW^%DTC
+17 SET Y=%
XECUTE ^DD("DD")
+18 SET BARNOW=Y
+19 DO SEP^BAR50PA1(IMPDA)
+20 SET PAGENO=0
+21 DO PLBHDR
+22 ;GRAND TOTAL
SET GRANDTOT=0
+23 ;TOTAL BY FY DATE
SET DATETOT=0
+24 SET LSTDATE=""
+25 SET SEGDA=0
+26 FOR
SET SEGDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA))
IF 'SEGDA
QUIT
Begin DoDot:1
+27 IF $PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E)'="PLB"
QUIT
+28 SET PLBDATA=$GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1))
+29 SET NPI=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,2)
+30 SET FYDATE=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,3)
+31 IF FYDATE'=LSTDATE
SET DATETOT=0
+32 SET LSTDATE=FYDATE
+33 SET X=FYDATE
DO DT^BAR50P02
SET FYDATE=X
+34 ;W !,$G(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1))
+35 WRITE !!?3,NPI
+36 WRITE ?20,FYDATE
+37 ;PLB SEPARATOR - WILL BE THE SUB-ELEMENT SEPARATOR OR VARIABLE SE
+38 SET LENGTH=$LENGTH($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E)
+39 ;GET ALL THE CODES IN THE PLB SEGMENT
+40 SET COUNT=1
+41 FOR PIECE=4:2:LENGTH
Begin DoDot:2
+42 SET PLBCODE=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,20,SEGDA,1)),E,PIECE,PIECE+1)
+43 ;W !,PLBCODE
+44 SET CD=$PIECE(PLBCODE,SE)
+45 IF CD[E
SET CD=$PIECE(CD,E)
+46 SET CDAMT=$PIECE(PLBCODE,E,2)
+47 SET PLBREFID=$PIECE($PIECE(PLBCODE,E),SE,2)
+48 WRITE !,COUNT
+49 WRITE ?14,$JUSTIFY($FNUMBER(CDAMT,",",2),10)
+50 WRITE ?26,CD
+51 SET DESC=$$DESC(CD)
+52 WRITE ?30,DESC
+53 WRITE ?50,PLBREFID
+54 SET DATETOT=DATETOT+CDAMT
+55 SET GRANDTOT=GRANDTOT+CDAMT
+56 SET COUNT=COUNT+1
End DoDot:2
+57 WRITE !?10,"---------------"
+58 WRITE !?14,$JUSTIFY($FNUMBER(DATETOT,",",2),10)
+59 SET DATETOT=0
+60 ;I $Y>20 D EOP^BARUTL(1)
End DoDot:1
+61 WRITE !?10,"---------------"
+62 WRITE !?14,$JUSTIFY($FNUMBER(GRANDTOT,",",2),10)
+63 DO EOP^BARUTL(1)
+64 DO CLNUP
+65 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
