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

BARUFEX5.m

Go to the documentation of this file. 
  1. BARUFEX5 ; IHS/SD/TPF - CONTINUATION OF EXPORT -- BUILD BOB FILE ; 09/17/2008
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,5,6,7,23**;OCT 26, 2005
  1.  ;NEW ROUTINE; ITEM 1 OF SCR58 1/2/2008 ;MRS:BAR*1.8*4 DD ITEM 4.1.1
  1.  ;HEAT54733 APR 2012 P.OTT bug fix <SUBSCRIPT>SETORIG+2^BARUFEX5
  1.  ;HEAT93190 DEC 2012 P.OTTIS NOHEAT MARK / IGNORE DUPLICATE GHOST BILLS (SAME PAT, BUT MISSING CLAIM IN 3PB)
  1.  ;NOHEAT MAR 2013 P.OTTIS ADDED NEW VA billing 
  1.  ;
  1. PRE(BARBG,BARDUZ) ;EP;
  1.  ;
  1.  ; ENTERS WITH TRANSACTION BEGIN DATE
  1.  ;  AND BARDUZ = DUZ OF USER
  1.  ;
  1.  K ^BARBOB("BARZ",BARDUZ)
  1.  K ^BARBOB("BARZZ",BARDUZ)
  1.  K ^BARZZZ("BARZ")  ;MRS:BAR*1.8*6
  1.  D NOW^%DTC
  1.  S PRELIVLM=3071001  ;FOR RELEASE
  1.  S ^BARBOB("BARZ",BARDUZ,"BEGIN")=%
  1.  N BARX,BARY,BARZ,BARIDT,BART,BARBDA,BARTX,BAR,BARREV,BARFLG,TRDATE
  1.  S SAFEDUZ=DUZ(2)
  1.  S BARTOTX=0  ;XTMP COUNTER
  1.  ;BEGIN EXCLUSION CHECKS
  1.  D SETZZ(BARDUZ)   ;BUILD FILE OF PAYMENTS IN DATE RANGE
  1.  S DUZ(2)=0
  1.  F  S DUZ(2)=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2))) Q:'DUZ(2)  D
  1.  .S BARBDA=0
  1.  .F  S BARBDA=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA)) Q:'BARBDA  D
  1.  ..S BARBILL=$G(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA))
  1.  ..Q:'BARBILL   ;BILL HAS DA BUT NOT NAME
  1.  ..S BARBL0=$G(^BARBL(DUZ(2),BARBDA,0))
  1.  ..S ABMDUZ2=$P(BARBL0,U,22)
  1.  ..Q:'ABMDUZ2   ;NO 3P DUZ(2)
  1.  ..S ABMIEN=$P(BARBL0,U,17)
  1.  ..Q:'ABMIEN  ;NO 3P BILL IEN
  1.  ..I $$BILL^ABMUEAPI(ABMDUZ2,ABMIEN)<1 Q  ;3P EXCLUSION
  1.  .. Q:'$$IHS^BARUFUT(ABMDUZ2)
  1.  ..;;;Q:'$$IHSERA^BARUFUT(ABMDUZ2) ;P.OTT
  1.  ..S BARACCT=$$GETBACC^BARUFEXU(BARBDA)   ;A/R BILL, A/R ACCOUNT
  1.  ..Q:'BARACCT   ;NO INSURER
  1.  ..S D0=BARACCT
  1.  ..S BARITYP=$$VALI^BARVPM(8)   ;GET 'VIP INSURER TYPE' CODE (NUMBER)
  1.  ..I BARITYP="I"!(BARITYP="T") Q  ;EXCLUDE 'INDIAN' OR 'THIRD PARTY BILLING' PER MEETING OF 5/4/2007
  1.  ..; Check 3P transmitted date
  1.  ..S BARPLOC=$$GETPLOC  ;A/R BILL, PARENT LOCATION
  1.  ..Q:'BARPLOC
  1.  ..;S UFMSSUFC=$$PRELIVE(ABMDUZ2,ABMIEN,BARITYP,BARPLOC)  ;MRS:BAR*1.8*7
  1.  ..;I UFMSSUFC="" Q   ;MRS:BAR*1.8*7
  1.  ..;
  1. TX ..;NOW HAVE A BILL TO CHECK
  1.  ..S TRDATE=0
  1.  ..F  S TRDATE=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)) Q:'TRDATE  D
  1.  ...S IENS=TRDATE_","
  1.  ...S BARPAY=$$GET1^DIQ(90050.03,IENS,3.5,"E")  ;CREDIT - DEBIT
  1.  ...Q:BARPAY=0  ;DON'T LOOK AT 0 PAYMENTS
  1.  ...S BARTX0=$G(^BARTR(DUZ(2),TRDATE,0))
  1.  ...S BARCB=$P(BARTX0,U,14)   ;COLLECTION BATCH IEN;GET EXTERNAL NAME LATER
  1.  ...S BARCI=$P(BARTX0,U,15)   ;COLLECTION ITEM
  1.  ...I BARCB=""!(BARCI="") Q   ;NOT IN BATCH/ITEM
  1.  ...S BARZZ0=^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)
  1.  ...S BARFLG=$S(BARZZ0]"":BARZZ0,1:0)   ;CHECK FOR -25 CODE FLAG
  1.  ...S (BARREV,BAROTX)=""  ;INIT ORIGINAL TX
  1.  ...S BARIPAC=$$IPAC^BARUFEX4(BARCB,BARCI,IENS)  ;SCHEDULE NUMBER/IPAC
  1.  ...D CLEAN
  1.  ...I BARPAY<0,BARFLG'=-25 D
  1.  ....S BARXPAC=$$REV(BARBDA,BARPAY,BARIPAC) ;CHECK REVERSAL
  1.  ....;RETURNS CODE_U_RESCHED_U_ORIGTX
  1.  ....S BARFLG=$P(BARXPAC,U)   ;WHAT FOUND FLAG
  1.  ....S BARIPAC=$P(BARXPAC,U,2)
  1.  ....I BARFLG=2 D   ;SIMPLE REVERSAL
  1.  .....S BAROTX=$P(BARXPAC,U,3)  ;ORIGINAL TRANSACTION
  1.  .....I BAROTX="" QUIT  ;P.OTT
  1.  .....D SETORIG(BAROTX,.BARFLG)  ;RETURNS ORIGINAL REFERENCES
  1.  .....S ^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDATE)=2
  1.  ....I $E(BARFLG)="-" D CODE(BARBDA,BARFLG)
  1.  ...S ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)=BARPAY_U_BARIPAC_U_BARBDA_U_BARBILL_U_BARFLG
  1.  D COLCK   ;CHECK BATCH/ITEM FOR PAIRS
  1.  D NOW^%DTC
  1.  S ^BARBOB("BARZ",BARDUZ,"END")=%
  1.  S DUZ(2)=SAFEDUZ
  1.  Q
  1.  ;
  1. SETORIG(TRDT,BARFLG) ;FLAG ORIGINAL PAYMENT WHEN SIMPLE REVERSAL IS FOUND
  1.  N BARO0,BAROCB,BAROCI
  1.  S BARO0=$G(^BARTR(DUZ(2),TRDT,0))
  1.  S BAROCB=$P(BARO0,U,14)   ;COLLECTION BATCH IEN;GET EXTERNAL NAME LATER
  1.  Q:'BAROCB
  1.  S BAROCI=$P(BARO0,U,15)   ;COLLECTION ITEM
  1.  Q:'BAROCI
  1.  S BARFLG=BARFLG_U_BARCB_U_BARCI_U_TRDATE
  1.  S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BAROCB,BAROCI,TRDT),U,5)=BARFLG
  1.  S BARFLG=BARFLG_U_BAROCB_U_BAROCI_U_TRDT
  1.  S ^BARBOB("BARZZ",BARDUZ,DUZ(2),BARBDA,TRDT)=2
  1.  Q
  1.  ;
  1. COLCK ; NOW BEGIN PAIRS CHECK IN COLLECTION BATCH/ITEM
  1.  ;
  1.  N BARCB,BARCI,TRDATE,BARNEG,BAR,BARPAY,BAR7
  1.  S DUZ(2)=0
  1.  F  S DUZ(2)=$O(^BARBOB("BARZ",BARDUZ,DUZ(2))) Q:'DUZ(2)  D
  1.  .S BARCB=0
  1.  .F  S BARCB=$O(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB)) Q:'BARCB  D
  1.  ..S BARCI=0
  1.  ..F  S BARCI=$O(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)) Q:'BARCI  D
  1.  ...S (TRDATE,BARNEG,BAR7)=0
  1.  ...K BAR   ;CLEAR LOCAL ARRAY
  1.  ...F  S TRDATE=$O(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)) Q:'TRDATE  D
  1.  ....S BAR0=^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE)
  1.  ....S BARDA=$P(BAR0,U,3)
  1.  ....S BARFLG=$P(BAR0,U,5)
  1.  ....S BARFLGZ=$G(^BARBOB("BARZZ",BARDUZ,DUZ(2),BARDA,TRDATE))
  1.  ....I BARFLG=0,BARFLGZ'="" S BARFLG=BARFLGZ
  1.  ....I $E(BARFLG)="-" D
  1.  .....S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,TRDATE),U,5)=BARFLG
  1.  .....S $P(BAR0,U,5)=BARFLG
  1.  .....S BAR7=3
  1.  ....S BARAMT=$P(BAR0,U,1)
  1.  ....I BARAMT<0 S BARNEG=1
  1.  ....S BAR(TRDATE)=BAR0
  1.  ...I BARNEG D PAIRS(.BAR,BAR7) Q   ;REVERSAL FOUND
  1.  ...S BARFLG=$S(BAR7'=0:2,1:1)
  1.  ...S ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)=BARFLG
  1.  Q
  1.  ;
  1. PAIRS(BAR,BAR7) ;LOOK FOR OK PAIRS OF PAYMENTS AND REVERSALS
  1.  ;BAR STRING = BARPAY_U_BARIPAC_U_BARBDA_U_BARBILL_U_BARFLG
  1.  ;   I BARFLG=-4 or -7  ;MULTIPLE MATCHES -- DON'T PAIR
  1.  ;   I BARFLG=-3 or -6  ;ORIGINAL NOT FOUND -- PAIR
  1.  ;ADDED CHECK FOR PERMANENT IGNORABLE PAIRS
  1.  ;  DEF: FIRST PAYMENT IS A REVERSAL
  1.  ;   SECOND PAYMENT MATCHES REVERSAL
  1.  ;   AND BOTH ARE IN SAME BILL AND BATCH/ITEM
  1.  ;
  1.  N BARI,BARJ,BARCNT
  1.  S ^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI)=BAR7 ;REVERSALS IN BATCH
  1.  S BARCNT=0
  1.  ;
  1. AGAIN S BARI=0
  1. I S BARI=$O(BAR(BARI))
  1.  Q:'BARI
  1.  S BARCNT=BARCNT+1
  1.  S BARIFLG=$P(BAR(BARI),U,5)
  1.  I BARIFLG=2 K BAR(BARI) G I   ;FLAGGED AS SIMPLE TX/REV
  1.  I BARIFLG=-4!(BARIFLG=-7)!(BARIFLG=-25) K BAR(BARI) G I ;COMPLEX OR DUPLICATE
  1.  S BARJ=0
  1. J S BARJ=$O(BAR(BARJ))
  1.  I 'BARJ G I
  1.  S BARJFLG=$P(BAR(BARJ),U,5)
  1.  I BARJFLG=2 K BAR(BARJ) G J   ;FLAGGED AS ORIGINAL TX OR REV
  1.  I BARJFLG=-4!(BARJFLG=-7)!(BARJFLG=-25) K BAR(BARI) G I ;COMPLEX OR DUPLICATE
  1.  I $P(BAR(BARI),U,1,3)=$P(BAR(BARJ),U,1,3) G J   ;DON'T CHECK SELF
  1.  ;CHECK AMOUNT
  1.  S BARIAMT=$P(BAR(BARI),U)
  1.  S BARJAMT=$P(BAR(BARJ),U)
  1.  I BARIAMT'=-BARJAMT G J   ;ABSOLUTE AMOUNTS DON'T MATCH
  1.  ;CHECK TREAS SCHED #
  1.  I $P(BAR(BARI),U,2)=$P(BAR(BARJ),U,2) D  G AGAIN  ;KEEP CHECKING
  1.  .I BARCNT=1 D  Q:'$D(BAR(BARI))
  1.  ..I $P(BAR(BARI),U,3)'=$P(BAR(BARJ),U,3) Q  ;NOT MATCHING BILLS
  1.  ..I BARIAMT<0,BARJAMT>0 D PAIR("-I")  ;FOUND IGNORABLE PAIR
  1.  .D PAIR(1)
  1.  G J
  1.  ;
  1. PAIR(Z) ;FOUND A MATCH -- FLAG TRANSACTIONS AS GOOD TO GO OR CODE "-I"
  1.  N FLG
  1.  S FLG=Z_U_BARCB_U_BARCI_U_BARJ
  1.  S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,BARI),U,5)=FLG
  1.  K BAR(BARI)   ;REMOVE ENTRY
  1.  S FLG=Z_U_BARCB_U_BARCI_U_BARI
  1.  S $P(^BARBOB("BARZ",BARDUZ,DUZ(2),BARCB,BARCI,BARJ),U,5)=FLG
  1.  K BAR(BARJ)
  1.  Q
  1.  ;
  1. REV(BARBDA,BARPAY,TIPAC) ; FIND SIMPLE REVERSAL SCHEDULE NUMBER ;HEAVILY MODIFIED FOR BAR*1.8*5 IM29449 
  1.  N Y,Z,SCHED,CODE,BARRDT,BARRTDN,BARR1
  1.  S Y=""
  1.  S BARR1=$G(^BARTR(DUZ(2),TRDATE,1))
  1.  I $P(BARR1,U,12)="I" Q "I"  ;IGNORE TRANSACTION MRS:BAR*1.8*6 IM29571
  1.  S BARRDT=$P(BARR1,U,10)   ;REVERSAL DATE/TIME
  1.  I BARRDT]"" D  ;GET MATCHED TRANSACTION   ;NEW CHECK FOR MATCHES BAR*1.8*5 IM29571
  1.  .I BARRDT'["." S BARRDT="" Q  ;IMCOMPLETE TX DATE; CHECK FURTHER
  1.  .S BARRTDN=$P(BARR1,U,11)   ;REVERSAL TDN/IPAC
  1.  .;S:BARRTDN="" BARRTDN="PRE MODIFICATIONS"  ;LEAVE BLANK;MRS:BAR*1.8*6
  1.  .I '$G(^BARTR(DUZ(2),BARRDT,0)) S REV=0 Q
  1.  .S TAMT=$$GET1^DIQ(90050.03,BARRDT_",",3.5,"E")
  1.  .I +$G(BARPAY)'=-TAMT S REV=0 Q
  1.  .S REV=$P(BARRDT,".")_U_BARRTDN_U_BARRDT
  1.  ;
  1.  I BARRDT="" D
  1.  .S REV=$$FINDTRAN(BARBDA,BARPAY) ;FIND ORIGINAL RECEIPT
  1.  .; RETURNS REVDATE_U_RESCHED_U_ORIGTX, NUMBER OF MULTIPLES, OR 0 IF CAN'T FIND
  1.  S SCHED=$P(REV,U,2)
  1.  S Y=$P($G(^BARTR(DUZ(2),TRDATE,1)),U,6)
  1.  ;
  1.  I 'REV D  Q CODE_U_TIPAC  ;CAN'T FIND THE ORIGINAL DATE
  1.  .S CODE=$S(Y="e":-3,1:-6)
  1.  I REV'[U D  Q CODE_U_TIPAC  ;MATCHES/REV ARE>1, NOT STRING
  1.  .S CODE=$S(Y="e":-4,1:-7)
  1.  Q 2_U_$P(REV,U,2,3)   ;RETURN SCHED AND ORIGINAL TX
  1.  ;
  1. PRELIVE(ABMDUZ2,ABMIEN,BARITYP,BARPLOC) ;
  1.  Q   ;MRS:BAR*1.8*7
  1.  N TPBAPDT,TPBEXDT
  1.  S UFMSSUFC=""
  1.  S TPBAPDT=$$APPRDTTM^ABMUEAPI(ABMDUZ2,ABMIEN)  ;API 3P APPROVAL DATE
  1.  I TPBAPDT="" Q UFMSSUFC
  1.  ;
  1.  ;Prelive logic for 'APPLY TO' or ASUFACASUFAC3PIEN string
  1.  ;If Date/Time Approved < 10/1/2007 then UFMSSUFC=$$PRELIVE instead
  1.  ;If this is true there will be no delay send at all
  1.  ;
  1.  ;I TPBAPDT<PRELIVLM D  Q UFMSSUFC  ;IHS/SD/SDR bar*1.8*4 SCR100
  1.  S BAR08DT=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5)  ;IHS/SD/SDR bar*1.8*4 SCR100
  1.  I TPBAPDT<PRELIVLM!(TPBAPDT<BAR08DT) D  Q UFMSSUFC  ;IHS/SD/SDR bar*1.8*4 SCR100
  1.  .S BARAREA=$$GET1^DIQ(9999999.06,BARPLOC_",",.04,"I") ;LOCATION, AREA PTR
  1.  .S PRELIV=$$PRELIVE^BARUFUT1(BARAREA,BARITYP)
  1.  .S UFMSSUFC=PRELIV
  1.  ;
  1.  S UFMSSUFC=$$TRANSMIT^ABMUEAPI(ABMDUZ2,ABMIEN)
  1.  S:UFMSSUFC=-1 UFMSSUFC=""
  1.  Q UFMSSUFC
  1.  ;
  1. GETPLOC() ;
  1.  N BARPLOC,BARVLOC
  1.  S BARPLOC=$P(BARBL0,U,8)   ;A/R BILL, PARENT LOCATION
  1.  I BARPLOC Q BARPLOC
  1.  I 'BARPLOC D   ;Not found/or bad location
  1.  .S BARVLOC=$P($G(^BARBL(DUZ(2),BARBDA,1)),U,8) ;A/R BILL, VISIT LOCATION
  1.  .S BARPLOC=$$PARENT^BARUFEXU
  1.  Q BARPLOC
  1.  ;
  1. SETZZ(BARDUZ) ;CHECK FOR AT LEAST ONE PAYMENT IN DATE RANGE
  1.  N X,Y,Z,BARBILL,DUP,BARNUM,TRANTYPE
  1.  S DUZ(2)=0 F  S DUZ(2)=$O(^BARTR(DUZ(2))) Q:'DUZ(2)  D
  1.  . Q:'$$IHS^BARUFUT(DUZ(2))
  1.  . ;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;P.OTT
  1.  .S BARBEG=$$BARBEG(DUZ(2))
  1.  .S X=0
  1.  .F  S X=$O(^BARTR(DUZ(2),"AC",X)) Q:'X  D
  1.  ..S Y=$O(^BARTR(DUZ(2),"AC",X,""),-1)
  1.  ..I Y'>BARBEG Q   ;NO TRANSACTIONS IN DATE RANGE
  1.  ..S Y=0
  1.  ..F  S Y=$O(^BARTR(DUZ(2),"AC",X,Y)) Q:'Y  D
  1.  ...I $P($G(^BARTR(DUZ(2),Y,1)),U,12)="I" D  Q  ;FLAGGED AS IGNORABLE:MRS:BAR*1.8*6 IM29571
  1.  ....S ^BARBOB("BARZZ",BARDUZ,DUZ(2),"I",X)=""  ;MRS:BAR*1.8*6 IM29571
  1.  ...S IENS=Y_","
  1.  ...S TRANTYPE=$$GET1^DIQ(90050.03,IENS_",",101,"E")  ;TRANSACTION TYPE
  1.  ...Q:TRANTYPE'="PAYMENT"   ;ONLY WANT PAYMENTS
  1.  ...S BARBILL=$$GET1^DIQ(90050.03,IENS,4,"E")   ;A/R BILL
  1.  ...S DUP=$$DUP(BARBILL)  ;CHECK FOR DUPLICATE BILLS
  1.  ...S ^BARBOB("BARZZ",BARDUZ,DUZ(2),X)=BARBILL
  1.  ...S ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=DUP
  1.  Q
  1.  ;
  1. CODE(X,Z) ;FLAG ALL TRANSACTIONS FOR BILL WITH CODE -7 AND -4
  1.  ; ENTERS WITH X = BARBILL DA
  1.  ;   Z = CODE = -7 = MULTIPLE MAN TX W/IN BILL
  1.  ;  -6 = CANNOT FIND ORIG TX W/IN BILL
  1.  ;  -3 = SAME AS -6 FOR ERA TX
  1.  ;  -4 = SAME AS -7 FOR ERA TX
  1.  N Y
  1.  S Y=0
  1.  F  S Y=$O(^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)) Q:'Y  D
  1.  .I Z'=-25 Q:^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=2   ;HAS SIMPLE REVERSAL
  1.  .Q:^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=-25   ;DUPLICATE BILL
  1.  .S ^BARBOB("BARZZ",BARDUZ,DUZ(2),X,Y)=Z
  1.  Q
  1. DUP(ZZ) ;EP-CHECK FOR DUPLICATE BILLS
  1.  ;  ENTERS WITH BILL NUMBER
  1.  I ZZ="" Q ""
  1.  N YY,CNT
  1.  I '$D(^BARBL(DUZ(2),"B",ZZ)) Q ""
  1.  S (CNT,YY)=0
  1.  F  S YY=$O(^BARBL(DUZ(2),"B",ZZ,YY)) Q:'YY  D
  1.  . I $D(^BARBOB("BARZZ",BARDUZ,DUZ(2),"I",YY)) Q   ;IGNORABLE;MRS:BAR*1.8*6 IM29571
  1.  . S CNT=CNT+1
  1.  ;------------>P.OTT: RETURNS DUP="" FOR MANAGABLE DUP, -26 FOR GHOST
  1.  ;;;***** NOTE: TMP DISABLED FOR P23 DEC 30 2012 ***
  1.  ;;;I CNT=2 D FNDD Q QVAL ;CHECK IF ONE OF THESE 2 IS 'GHOST' (NONEX IN 3PB) ?
  1.  ;;;***** NOTE: TMP DISABLED FOR P23 DEC 30 2012 ***
  1.  ;<------------P.OTT
  1.  I CNT>1 Q -25 ;DUPLICATE
  1.  Q ""
  1. FNDD ;
  1.  NEW YY1,YY2,BAR3PEIN,BARDUZ3P,QVAL D
  1.  . S YY1=$O(^BARBL(DUZ(2),"B",ZZ,0))
  1.  . S BAR3PEIN=$P($G(^BARBL(DUZ(2),YY1,0)),"^",17)
  1.  . S BARDUZ3P=$P($G(^BARBL(DUZ(2),YY1,0)),"^",22)
  1.  . I BAR3PEIN="" S QVAL="" Q
  1.  . I BARDUZ3P="" S QVAL="" Q
  1.  . I '$D(^ABMDBILL(BARDUZ3P,BAR3PEIN,0)) S QVAL=-26 Q  ;GHOST
  1.  . S YY2=$O(^BARBL(DUZ(2),"B",ZZ,YY1))
  1.  . S BAR3PEIN=$P($G(^BARBL(DUZ(2),YY2,0)),"^",17)
  1.  . S BARDUZ3P=$P($G(^BARBL(DUZ(2),YY2,0)),"^",22)
  1.  . I BAR3PEIN="" S QVAL="" Q
  1.  . I BARDUZ3P="" S QVAL="" Q
  1.  . I '$D(^ABMDBILL(BARDUZ3P,BAR3PEIN,0)) S QVAL=-26 Q  ;GHOST
  1.  . S QVAL=""
  1.  . QUIT
  1.  Q
  1. BARBEG(X) ;SET BEGINING DATE FROM NOT SET CROSS-REFERENCE
  1.  ;
  1.  N Z
  1.  S:BARBG="" BARBG=3070930
  1.  S Z=$O(^BARSESS(X,"NS",""))
  1.  I Z=""!(Z>BARBG) S Z=BARBG  ;IF NO NS X-REF, OR BARBG<NS, USE SESS DATE
  1.  Q Z-1
  1. FINDTRAN(BARBLIEN,AMOUNT) ;EP -HEAVILY MODIFIED FOR NEW MATCHING;MRS:BAR*1.8*6 IM29571
  1.  ;AMOUNT SHOULD BE A NEGATIVE NUMBER
  1.  Q:'BARBLIEN 0
  1.  N TRANS,TAMOUNT,FOUND,REVDATE,COLDA,ITEMDA,REVSCHED,REVERSAL,BARFLG
  1.  S BARFLG=^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRDATE)
  1.  I BARFLG=2 D  Q $P(REVDATE,".")_U_REVSCHED  ;ALREADY MATCHED
  1.  .S BARTR0=^BARTR(DUZ(2),TRDATE,1)
  1.  .S REVDATE=$P(BARTR0,U,10)
  1.  .S REVSCHED=$P(BARTR0,U,11)
  1.  S AMOUNT=-AMOUNT  ;SET TO ABSOLUTE VALUE
  1.  S FOUND=0
  1.  S REVERSAL=0  ;NUMBER OF REVERSALS ALREADY SET UP FOR THIS AMOUNT. if even one sent to "ns"
  1.  S TRANS=TRDATE  ;WORK BACK TO EARLIER TRANSACTIONS
  1.  ;CHECK FOR MULTIPLES; REVERSAL CAN NOT APPLY TO A FUTURE PAYMENT
  1.  F  S TRANS=$O(^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRANS),-1) Q:'TRANS  D  ;CHECK FOR MULTIPLES; REVERSAL CAN NOT APPLY TO A FUTURE PAYMENT
  1.  .S BARFLG=^BARBOB("BARZZ",DUZ,DUZ(2),BARBLIEN,TRANS)
  1.  .Q:BARFLG=2  ;ALREADY MATCHED
  1.  .S TAMOUNT=$$GET1^DIQ(90050.03,TRANS_",",3.5,"E")
  1.  .I TAMOUNT=-AMOUNT,$$GET1^DIQ(90050.03,TRANS_",",110,"I") S REVERSAL=REVERSAL+1
  1.  .I TAMOUNT=AMOUNT S FOUND=FOUND+1 D
  1.  ..S REVDATE=$$GET1^DIQ(90050.03,TRANS_",",.01,"I")
  1.  ..S COLDA=$$GET1^DIQ(90050.03,TRANS_",",14,"I")
  1.  ..S ITEMDA=$$GET1^DIQ(90050.03,TRANS_",",15,"I")
  1.  ..S REVSCHED=$$GET1^DIQ(90051.1101,ITEMDA_","_COLDA_",",20,"I")
  1.  ..S:REVSCHED="" REVSCHED="PRE-UFMS_COLLECTIONS"
  1.  ..S REVSCHED=REVSCHED_U_TRANS   ;CAPTURE ORIGINAL TX
  1.  I REVERSAL>0 S FOUND=0
  1.  I FOUND=1 Q $P(REVDATE,".")_U_REVSCHED
  1.  Q FOUND
  1.  ;
  1. CLEAN ;CHECK FOR AND CLEAN POSSIBLE BAD DATA
  1.  ;FIX ANY TRANSACTION HAS A 0 REVERSAL DATE
  1.  I $P($G(^BARTR(DUZ(2),TRDATE,1)),U,10)=0 D DEPOP Q
  1.  ;
  1.  ; FIX TRANTYPE = PAYMENT WITH A REVERSAL DATE AND A POSITIVE AMT
  1.  I (BARPAY>0!(BARPAY=0)),$P($G(^BARTR(DUZ(2),TRDATE,1)),U,10) D
  1.  .D DEPOP
  1.  Q
  1. DEPOP ;EP - DE POPULATE IF REVERSAL DATES NOT FOUND
  1.  ;ONLY FOR BETA SITES
  1.  K DIR,DIE,DIC,DA,DR
  1.  S DA=TRDATE
  1.  S DR="110///@;111///@"
  1.  S DIE="^BARTR("_DUZ(2)_","
  1.  D ^DIE
  1.  K DIR,DIE,DIC,DA,DR
  1.  Q