Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BAR50EB

BAR50EB.m

Go to the documentation of this file. 
  1. BAR50EB ; IHS/SD/TPF - AR ERA BALANCE CHECKER ; 01/28/2009
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**5,6,10,20,21,22,23,24,26,28**;OCT 26,2005;Build 92
  1.  ;
  1.  ;THIS RTN CONTAINS THE BALANCE CHECKING NEED SO ERA POSTING DOES NOT ALLOW
  1.  ;POSTING WHICH WILL NOT BE ACCEPTED BY UFMS
  1.  ;
  1.  ;BATCH - CHECKS THE TRANSACTIONS WITHIN A SINGLE ERA FILE BEING POSTED
  1.  ;AGAINST A BATCH. THE PAYMENTS/ADJUSTMENTS FROM THE ERA FILE MUST BE <= THE 
  1.  ;BATCH AMOUNT (#29) AND THE BATCH AMOUNT (#29) MUST BE >=0
  1.  ;;P.OTTIS HEAT#82698 NOV 2012 LEADING ZEROES IN CHKECK # (POS)
  1.  ;;                   MAR 2013 EXCLUDED COL BATCHES OLDER THAN 365 DAYS
  1.  ;;                   10/10/2013 FIXED ERR MSG
  1.  ;;HEAT147572 P.OTT ALLOW TRIBAL SITES ERA POSTING OF NEG BAL & CANCELLED BILLS 2/5/2014
  1.  ;;HEAT151948 P.OTT 2/6/2014 FIXED PENDING ADJ. (NEGATIVE BILL BALANCE)
  1.  ;IHS/SD/SDR 1.8*26 - HEAT170856 Changed IHSNEGB to IHSCANCB for ERA > ITM check.
  1.  ;IHS/SD/SDR 1.8*28 - CR8346 HEAT275351 - Fixed so matched with reason NTP won't get counted in matched total.
  1.  ;IHS/DIT/CPC 1.8*28 - CR9372 Change position of ADDREAS 
  1.  Q
  1.  ;
  1.  ;TYPE = "ERA" FOR INTERNAL ERA FILE CHECK, RPMS = COMPARE ERA TO RPMS BILL
  1. NEGBAL(IMPDA,TYPE) ;EP - CHECK FOR NEGATIVE BALANCE W/IN ERA AND IF POSTED AGAINST RPMS
  1.  Q:$G(TYPE)=""
  1.  I $G(BARDBG) W !!!,"CHECKING FOR NEGATIVE BALANCE IF MATCHED ERA CLAIMS ARE POSTED..."  ;bar*1.8*20
  1.  N BARBILL,BARANS,BARTOT,BARPAY,BARADJ,ADJDA,ERRORS,CHECKTOT,ALLADJ
  1.  N ERACHECK,CLMDA,TCLMDA,CLM,ERRORS,BILLCHOS,BARTYPE,BARREAS
  1.  S (BARBAL,BARTOT,ALLADJ)=0
  1.  K CHECKTOT
  1.  S BARBILL=""
  1.  K BARCNT,BARAMT,BARTOT  ;bar*1.8*20
  1.  S CLMCNT=0
  1.  S CLMDA=0
  1.  K ^XTMP("BAR-LIST",$J,DUZ(2))
  1.  F  S CLMDA=$O(^BAREDI("I",DUZ(2),"F",BARCHK,IMPDA,CLMDA)) Q:'CLMDA  D
  1.  .S BARBILL=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U)
  1.  .S ^XTMP("BAR-LIST",$J,DUZ(2),BARBILL,CLMDA)=""
  1.  S BARBILL=""
  1.  F  S BARBILL=$O(^XTMP("BAR-LIST",$J,DUZ(2),BARBILL)) Q:BARBILL=""  D
  1.  .S CLMCNT=+$G(CLMCNT)+1  ;bar*1.8*20 REQ4
  1.  .S BARPAY=0
  1.  .;WAS A BILL CHOSEN OR MATCHED EARLIER IN BAR50P04?
  1.  .S CLMDA=0,BILLCHOS=""
  1.  .F  S CLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,"B",BARBILL,CLMDA)) Q:'CLMDA  D
  1.  ..S CLMCNT=CLMCNT+1
  1.  ..S (BARTOT,BARADJ,BARPAY)=0
  1.  ..S BILLCHOS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,1)),U)  ;A-CLAIM ; IF THIS IS POPULATED THEN THE CORRCET BILL WAS FOUND OR CHOSEN ALREADY
  1.  ..S BARSTAT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)  ;bar*1.8*20 REQ5
  1.  ..S BARTOT("CNT")=+$G(BARTOT("CNT"))+1,BARTOT("AMT")=+$G(BARTOT("AMT"))+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4) ;bar*1.8*20
  1.  ..I BARSTAT="M" S BARCNT("MATCHED")=+$G(BARCNT("MATCHED"))+1,BARAMT("MATCHED")=+$G(BARAMT("MATCHED"))+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)  ;bar*1.8*20
  1.  ..I BARSTAT'="M" S BARCNT("UNMATCHED")=+$G(BARCNT("UNMATCHED"))+1,BARAMT("UNMATCHED")=+$G(BARAMT("UNMATCHED"))+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)  ;bar*1.8*20
  1.  ..Q:BARSTAT'="M"  ;only display matched claims bar*1.8*20
  1.  ..I $G(BARDBG) W !!,CLMCNT,?4,"ERA BILL: ",BARBILL  ;bar*1.8*20 REQ4
  1.  ..I BILLCHOS S BARBLIEN=BILLCHOS
  1.  ..E  S BARBLIEN=$$GETIEN("B",BARBILL)
  1.  ..I BARBLIEN="BILL NOT FOUND" D
  1.  ...I '$D(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,"B",11)) D
  1.  ....S ERRORS("BL NF")=""  ;BILL NOT FOUND IN RPMS. SET ONLY IF OLD ERROR 11 NOT SET
  1.  ..I BARBLIEN="DUPLICATE BILLS FOUND" D
  1.  ...S ERRORS("DUPB")=""  ;DUPLICATE BILLS FOUND IN RPMS
  1.  ..I BARBLIEN S BARBAL=$$GET1^DIQ(90050.01,BARBLIEN_",",15,"I")  ;CURRENT BILL AMOUNT
  1.  ..E  S BARBAL=0
  1.  ..I $G(BARDBG) W ?41,"CURRENT BILL AMT(RPMS): ",$J($FN(BARBAL,",",2),14)  ;bar*1.8*20 REQ4
  1.  ..;
  1.  ..S BARADJ=0
  1.  ..I $$DONOTPR(IMPDA,CLMDA) Q  ;new code
  1.  ..;Q:$$OVERIDE^BAR50EP1(CLMDA)  ;MRS:BAR*1.8*10 D159-1 AND 2
  1.  ..;Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P"  ;DON'T PROCESS POSTED CLAIMS
  1.  ..;S CLSTATUS=$P($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," ")  ;E-CLAIM STATUS CODE (CLP02)
  1.  ..;I CLSTATUS="" S CLSTATUS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,4)  ;MRS:BAR*1.8*10 H2555
  1.  ..;Q:(U_"1"_U_"2"_U_"3"_U_"4"_U_"19"_U_"20"_U_"21"_U_"22"_U)'[(U_CLSTATUS_U)  ;ADDED 4 (DENIALS) PER EMAIL OF 7/31
  1.  ..;DENIAL ADJUSTMENTS CLP02=4 WERE CREATING NEGATIVE BALANCES
  1.  ..S ERACHECK=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U)
  1.  ..S BARAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,4)
  1.  ..S BARPAY=BARPAY+BARAMT
  1.  ..I $G(BARDBG) W !?3,$S(BARBILL'=$$GET1^DIQ(90050.01,BILLCHOS,".01"):"("_$$GET1^DIQ(90050.01,BILLCHOS,".01")_")",1:""),?59,"PYMT: ",$J($FN(BARAMT,",",2),14)  ;bar*1.8*20 REQ4
  1.  ..;
  1.  ..;S CHECKTOT(ERACHECK)=$G(CHECKTOT(ERACHECK))+BARAMT  ;bar*1.8*28 IHS/SD/SDR CR8346 HEAT275351
  1.  ..I ((BARSTAT="M")&(+$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,0))=0)) S CHECKTOT(ERACHECK)=$G(CHECKTOT(ERACHECK))+BARAMT  ;only count postable amounts  ;bar*1.8*28 IHS/SD/SDR CR8346 HEAT275351
  1.  ..S ADJDA=0
  1.  ..F  S ADJDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA)) Q:'+ADJDA  D
  1.  ...S BARAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,30,ADJDA,0)),U,2)
  1.  ...S BARCAT=$$GET1^DIQ(90056.0208,ADJDA_","_CLMDA_","_IMPDA_",",.04,"E")
  1.  ...S BARCATN=$$GET1^DIQ(90056.0208,ADJDA_","_CLMDA_","_IMPDA_",",.04,"I") ;P.OTT 2/6/2014 HEAT151948
  1.  ...S BARREAS=$$GET1^DIQ(90056.0208,ADJDA_","_CLMDA_","_IMPDA_",",.05,"E")
  1.  ...I $G(BARDBG) W !?3,"A/R CAT:",$E(BARCAT,1,11) ;,"  (",BARCAT,")" R ASD
  1.  ...I $G(BARDBG) W ?23,"A/R RSN:",$E(BARREAS,1,27)
  1.  ...I $G(BARDBG) W ?60,"ADJ:",$J($FN(BARAMT,",",2),15)
  1.  ...I BARCATN=21 Q  ;PENDING  3/5/14 P.OTT HEAT151948
  1.  ...I BARCATN=22 Q  ;GEN INFO P.OTT HEAT151948
  1.  ...S BARADJ=BARADJ+BARAMT
  1.  ...S ALLADJ=ALLADJ+BARAMT
  1.  ..S BARTOT=BARPAY+BARADJ
  1.  ..I $G(BARDBG) W !,?28,"BILL BALANCE IF ERA CLAIM IS POSTED: ",$J($FN(BARBAL-BARTOT,",",2),14)
  1.  ..;---chk for neg bal
  1.  ..I ((BARSTAT="M")&(+$O(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,4,0))'=0)) Q  ;bar*1.8*28 IHS/SD/SDR CR8346 HEAT275351
  1.  ..I BARBAL-BARTOT<0 D
  1.  ...Q:BARSTAT'="M"!($D(ERRORS("DUPB")))  ;don't put error on claim if not matched or if duplicate bills  bar*1.8*20 REQ5
  1.  ...I '$$IHSNEGB^BARUFUT(DUZ(2)) Q  ;P.OTT 2/5 2014 HEAT147572
  1.  ...S ERRORS("NEGR")=""
  1.  ..I $D(ERRORS) D ADDREAS^BAR50P04(IMPDA,CLMDA,.ERRORS)  ;IHS/DIT/CPC 1.8*28 - Move out of loop 
  1.  ...;S TCLMDA=""
  1.  ...;F  S TCLMDA=$O(^BAREDI("I",DUZ(2),IMPDA,30,"B",BARBILL,TCLMDA)) Q:TCLMDA=""  D
  1.  ....;I $$DONOTPR(IMPDA,CLMDA) Q  ;new code
  1.  ....;Q:$$OVERIDE^BAR50EP1(TCLMDA)                         ;MRS:BAR*1.8*10 D159-1 AND 2
  1.  ....;Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,30,TCLMDA,0)),U,2)="P"  ;DON'T PROCESS POSTED CLAIMS
  1.  ....;S CLSTATUS=$P($P($G(^BAREDI("I",DUZ(2),IMPDA,30,TCLMDA,0)),U,11)," ")  ;E-CLAIM STATUS CODE (CLP02) BAR*1.8*6 IM29637
  1.  ....;I CLSTATUS="" S CLSTATUS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,4)  ;MRS:BAR*1.8*10
  1.  ....;Q:(U_"1"_U_"2"_U_"3"_U_"4"_U_"19"_U_"20"_U_"21"_U_"22"_U)'[(U_CLSTATUS_U)  ;ADDED 4 (DENIALS) PER EMAIL/CONVERSATION WITH ADRIAN 7/31
  1.  ....;D ADDREAS^BAR50P04(IMPDA,TCLMDA,.ERRORS)
  1.  ..K ERRORS
  1.  ..; ------
  1.  D CHECKTOT(.CHECKTOT) ;CHECK ERA CHECK TOTALS AGAINST BATCH/ITEM TOTAL
  1.  Q
  1.  ;
  1. CHECKTOT(CHECKTOT) ;CHECK ERA CHECK TOTALS AGAINST BATCH/ITEM TOTAL
  1.  N ERRORS,CLMDA,ALLPAY,ERACHECK,CLSTATUS
  1.  N BPR02  ;BAR*1.8*6 SCR119 IHS/SD/TPF
  1.  W !
  1.  W !?2,"  Matched Bills: ",$J(+$G(BARCNT("MATCHED")),5)," for $",$J($FN(+$G(BARAMT("MATCHED")),",",2),12)
  1.  W !?2,"Unmatched Bills: ",$J(+$G(BARCNT("UNMATCHED")),5)," for $",$J($FN(+$G(BARAMT("UNMATCHED")),",",2),12)
  1.  W !?2,"    Total Bills: ",$J(+$G(BARTOT("CNT")),5)," for $",$J($FN(+$G(BARTOT("AMT")),",",2),12)
  1.  W !
  1.  S ERACHECK="" F  S ERACHECK=$O(CHECKTOT(ERACHECK)) Q:ERACHECK=""  D
  1.  .S CLMDA=""
  1.  .S CLMDA=$O(^BAREDI("I",DUZ(2),"F",ERACHECK,IMPDA,CLMDA))
  1.  .S BPR02=+$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,5)  ;BPR MONETARY AMOUNT BAR*1.8*6 SCR119 IHS/SD/TPF
  1.  .I $G(BARDBG) W !?2,"CHECKING ERA CHECK TOTALS FOR ",ERACHECK," TOTAL ",$J($FN(CHECKTOT(ERACHECK),",",2),15)  ;bar*1.8*20 REQ4
  1.  .;
  1.  .D GETITMTO(ERACHECK,CHECKTOT(ERACHECK),.ERRORS,BPR02)  ;GET BATCH/ITEM TOTAL  BAR*1.8*6 SCR119 IHS/SD/TPF
  1.  .I $D(ERRORS) D
  1.  ..S CLMDA=""
  1.  ..F  S CLMDA=$O(^BAREDI("I",DUZ(2),"F",ERACHECK,IMPDA,CLMDA)) Q:CLMDA=""  D
  1.  ... I $$DONOTPR(IMPDA,CLMDA) Q  ;new code
  1.  ... ;Q:$$OVERIDE^BAR50EP1(CLMDA)     ;MRS:BAR*1.8*10 D159-1 AND 2
  1.  ... ;Q:$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P"  ;DON'T PROCESS POSTED CLAIMS
  1.  ... ;S CLSTATUS=$P($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," ")  ;E-CLAIM STATUS CODE (CLP02) BAR*1.8*6 IM29637
  1.  ... ;I CLSTATUS="" S CLSTATUS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,4)  ;MRS:BAR*1.8*10
  1.  ... ;Q:(U_"1"_U_"2"_U_"3"_U_"4"_U_"19"_U_"20"_U_"21"_U_"22"_U)'[(U_CLSTATUS_U)  ;ADDED 4 (DENIALS) PER EMAIL/CONVERSATION WITH ADRIAN 7/31
  1.  ... D ADDREAS^BAR50P04(IMPDA,CLMDA,.ERRORS)
  1.  .K ERRORS
  1.  Q
  1.  ;
  1. GETIEN(BARX,BARBILL) ;EP - FIND AR BILL IEN
  1.  N BARTMP
  1.  S (BARBIEN,BARCNT)=0
  1.  I '$D(^BARBL(DUZ(2),"B",BARBILL)) S BARX="G"   ; Pharmacy POS
  1.  F  S BARBIEN=$O(^BARBL(DUZ(2),BARX,BARBILL,BARBIEN)) Q:'+BARBIEN  D
  1.  . S BARCNT=BARCNT+1
  1.  . S BARTMP(BARBIEN)=""
  1.  I BARCNT=0 Q "BILL NOT FOUND"   ;BILL NOT FOUND IN RPMS
  1.  I BARCNT>1 Q "DUPLICATE BILLS FOUND"   ;DUPES FOUND
  1.  S BARBIEN=$O(BARTMP(""))
  1.  Q BARBIEN
  1.  ;
  1. XGETIEN(BARX,BARBILL) ;NEW CODEEP - FIND AR BILL IEN 12/10/2013
  1.  N BARTMP,BARXBILL,BARRET
  1.  S BARRET=""
  1.  S BARX="G",BARXBILL=BARBILL
  1.  I $D(^BARBL(DUZ(2),BARX,BARXBILL)) S BARRET=$$GETIT() Q BARRET
  1.  S BARX="G",BARXBILL=+BARBILL
  1.  I $D(^BARBL(DUZ(2),BARX,BARXBILL)) S BARRET=$$GETIT() Q BARRET
  1.  S BARX="B",BARXBILL=BARBILL
  1.  I $D(^BARBL(DUZ(2),BARX,BARXBILL)) S BARRET=$$GETIT() Q BARRET
  1.  S BARX="B",BARXBILL=+BARBILL
  1.  I $D(^BARBL(DUZ(2),BARX,BARXBILL)) S BARRET=$$GETIT() Q BARRET
  1.  Q BARRET
  1. GETIT() N BARBIEN
  1.  S BARCNT=0
  1.  S BARBIEN=0 F  S BARBIEN=$O(^BARBL(DUZ(2),BARX,BARXBILL,BARBIEN)) Q:'+BARBIEN  D
  1.  . S BARCNT=BARCNT+1
  1.  . S BARTMP(BARBIEN)=""
  1.  I BARCNT=0 Q "BILL NOT FOUND"   ;BILL NOT FOUND IN RPMS
  1.  I BARCNT>1 Q "DUPLICATE BILLS FOUND"   ;DUPES FOUND
  1.  S BARBIEN=$O(BARTMP(""))
  1.  Q BARBIEN
  1.  ;
  1. GETITMTO(ERACHECK,ERATOTAL,ERRORS,BRP02) ;EP - GIVEN ERACHECK GET BATCH ITEM TOTALS FOR ERA CHECK ;BAR*1.8*6 SCR119 IHS/SD/TPF
  1.  N BARCOLDA,BARITMDA,ITEMTOT,BARXCHK,BARTODAY,%H ;P.OTT
  1.  ;S X=DT D H^%DTC ;GET $H-FORMAT
  1.  S BARTODAY=+$H ;%H
  1.  S BARXCHK=$$BARXCHK^BAREDP09(ERACHECK) ;P.OTT
  1.  S BARCOLDA=$O(^BARCOL(DUZ(2),"D",BARXCHK,""))
  1.  I 'BARCOLDA,(BPR02=0) Q  ;BAR*1.8*6 SCR119 DON'T REQUIRE A BATCH NONPAY CHECK FOR A BPR02=0 IHS/SD/TPF
  1.  I 'BARCOLDA D  Q
  1.  .S ERRORS("NB")=""  ;NO BATCH FOUND FOR ERA CHECK
  1.  .I $G(BARDBG) W !,"NO BATCH FOUND FOR ERA CHECK"
  1.  W !
  1.  S BPOSTBAL=0 ;BATCH POSTING BALANCE
  1.  S BARCOLDA="" F  S BARCOLDA=$O(^BARCOL(DUZ(2),"D",BARXCHK,BARCOLDA)) Q:BARCOLDA=""  D
  1.  .NEW X,BARCBDT,BARCB ;P.OTT
  1.  .S BARCB=$$GET1^DIQ(90051.01,BARCOLDA_",",.01,"A")
  1.  .S X=$$GET1^DIQ(90051.01,BARCOLDA_",",4,"I")
  1.  .D H^%DTC ;GET $H-FORMAT
  1.  .S BARCBDT=%H
  1.  .IF BARTODAY-BARCBDT>365 D  Q  ;DONT SHOW THIS MSG: 10/10/2013 
  1.  .;;;. S BARMSG="IGNORING COLL. BATCH "_BARCB_" EIN# "_BARCOLDA_" TOO OLD: ("_X_")"
  1.  .;;;. I $G(BARDBG) W !,BARMSG
  1.  .;
  1.  .I $G(BARDBG) W !,?2,"CHECKING BATCH: ",BARCB ;P.OTT SHOW ONLY 'NEW' CB 10/10/2013 
  1.  .S BPOSTBAL=BPOSTBAL+$$GET1^DIQ(90051.01,BARCOLDA_",",17,"E")  ;BAR*1.8*6 LOOK AT BATCH POSTING TOTAL NOT ITEM CREDIT TOTALS
  1.  .I $G(BARDBG) W " POSTING BALANCE: ",BPOSTBAL
  1.  I ERATOTAL>BPOSTBAL D
  1.  .I '$$IHSNEGB^BARUFUT(DUZ(2)) Q  ;P.OTT 2/6 2014 HEAT147572
  1.  .S ERRORS("ERA > ITM")=""  ;ERA TOTAL GREATER THAN BATCH/ITEM TOTAL
  1.  .I $G(BARDBG) D  ;
  1.  ..W !,"ERA TOTAL PAYMENTS AND ADJUSTMENTS OF ",ERATOTAL
  1.  ..W !,"IS GREATER THAN BATCH POSTING BALANCE OF ",BPOSTBAL
  1.  Q
  1. DONOTPR(IMPDA,CLMDA) ;CALLED FROM 3 DIFFERENT PLACES
  1.  N CLSTATUS
  1.  I $$OVERIDE^BAR50EP1(CLMDA) Q 1  ;MRS:BAR*1.8*10 D159-1 AND 2
  1.  I $P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,2)="P"  Q 2 ;DON'T PROCESS POSTED CLAIMS
  1.  S CLSTATUS=$P($P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,0)),U,11)," ")  ;E-CLAIM STATUS CODE (CLP02)
  1.  I CLSTATUS="" S CLSTATUS=$P($G(^BAREDI("I",DUZ(2),IMPDA,30,CLMDA,2)),U,4)  ;MRS:BAR*1.8*10 H2555
  1.  I (U_"1"_U_"2"_U_"3"_U_"4"_U_"19"_U_"20"_U_"21"_U_"22"_U)'[(U_CLSTATUS_U) Q 3  ;ADDED 4 (DENIALS) PER EMAIL OF 7/31
  1.  ;DENIAL ADJUSTMENTS CLP02=4 WERE CREATING NEGATIVE BALANCES
  1.  Q 0
  1.  ;EOR - IHS/DIT/CPC 1.8*28