BAR50P4A ; IHS/SD/SDR - MATCH REASONS AND CLAIMS - 2 ; 01/09/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**20,21,23,24,26**;OCT 26, 2005;Build 17
;CLM/CLM2 split BARFROM BAREDP04 due to size
;IHS/SD/POT - 1.8*23 HEAT82698 NOV 2012,JAN 2013 LEADING/MISSING ZEROES IN BILL #
;IHS/SD/POT - 1.8*23 BETA TEST SEP 2013 YAK: SWAPPED CHK001 AND CHK002 (FIXED POS CLAIMS)
;IHS/SD/POT - 1.8*23 12/2/2012 RECORD ONLY UNMATCHED ITEMS (deactivated ->p24)
;IHS/SD/POT - 1.8*24 - 2/12/2014 MATCHING MANUAL BILLS (NO ALPHA)
;IHS/SD/SDR - 1.8*26 - Updated p23, p24 documentation
;IHS/SD/SDR - 1.8*26 - HEAT166023 - Made change to treat a negative bill amount as a positive number and use it to
; try matching the bill amount to the RPMS bill amount.
;
PAYER ;EP
S IENS=BARCKIEN_","_IMPDA_","
S EPAYER=$$GET1^DIQ(90056.02011,IENS,".06")
D ^XBFMK
S DIC=$$DIC^XBDIQ1(90056.24)
S DIC(0)="SMQ"
S X=EPAYER
D ^DIC
Q:+Y<0 ;stop here if no match in A/R EDI BILL LOGIC file
W !!,"A matching ""override"" has been set up for this A/R Account",!
S BARIEN=+Y
D DISPLAY^BAR50MCH
D ^XBFMK
K DIR
S DIR(0)="Y"
S DIR("A")="Do you wish to continue with the A/R Bill Matching using this criteria?"
S DIR("B")="N"
D ^DIR
I Y=0 S QFLG=1 Q
Q
;start old bar*1.8*23 IHS/SD/POT
;CLM ;EP
;S BARX="B"
;K BILMATCH S BILMATCH=0 ;bar*1.8*20
;I $$GET1^DIQ(90056.0205,IENS,1.01)'="" D Q
;.S BARBIEN=$$GET1^DIQ(90056.0205,IENS,1.01,"I")
;.D CLM3
;.;S (BARCNT,BILMATCH)=1,BILMATCH(BARBIEN)="",BARTMP(BARBIEN)="" I $G(DEBUG) W " MATCHED" ;bar*1.8*20
;;I '$D(^BARBL(DUZ(2),"B",BARBILL)) S BARX="G" ;Pharmacy POS ;bar*1.8*20 REQ4
;I $O(^BARBL(DUZ(2),"B",$S(($L(+BARBILL)=$L(BARBILL)):BARBILL_"-",1:BARBILL)))'[BARBILL S BARX="G" ;Pharmacy POS ;bar*1.8*20 REQ4
;;K BILMATCH S BILMATCH=0 ;bar*1.8*20
;S (BARBIEN,BARCNT)=0
;;start new code bar*1.8*20 REQ4
;I BARX="G" D CLM2 Q
;S BARSAVE=BARBILL
;F S BARBILL=$O(^BARBL(DUZ(2),"B",$S(($L(+BARBILL)=$L(BARBILL)):BARBILL_"-",1:BARBILL))) Q:(BARBILL'[BARSAVE) D CLM2
;S BARBILL=BARSAVE
;;
;Q
;;end new code REQ4
;CLM2 ;
;F S BARBIEN=$O(^BARBL(DUZ(2),BARX,BARBILL,BARBIEN)) Q:'+BARBIEN D
;.D CLM3
;.I (ERABILL'=BARAMT)!(ERADOS'=BARDOS) Q
;.S BARCNT=BARCNT+1
;.S BARTMP(BARBIEN)=""
;Q
;CLM3 ;
;S ERABILL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,5) ;E-BILLED
;S ERADOS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,8) ;E-DOS BEGIN
;S BARDOS=$$GET1^DIQ(90050.01,BARBIEN,102,"I") ;DOS BEGIN
;S ERATYPE=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11) ;E-CLM STATUS CD
;;S X=ERADOS D ^%DT S ERADOS=Y ;bar*1.8*21 SDR
;S BARDOS=$$Y2KD2^BARDUTL(BARDOS) ;bar*1.8*21 SDR
;S BARAMT=$$GET1^DIQ(90050.01,BARBIEN,13,"I") ;AMT BILLED
;I $G(DEBUG) W !,"ERA BILL : ",BARBILL ;bar*1.8*20 REQ4
;I $G(DEBUG) W !,"ERA BILL : ",$$GET1^DIQ(90056.0205,BAREIENS,.01) ;bar*1.8*20 REQ4
;I $G(DEBUG) W ?35,"ERA BILL TYPE: ",ERATYPE
;I $G(DEBUG) W !,"ERA BILLED: ",ERABILL,?25,"ERA DOS: ",ERADOS
;I $G(DEBUG) W !,"A/R BILLED: ",BARAMT,?25,"A/R DOS: ",BARDOS
;I ERABILL<0 S ERABILL=-ERABILL I $G(DEBUG) W ?50,"ERA BILL IS A NEGATIVE AMOUNT"
;I (ERABILL=BARAMT),(ERADOS=BARDOS) S BILMATCH=BILMATCH+1,BILMATCH(BARBIEN)="" I $G(DEBUG) W " MATCHED"
;Q
;end old start new bar*1.8*23 IHS/SD/POT
CLM(BAREIENS,BARBILL,BARX,BARMMFLG) ;EP
NEW BARMMTOT,BARMCNT,BARMMTYP ;P.OTT
S BARMMVAL="" ;RETURN VALUE OF MATCHED ITEM
S BARCNT=0
K BILMATCH S BILMATCH=0
;
S BARMMFLG=0 ;NEGATIVE IF MATCH, 0 IF NO MATCH 1 FOR BILLED AMOUNT MATCH, 2 FOR DOS MATCH
S BARMMTOT=0 ;COUNT OF MISMATCHES
F I=0:1:3 S BARMMCNT(I)=0
S BARFND=0
I $$GET1^DIQ(90056.0205,IENS,1.01)'="" D Q
.S BARBIEN=$$GET1^DIQ(90056.0205,IENS,1.01,"I")
.S BARFND=10
.S BARX="B"
.I $D(^BARBL(DUZ(2),"G",BARBILL))!$D(^BARBL(DUZ(2),"G",+BARBILL)) S BARX="G"
.S BARTMP=$$FINDING(BARBILL) I +BARTMP S BARX="G",(BARBILL)=$P(BARTMP,"^",2)
.I $$CLM3(1,BARBIEN,IMPDA,CLMDA,.BARMMTYP) ;JUST DISPLAY (1ST PARAM=1)
.Q
S BARX="G"
I $D(^BARBL(DUZ(2),BARX,BARTEST)) D Q ;CHK001
.S BARFND=1050
.D CLM2(BARX,BARTEST,.BARMMFLG)
.Q
;
S BARX="G" ;6/10/13
I $D(^BARBL(DUZ(2),BARX,+BARTEST)) D Q ;CHK002
.S BARFND=1051
.D CLM2(BARX,+BARTEST,.BARMMFLG)
.Q
;-------------------------------------------------2/27/2013>
S BARX="B"
I $D(^BARBL(DUZ(2),BARX,BARTEST)) D Q
.S BARFND=1052
.D CLM2(BARX,BARTEST,.BARMMFLG)
.Q
;-------------------------------------------------2/27/2013<
;TRY TO MATCH MANUAL BILL (form: nnnnn-IHS-WHATEVER) 2/13/2014
;
S BARX="G"
;
;S BARSAVE=+BARBILL,BARBILL=+BARBILL_"@" ;bar*1.8*24 IHS/SD/POT
S BARSAVE=+BARBILL ;bar*1.8*24 IHS/SD/POT
S BARBILL=+BARBILL_"-" ;bar*1.8*24 IHS/SD/POT
F S BARBILL=$O(^BARBL(DUZ(2),BARX,BARBILL)) Q:'+BARBILL Q:$E(BARBILL,1,$L(BARSAVE))'=BARSAVE D
.S BARFND=104
.D CLM2(BARX,BARBILL,.BARMMFLG)
I BARFND Q ;Found in POS
S BARBILL=BARSAVE
;
S BARX="B"
;
S BARSAVE=+BARBILL
S BARBILL=+BARBILL_"-" ;2/12/2014
F S BARBILL=$O(^BARBL(DUZ(2),BARX,BARBILL)) Q:'+BARBILL Q:$E(BARBILL,1,$L(BARSAVE))'=BARSAVE D
.S BARFND=105
.D CLM2(BARX,BARBILL,.BARMMFLG)
I BARFND Q ;found in A/R
S BARBILL=BARSAVE
;---------------------------------------------------------------------------------- END 2/13/2014
S BARX="G"
;
;S BARSAVE=+BARBILL,BARBILL=+BARBILL_"@" ;bar*1.8*24 IHS/SD/POT
S BARSAVE=+BARBILL ;bar*1.8*24 IHS/SD/POT
S BARBILL=+BARBILL_"-" ;bar*1.8*24 IHS/SD/POT
;start new bar*1.8*24 IHS/SD/POT
F S BARBILL=$O(^BARBL(DUZ(2),BARX,BARBILL)) Q:'+BARBILL Q:$E(BARBILL,1,$L(BARSAVE))'=BARSAVE D
.S BARFND=104
.D CLM2(BARX,BARBILL,.BARMMFLG)
I BARFND Q ;If found in POS do not search in A/R -->
;
S BARBILL=BARSAVE
;
S BARX="B"
;
S BARSAVE=+BARBILL,BARBILL=+BARBILL_"@"
F S BARBILL=$O(^BARBL(DUZ(2),BARX,BARBILL)) Q:'+BARBILL Q:$E(BARBILL,1,$L(BARSAVE))'=BARSAVE D
.S BARFND=105
.D CLM2(BARX,BARBILL,.BARMMFLG)
I BARFND Q ;If found in POS do not search in A/R -->
;
S BARBILL=BARSAVE
;end new bar*1.8*24 IHS/SD/POT
;
;CHK POS (OPTION WITH MISSING LEADING ZEROES) -------------------------
;
S BARTMP=$$FINDING(BARBILL)
I +BARTMP S BARX="G",(BARBILL)=$P(BARTMP,"^",2) D
.S BARX="G",BARFND=100
.D CLM2("G",BARBILL,.BARMMFLG)
.Q
I BARFND Q ;if found in POS do not search in A/R -->
;
;CHK POS (OPTION WITH LEADING ZEROES)
;
I $D(^BARBL(DUZ(2),"G",BARBILL)) D
.S BARX="G",BARFND=1
.D CLM2("G",BARBILL,.BARMMFLG)
.Q
I BARFND Q ;If found in POS do not search in A/R -->
;
;CHK POS (OPTION WITH NO LEADING ZEROES)
;
I +BARBILL'=BARBILL I $D(^BARBL(DUZ(2),"G",+BARBILL)) D
.S BARX="G",BARFND=2
.D CLM2("G",+BARBILL,.BARMMFLG) ;CHK POS
I BARFND Q ;If found in POS do not search in A/R -->
;
S BARX="B" ;
;CHK POS (OPTION WITH LEADING ZEROES) -------------------------
I $D(^BARBL(DUZ(2),BARX,BARBILL)) D
.S BARFND=3
.D CLM2(BARX,BARBILL,.BARMMFLG)
.Q
I BARFND Q ;If found in POS do not search in A/R -->
;
S BARSAVE=+BARBILL,BARBILL=+BARBILL_"@"
;
F S BARBILL=$O(^BARBL(DUZ(2),BARX,BARBILL)) Q:'+BARBILL Q:$E(BARBILL,1,$L(BARSAVE))'=BARSAVE D
.S BARFND=4
.D CLM2(BARX,BARBILL,.BARMMFLG)
I BARFND Q ;If found in POS do not search in A/R -->
;
S BARBILL=BARSAVE
;
;CHK POS (OPTION WITH NO LEADING ZEROES) -------------------------
;
I +BARBILL'=BARBILL I $D(^BARBL(DUZ(2),BARX,+BARBILL)) D ;
.S BARFND=5
.D CLM2(BARX,+BARBILL,.BARMMFLG)
I BARFND Q ;If found in POS do not search in A/R -->
;
;
S BARSAVE=+BARBILL,BARBILL=+BARBILL_"@"
;
F S BARBILL=$O(^BARBL(DUZ(2),BARX,BARBILL)) Q:'+BARBILL Q:$E(BARBILL,1,$L(BARSAVE))'=BARSAVE D
.S BARFND=6
.D CLM2(BARX,BARBILL,.BARMMFLG)
S BARBILL=BARSAVE
Q
;
;
CLM2(BARX,BARBILL,BARMMFLG) ;
S BARMMFLG=0
S BARBIEN=0 F S BARBIEN=$O(^BARBL(DUZ(2),BARX,BARBILL,BARBIEN)) Q:'+BARBIEN D
.I $$CLM3(2,BARBIEN,IMPDA,CLMDA,.BARMMTYP) D Q ;BLOCK FOR MATCHED
..S BARCNT=BARCNT+1
..S BARTMP(BARBIEN)="" ;ARRAY OF MATCHED BILLS
..S BARMMFLG=-1
..Q ;
.;COUNTING TYPES OF UNMATCHED
.S BARMMTOT=BARMMTOT+1 ;COUNT OF MISMATCHES (MM)
.S BARMMCNT(BARMMTYP)=BARMMCNT(BARMMTYP)+1 ;COUNT TYPES OF MM
.QUIT
I $G(BARDBG) I BARMMCNT(1)+BARMMCNT(2)=1 D ;ONE OR THE OTHER; NOT BOTH!
.I BARMMCNT(1) S BARMMFLG=1
.I BARMMCNT(2) S BARMMFLG=2
.Q
Q
CLM3(BARFROM,BARBIEN,IMPDA,CLMDA,BARMMTYP) ;
NEW ERABILL,ERADOS,BARDOS,BARAMT,ERATYPE
S ERABILL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,5) ;E-BILLED
S ERADOS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,8) ;E-DOS BEGIN
S BARDOS=$$GET1^DIQ(90050.01,BARBIEN,102,"I") ;DOS BEGIN
S ERATYPE=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11) ;E-CLM STATUS CD
S BARDOS=$$Y2KD2^BARDUTL(BARDOS) ;
S BARAMT=$$GET1^DIQ(90050.01,BARBIEN,13,"I") ;AMT BILLED
S BARMMTYP=0 ;MATCH
;
;I ERABILL<0 S ERABILL=-ERABILL D Q 0 ;bar*1.8*26 IHS/SD/SDR HEAT166023
I ERABILL<0 S ERABILL=-ERABILL D ;bar*1.8*26 IHS/SD/SDR HEAT166023
.D BLHDR ;P.OTT 12/2/2013
.I $G(BARDBG) D INS^BAR50DET($C(9,9)_"ERA BILL IS A NEGATIVE AMOUNT",1)
;
I (+ERABILL=+BARAMT),(ERADOS=BARDOS) D Q 1 ;P.OTT 12/2/2013
.D BLHDR ;P.OTT 12/2/2013
.S BILMATCH=BILMATCH+1,BILMATCH(BARBIEN)=""
.Q ;OK
; ---- NOT MATCHED - OTHER REASON FALL THRU
I BARFROM=1 QUIT 0
;BARMMTYP=0 - MATCH
;BARMMTYP=1 ONLY AMOUNT NOT MATCHED
;BARMMTYP=2 ONLY DOS NOT MATCHED
;BARMMTYP=3 AMOUNT & DOS NOT MATCHED
;
D BLHDR ;P.OTT 12/2/2013
I (+ERABILL'=+BARAMT),(ERADOS'=BARDOS) S BARMMTYP=3 D Q 0
.I $G(BARDBG) D INS^BAR50DET(" NOT MATCHED",1) Q ;
I (+ERABILL'=+BARAMT),(ERADOS=BARDOS) S BARMMTYP=1 D Q 0
.I $G(BARDBG) D INS^BAR50DET(" PARTIAL MATCH: DOS OK. AMT DIFF: "_$J(ERABILL-BARAMT,5,2)_"$",1) S BARMMVAL=BARDOS
I (ERADOS'=BARDOS),(+ERABILL=+BARAMT) S BARMMTYP=2 D Q 0
.I $G(BARDBG) D INS^BAR50DET(" PARTIAL MATCH: AMOUNT OK",1) S BARMMVAL=BARAMT
; ---- NOT MATCHED - OTHER REASON FALL THRU
Q 0
BLHDR ;
I $G(BARDBG) D ;P.OTT 12/2/2013
.D NOMATCH^BAR50DET
.D INS^BAR50DET("ERA BILL : "_$$GET1^DIQ(90056.0205,BAREIENS,.01),0)
.D INS^BAR50DET($C(9,9)_"ERA BILL TYPE: "_ERATYPE,1)
.D INS^BAR50DET("ERA BILLED: "_ERABILL_$C(9,9)_"ERA DOS: "_ERADOS,0)
.D INS^BAR50DET("A/R BILLED: "_BARAMT_$C(9,9)_"A/R DOS: "_BARDOS,0)
.D INS^BAR50DET("BAR BILL : "_BARBILL,0)
Q
;end new bar*1.8*23 IHS/SD/POT
TRANSCK ;EP
Q:$G(BARBIEN)="" ;no bill number matched
S BARTFLG=0
S BARBTCH=$$GET1^DIQ(90056.02011,BARCKIEN,.07)
S BARITEM=$$GET1^DIQ(90056.02011,BARCKIEN,.08)
S BARTR=0,BARTFLG=0
F S BARTR=$O(^BARTR(DUZ(2),"AC",BARBIEN,BARTR)) Q:'BARTR D Q:(BARTFLG=1)
.S BARTBTCH=$$GET1^DIQ(90050.03,BARTR,14)
.S BARTITEM=$$GET1^DIQ(90050.03,BARTR,15)
.I BARTBTCH'="",BARITEM'="",BARBTCH=BARTBTCH,BARITEM=BARTITEM S BARTFLG=1
I BARTFLG S ERRORS("HTRN")=""
Q
;start new bar*1.8*23 IHS/SD/POT
FINDING(BARBILL) ;RETURNS 1^BARXBILL (WITH MISSED OR ADDED LEADING ZERORS); OR 0
N BARXBILL,BARRET,IXX ;REWRITE JAN 2013
I $E(BARBILL)'="0" D Q BARRET
.S BARRET=0
.S BARXBILL=BARBILL
.F IXX=1:1 Q:($L(BARXBILL)=20) D Q:BARRET
..S BARXBILL="0"_BARXBILL
..I $D(^BARBL(DUZ(2),"G",BARXBILL)) S BARRET="1^"_BARXBILL
..Q
.Q
I $E(BARBILL)="0" D Q BARRET
.S BARRET=0
.S BARXBILL=BARBILL
.F IXX=1:1 Q:$E(BARXBILL,1)'="0" D Q:BARRET
..S BARXBILL=$E(BARXBILL,2,999) I BARXBILL="" Q
..I $D(^BARBL(DUZ(2),"G",BARXBILL)) S BARRET="1^"_BARXBILL
..Q
.Q
I BARBILL=+BARBILL D Q BARRET
.S BARXBILL=+BARBILL
.I $D(^BARBL(DUZ(2),"G",BARXBILL)) S BARRET="1^"_BARXBILL
.Q
Q "" ;NEVER FALLS THROUGH
;end new bar*1.8*23 IHS/SD/POT
BAR50P4A ; IHS/SD/SDR - MATCH REASONS AND CLAIMS - 2 ; 01/09/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**20,21,23,24,26**;OCT 26, 2005;Build 17
+2 ;CLM/CLM2 split BARFROM BAREDP04 due to size
+3 ;IHS/SD/POT - 1.8*23 HEAT82698 NOV 2012,JAN 2013 LEADING/MISSING ZEROES IN BILL #
+4 ;IHS/SD/POT - 1.8*23 BETA TEST SEP 2013 YAK: SWAPPED CHK001 AND CHK002 (FIXED POS CLAIMS)
+5 ;IHS/SD/POT - 1.8*23 12/2/2012 RECORD ONLY UNMATCHED ITEMS (deactivated ->p24)
+6 ;IHS/SD/POT - 1.8*24 - 2/12/2014 MATCHING MANUAL BILLS (NO ALPHA)
+7 ;IHS/SD/SDR - 1.8*26 - Updated p23, p24 documentation
+8 ;IHS/SD/SDR - 1.8*26 - HEAT166023 - Made change to treat a negative bill amount as a positive number and use it to
+9 ; try matching the bill amount to the RPMS bill amount.
+10 ;
PAYER ;EP
+1 SET IENS=BARCKIEN_","_IMPDA_","
+2 SET EPAYER=$$GET1^DIQ(90056.02011,IENS,".06")
+3 DO ^XBFMK
+4 SET DIC=$$DIC^XBDIQ1(90056.24)
+5 SET DIC(0)="SMQ"
+6 SET X=EPAYER
+7 DO ^DIC
+8 ;stop here if no match in A/R EDI BILL LOGIC file
IF +Y<0
QUIT
+9 WRITE !!,"A matching ""override"" has been set up for this A/R Account",!
+10 SET BARIEN=+Y
+11 DO DISPLAY^BAR50MCH
+12 DO ^XBFMK
+13 KILL DIR
+14 SET DIR(0)="Y"
+15 SET DIR("A")="Do you wish to continue with the A/R Bill Matching using this criteria?"
+16 SET DIR("B")="N"
+17 DO ^DIR
+18 IF Y=0
SET QFLG=1
QUIT
+19 QUIT
+20 ;start old bar*1.8*23 IHS/SD/POT
+21 ;CLM ;EP
+22 ;S BARX="B"
+23 ;K BILMATCH S BILMATCH=0 ;bar*1.8*20
+24 ;I $$GET1^DIQ(90056.0205,IENS,1.01)'="" D Q
+25 ;.S BARBIEN=$$GET1^DIQ(90056.0205,IENS,1.01,"I")
+26 ;.D CLM3
+27 ;.;S (BARCNT,BILMATCH)=1,BILMATCH(BARBIEN)="",BARTMP(BARBIEN)="" I $G(DEBUG) W " MATCHED" ;bar*1.8*20
+28 ;;I '$D(^BARBL(DUZ(2),"B",BARBILL)) S BARX="G" ;Pharmacy POS ;bar*1.8*20 REQ4
+29 ;I $O(^BARBL(DUZ(2),"B",$S(($L(+BARBILL)=$L(BARBILL)):BARBILL_"-",1:BARBILL)))'[BARBILL S BARX="G" ;Pharmacy POS ;bar*1.8*20 REQ4
+30 ;;K BILMATCH S BILMATCH=0 ;bar*1.8*20
+31 ;S (BARBIEN,BARCNT)=0
+32 ;;start new code bar*1.8*20 REQ4
+33 ;I BARX="G" D CLM2 Q
+34 ;S BARSAVE=BARBILL
+35 ;F S BARBILL=$O(^BARBL(DUZ(2),"B",$S(($L(+BARBILL)=$L(BARBILL)):BARBILL_"-",1:BARBILL))) Q:(BARBILL'[BARSAVE) D CLM2
+36 ;S BARBILL=BARSAVE
+37 ;;
+38 ;Q
+39 ;;end new code REQ4
+40 ;CLM2 ;
+41 ;F S BARBIEN=$O(^BARBL(DUZ(2),BARX,BARBILL,BARBIEN)) Q:'+BARBIEN D
+42 ;.D CLM3
+43 ;.I (ERABILL'=BARAMT)!(ERADOS'=BARDOS) Q
+44 ;.S BARCNT=BARCNT+1
+45 ;.S BARTMP(BARBIEN)=""
+46 ;Q
+47 ;CLM3 ;
+48 ;S ERABILL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,5) ;E-BILLED
+49 ;S ERADOS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,8) ;E-DOS BEGIN
+50 ;S BARDOS=$$GET1^DIQ(90050.01,BARBIEN,102,"I") ;DOS BEGIN
+51 ;S ERATYPE=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11) ;E-CLM STATUS CD
+52 ;;S X=ERADOS D ^%DT S ERADOS=Y ;bar*1.8*21 SDR
+53 ;S BARDOS=$$Y2KD2^BARDUTL(BARDOS) ;bar*1.8*21 SDR
+54 ;S BARAMT=$$GET1^DIQ(90050.01,BARBIEN,13,"I") ;AMT BILLED
+55 ;I $G(DEBUG) W !,"ERA BILL : ",BARBILL ;bar*1.8*20 REQ4
+56 ;I $G(DEBUG) W !,"ERA BILL : ",$$GET1^DIQ(90056.0205,BAREIENS,.01) ;bar*1.8*20 REQ4
+57 ;I $G(DEBUG) W ?35,"ERA BILL TYPE: ",ERATYPE
+58 ;I $G(DEBUG) W !,"ERA BILLED: ",ERABILL,?25,"ERA DOS: ",ERADOS
+59 ;I $G(DEBUG) W !,"A/R BILLED: ",BARAMT,?25,"A/R DOS: ",BARDOS
+60 ;I ERABILL<0 S ERABILL=-ERABILL I $G(DEBUG) W ?50,"ERA BILL IS A NEGATIVE AMOUNT"
+61 ;I (ERABILL=BARAMT),(ERADOS=BARDOS) S BILMATCH=BILMATCH+1,BILMATCH(BARBIEN)="" I $G(DEBUG) W " MATCHED"
+62 ;Q
+63 ;end old start new bar*1.8*23 IHS/SD/POT
CLM(BAREIENS,BARBILL,BARX,BARMMFLG) ;EP
+1 ;P.OTT
NEW BARMMTOT,BARMCNT,BARMMTYP
+2 ;RETURN VALUE OF MATCHED ITEM
SET BARMMVAL=""
+3 SET BARCNT=0
+4 KILL BILMATCH
SET BILMATCH=0
+5 ;
+6 ;NEGATIVE IF MATCH, 0 IF NO MATCH 1 FOR BILLED AMOUNT MATCH, 2 FOR DOS MATCH
SET BARMMFLG=0
+7 ;COUNT OF MISMATCHES
SET BARMMTOT=0
+8 FOR I=0:1:3
SET BARMMCNT(I)=0
+9 SET BARFND=0
+10 IF $$GET1^DIQ(90056.0205,IENS,1.01)'=""
Begin DoDot:1
+11 SET BARBIEN=$$GET1^DIQ(90056.0205,IENS,1.01,"I")
+12 SET BARFND=10
+13 SET BARX="B"
+14 IF $DATA(^BARBL(DUZ(2),"G",BARBILL))!$DATA(^BARBL(DUZ(2),"G",+BARBILL))
SET BARX="G"
+15 SET BARTMP=$$FINDING(BARBILL)
IF +BARTMP
SET BARX="G"
SET (BARBILL)=$PIECE(BARTMP,"^",2)
+16 ;JUST DISPLAY (1ST PARAM=1)
IF $$CLM3(1,BARBIEN,IMPDA,CLMDA,.BARMMTYP)
+17 QUIT
End DoDot:1
QUIT
+18 SET BARX="G"
+19 ;CHK001
IF $DATA(^BARBL(DUZ(2),BARX,BARTEST))
Begin DoDot:1
+20 SET BARFND=1050
+21 DO CLM2(BARX,BARTEST,.BARMMFLG)
+22 QUIT
End DoDot:1
QUIT
+23 ;
+24 ;6/10/13
SET BARX="G"
+25 ;CHK002
IF $DATA(^BARBL(DUZ(2),BARX,+BARTEST))
Begin DoDot:1
+26 SET BARFND=1051
+27 DO CLM2(BARX,+BARTEST,.BARMMFLG)
+28 QUIT
End DoDot:1
QUIT
+29 ;-------------------------------------------------2/27/2013>
+30 SET BARX="B"
+31 IF $DATA(^BARBL(DUZ(2),BARX,BARTEST))
Begin DoDot:1
+32 SET BARFND=1052
+33 DO CLM2(BARX,BARTEST,.BARMMFLG)
+34 QUIT
End DoDot:1
QUIT
+35 ;-------------------------------------------------2/27/2013<
+36 ;TRY TO MATCH MANUAL BILL (form: nnnnn-IHS-WHATEVER) 2/13/2014
+37 ;
+38 SET BARX="G"
+39 ;
+40 ;S BARSAVE=+BARBILL,BARBILL=+BARBILL_"@" ;bar*1.8*24 IHS/SD/POT
+41 ;bar*1.8*24 IHS/SD/POT
SET BARSAVE=+BARBILL
+42 ;bar*1.8*24 IHS/SD/POT
SET BARBILL=+BARBILL_"-"
+43 FOR
SET BARBILL=$ORDER(^BARBL(DUZ(2),BARX,BARBILL))
IF '+BARBILL
QUIT
IF $EXTRACT(BARBILL,1,$LENGTH(BARSAVE))'=BARSAVE
QUIT
Begin DoDot:1
+44 SET BARFND=104
+45 DO CLM2(BARX,BARBILL,.BARMMFLG)
End DoDot:1
+46 ;Found in POS
IF BARFND
QUIT
+47 SET BARBILL=BARSAVE
+48 ;
+49 SET BARX="B"
+50 ;
+51 SET BARSAVE=+BARBILL
+52 ;2/12/2014
SET BARBILL=+BARBILL_"-"
+53 FOR
SET BARBILL=$ORDER(^BARBL(DUZ(2),BARX,BARBILL))
IF '+BARBILL
QUIT
IF $EXTRACT(BARBILL,1,$LENGTH(BARSAVE))'=BARSAVE
QUIT
Begin DoDot:1
+54 SET BARFND=105
+55 DO CLM2(BARX,BARBILL,.BARMMFLG)
End DoDot:1
+56 ;found in A/R
IF BARFND
QUIT
+57 SET BARBILL=BARSAVE
+58 ;---------------------------------------------------------------------------------- END 2/13/2014
+59 SET BARX="G"
+60 ;
+61 ;S BARSAVE=+BARBILL,BARBILL=+BARBILL_"@" ;bar*1.8*24 IHS/SD/POT
+62 ;bar*1.8*24 IHS/SD/POT
SET BARSAVE=+BARBILL
+63 ;bar*1.8*24 IHS/SD/POT
SET BARBILL=+BARBILL_"-"
+64 ;start new bar*1.8*24 IHS/SD/POT
+65 FOR
SET BARBILL=$ORDER(^BARBL(DUZ(2),BARX,BARBILL))
IF '+BARBILL
QUIT
IF $EXTRACT(BARBILL,1,$LENGTH(BARSAVE))'=BARSAVE
QUIT
Begin DoDot:1
+66 SET BARFND=104
+67 DO CLM2(BARX,BARBILL,.BARMMFLG)
End DoDot:1
+68 ;If found in POS do not search in A/R -->
IF BARFND
QUIT
+69 ;
+70 SET BARBILL=BARSAVE
+71 ;
+72 SET BARX="B"
+73 ;
+74 SET BARSAVE=+BARBILL
SET BARBILL=+BARBILL_"@"
+75 FOR
SET BARBILL=$ORDER(^BARBL(DUZ(2),BARX,BARBILL))
IF '+BARBILL
QUIT
IF $EXTRACT(BARBILL,1,$LENGTH(BARSAVE))'=BARSAVE
QUIT
Begin DoDot:1
+76 SET BARFND=105
+77 DO CLM2(BARX,BARBILL,.BARMMFLG)
End DoDot:1
+78 ;If found in POS do not search in A/R -->
IF BARFND
QUIT
+79 ;
+80 SET BARBILL=BARSAVE
+81 ;end new bar*1.8*24 IHS/SD/POT
+82 ;
+83 ;CHK POS (OPTION WITH MISSING LEADING ZEROES) -------------------------
+84 ;
+85 SET BARTMP=$$FINDING(BARBILL)
+86 IF +BARTMP
SET BARX="G"
SET (BARBILL)=$PIECE(BARTMP,"^",2)
Begin DoDot:1
+87 SET BARX="G"
SET BARFND=100
+88 DO CLM2("G",BARBILL,.BARMMFLG)
+89 QUIT
End DoDot:1
+90 ;if found in POS do not search in A/R -->
IF BARFND
QUIT
+91 ;
+92 ;CHK POS (OPTION WITH LEADING ZEROES)
+93 ;
+94 IF $DATA(^BARBL(DUZ(2),"G",BARBILL))
Begin DoDot:1
+95 SET BARX="G"
SET BARFND=1
+96 DO CLM2("G",BARBILL,.BARMMFLG)
+97 QUIT
End DoDot:1
+98 ;If found in POS do not search in A/R -->
IF BARFND
QUIT
+99 ;
+100 ;CHK POS (OPTION WITH NO LEADING ZEROES)
+101 ;
+102 IF +BARBILL'=BARBILL
IF $DATA(^BARBL(DUZ(2),"G",+BARBILL))
Begin DoDot:1
+103 SET BARX="G"
SET BARFND=2
+104 ;CHK POS
DO CLM2("G",+BARBILL,.BARMMFLG)
End DoDot:1
+105 ;If found in POS do not search in A/R -->
IF BARFND
QUIT
+106 ;
+107 ;
SET BARX="B"
+108 ;CHK POS (OPTION WITH LEADING ZEROES) -------------------------
+109 IF $DATA(^BARBL(DUZ(2),BARX,BARBILL))
Begin DoDot:1
+110 SET BARFND=3
+111 DO CLM2(BARX,BARBILL,.BARMMFLG)
+112 QUIT
End DoDot:1
+113 ;If found in POS do not search in A/R -->
IF BARFND
QUIT
+114 ;
+115 SET BARSAVE=+BARBILL
SET BARBILL=+BARBILL_"@"
+116 ;
+117 FOR
SET BARBILL=$ORDER(^BARBL(DUZ(2),BARX,BARBILL))
IF '+BARBILL
QUIT
IF $EXTRACT(BARBILL,1,$LENGTH(BARSAVE))'=BARSAVE
QUIT
Begin DoDot:1
+118 SET BARFND=4
+119 DO CLM2(BARX,BARBILL,.BARMMFLG)
End DoDot:1
+120 ;If found in POS do not search in A/R -->
IF BARFND
QUIT
+121 ;
+122 SET BARBILL=BARSAVE
+123 ;
+124 ;CHK POS (OPTION WITH NO LEADING ZEROES) -------------------------
+125 ;
+126 ;
IF +BARBILL'=BARBILL
IF $DATA(^BARBL(DUZ(2),BARX,+BARBILL))
Begin DoDot:1
+127 SET BARFND=5
+128 DO CLM2(BARX,+BARBILL,.BARMMFLG)
End DoDot:1
+129 ;If found in POS do not search in A/R -->
IF BARFND
QUIT
+130 ;
+131 ;
+132 SET BARSAVE=+BARBILL
SET BARBILL=+BARBILL_"@"
+133 ;
+134 FOR
SET BARBILL=$ORDER(^BARBL(DUZ(2),BARX,BARBILL))
IF '+BARBILL
QUIT
IF $EXTRACT(BARBILL,1,$LENGTH(BARSAVE))'=BARSAVE
QUIT
Begin DoDot:1
+135 SET BARFND=6
+136 DO CLM2(BARX,BARBILL,.BARMMFLG)
End DoDot:1
+137 SET BARBILL=BARSAVE
+138 QUIT
+139 ;
+140 ;
CLM2(BARX,BARBILL,BARMMFLG) ;
+1 SET BARMMFLG=0
+2 SET BARBIEN=0
FOR
SET BARBIEN=$ORDER(^BARBL(DUZ(2),BARX,BARBILL,BARBIEN))
IF '+BARBIEN
QUIT
Begin DoDot:1
+3 ;BLOCK FOR MATCHED
IF $$CLM3(2,BARBIEN,IMPDA,CLMDA,.BARMMTYP)
Begin DoDot:2
+4 SET BARCNT=BARCNT+1
+5 ;ARRAY OF MATCHED BILLS
SET BARTMP(BARBIEN)=""
+6 SET BARMMFLG=-1
+7 ;
QUIT
End DoDot:2
QUIT
+8 ;COUNTING TYPES OF UNMATCHED
+9 ;COUNT OF MISMATCHES (MM)
SET BARMMTOT=BARMMTOT+1
+10 ;COUNT TYPES OF MM
SET BARMMCNT(BARMMTYP)=BARMMCNT(BARMMTYP)+1
+11 QUIT
End DoDot:1
+12 ;ONE OR THE OTHER; NOT BOTH!
IF $GET(BARDBG)
IF BARMMCNT(1)+BARMMCNT(2)=1
Begin DoDot:1
+13 IF BARMMCNT(1)
SET BARMMFLG=1
+14 IF BARMMCNT(2)
SET BARMMFLG=2
+15 QUIT
End DoDot:1
+16 QUIT
CLM3(BARFROM,BARBIEN,IMPDA,CLMDA,BARMMTYP) ;
+1 NEW ERABILL,ERADOS,BARDOS,BARAMT,ERATYPE
+2 ;E-BILLED
SET ERABILL=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,5)
+3 ;E-DOS BEGIN
SET ERADOS=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,8)
+4 ;DOS BEGIN
SET BARDOS=$$GET1^DIQ(90050.01,BARBIEN,102,"I")
+5 ;E-CLM STATUS CD
SET ERATYPE=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)
+6 ;
SET BARDOS=$$Y2KD2^BARDUTL(BARDOS)
+7 ;AMT BILLED
SET BARAMT=$$GET1^DIQ(90050.01,BARBIEN,13,"I")
+8 ;MATCH
SET BARMMTYP=0
+9 ;
+10 ;I ERABILL<0 S ERABILL=-ERABILL D Q 0 ;bar*1.8*26 IHS/SD/SDR HEAT166023
+11 ;bar*1.8*26 IHS/SD/SDR HEAT166023
IF ERABILL<0
SET ERABILL=-ERABILL
Begin DoDot:1
+12 ;P.OTT 12/2/2013
DO BLHDR
+13 IF $GET(BARDBG)
DO INS^BAR50DET($CHAR(9,9)_"ERA BILL IS A NEGATIVE AMOUNT",1)
End DoDot:1
+14 ;
+15 ;P.OTT 12/2/2013
IF (+ERABILL=+BARAMT)
IF (ERADOS=BARDOS)
Begin DoDot:1
+16 ;P.OTT 12/2/2013
DO BLHDR
+17 SET BILMATCH=BILMATCH+1
SET BILMATCH(BARBIEN)=""
+18 ;OK
QUIT
End DoDot:1
QUIT 1
+19 ; ---- NOT MATCHED - OTHER REASON FALL THRU
+20 IF BARFROM=1
QUIT 0
+21 ;BARMMTYP=0 - MATCH
+22 ;BARMMTYP=1 ONLY AMOUNT NOT MATCHED
+23 ;BARMMTYP=2 ONLY DOS NOT MATCHED
+24 ;BARMMTYP=3 AMOUNT & DOS NOT MATCHED
+25 ;
+26 ;P.OTT 12/2/2013
DO BLHDR
+27 IF (+ERABILL'=+BARAMT)
IF (ERADOS'=BARDOS)
SET BARMMTYP=3
Begin DoDot:1
+28 ;
IF $GET(BARDBG)
DO INS^BAR50DET(" NOT MATCHED",1)
QUIT
End DoDot:1
QUIT 0
+29 IF (+ERABILL'=+BARAMT)
IF (ERADOS=BARDOS)
SET BARMMTYP=1
Begin DoDot:1
+30 IF $GET(BARDBG)
DO INS^BAR50DET(" PARTIAL MATCH: DOS OK. AMT DIFF: "_$JUSTIFY(ERABILL-BARAMT,5,2)_"$",1)
SET BARMMVAL=BARDOS
End DoDot:1
QUIT 0
+31 IF (ERADOS'=BARDOS)
IF (+ERABILL=+BARAMT)
SET BARMMTYP=2
Begin DoDot:1
+32 IF $GET(BARDBG)
DO INS^BAR50DET(" PARTIAL MATCH: AMOUNT OK",1)
SET BARMMVAL=BARAMT
End DoDot:1
QUIT 0
+33 ; ---- NOT MATCHED - OTHER REASON FALL THRU
+34 QUIT 0
BLHDR ;
+1 ;P.OTT 12/2/2013
IF $GET(BARDBG)
Begin DoDot:1
+2 DO NOMATCH^BAR50DET
+3 DO INS^BAR50DET("ERA BILL : "_$$GET1^DIQ(90056.0205,BAREIENS,.01),0)
+4 DO INS^BAR50DET($CHAR(9,9)_"ERA BILL TYPE: "_ERATYPE,1)
+5 DO INS^BAR50DET("ERA BILLED: "_ERABILL_$CHAR(9,9)_"ERA DOS: "_ERADOS,0)
+6 DO INS^BAR50DET("A/R BILLED: "_BARAMT_$CHAR(9,9)_"A/R DOS: "_BARDOS,0)
+7 DO INS^BAR50DET("BAR BILL : "_BARBILL,0)
End DoDot:1
+8 QUIT
+9 ;end new bar*1.8*23 IHS/SD/POT
TRANSCK ;EP
+1 ;no bill number matched
IF $GET(BARBIEN)=""
QUIT
+2 SET BARTFLG=0
+3 SET BARBTCH=$$GET1^DIQ(90056.02011,BARCKIEN,.07)
+4 SET BARITEM=$$GET1^DIQ(90056.02011,BARCKIEN,.08)
+5 SET BARTR=0
SET BARTFLG=0
+6 FOR
SET BARTR=$ORDER(^BARTR(DUZ(2),"AC",BARBIEN,BARTR))
IF 'BARTR
QUIT
Begin DoDot:1
+7 SET BARTBTCH=$$GET1^DIQ(90050.03,BARTR,14)
+8 SET BARTITEM=$$GET1^DIQ(90050.03,BARTR,15)
+9 IF BARTBTCH'=""
IF BARITEM'=""
IF BARBTCH=BARTBTCH
IF BARITEM=BARTITEM
SET BARTFLG=1
End DoDot:1
IF (BARTFLG=1)
QUIT
+10 IF BARTFLG
SET ERRORS("HTRN")=""
+11 QUIT
+12 ;start new bar*1.8*23 IHS/SD/POT
FINDING(BARBILL) ;RETURNS 1^BARXBILL (WITH MISSED OR ADDED LEADING ZERORS); OR 0
+1 ;REWRITE JAN 2013
NEW BARXBILL,BARRET,IXX
+2 IF $EXTRACT(BARBILL)'="0"
Begin DoDot:1
+3 SET BARRET=0
+4 SET BARXBILL=BARBILL
+5 FOR IXX=1:1
IF ($LENGTH(BARXBILL)=20)
QUIT
Begin DoDot:2
+6 SET BARXBILL="0"_BARXBILL
+7 IF $DATA(^BARBL(DUZ(2),"G",BARXBILL))
SET BARRET="1^"_BARXBILL
+8 QUIT
End DoDot:2
IF BARRET
QUIT
+9 QUIT
End DoDot:1
QUIT BARRET
+10 IF $EXTRACT(BARBILL)="0"
Begin DoDot:1
+11 SET BARRET=0
+12 SET BARXBILL=BARBILL
+13 FOR IXX=1:1
IF $EXTRACT(BARXBILL,1)'="0"
QUIT
Begin DoDot:2
+14 SET BARXBILL=$EXTRACT(BARXBILL,2,999)
IF BARXBILL=""
QUIT
+15 IF $DATA(^BARBL(DUZ(2),"G",BARXBILL))
SET BARRET="1^"_BARXBILL
+16 QUIT
End DoDot:2
IF BARRET
QUIT
+17 QUIT
End DoDot:1
QUIT BARRET
+18 IF BARBILL=+BARBILL
Begin DoDot:1
+19 SET BARXBILL=+BARBILL
+20 IF $DATA(^BARBL(DUZ(2),"G",BARXBILL))
SET BARRET="1^"_BARXBILL
+21 QUIT
End DoDot:1
QUIT BARRET
+22 ;NEVER FALLS THROUGH
QUIT ""
+23 ;end new bar*1.8*23 IHS/SD/POT
