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

BARPST3.m

Go to the documentation of this file. 
  1. BARPST3 ; IHS/SD/LSL - PAYMENT COMMAND PROCESSOR ; 12/29/2008
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,7,10,20,21,23,24**;OCT 26, 2005;Build 69
  1.  ;** 'Select Command' processor
  1.  ; IHS/SD/PKD  1.8*21 HEAT20490 - 3/18/11
  1.  ; Prevent Cashier from continuing to post in the same Session
  1.  ;   if Session t
  1.  ;
  1.  ;
  1.  ; IHS/SD/POTT HEAT76683 07/12 LIMIT COMMAND FORMAT & LENGTH  - BAR 1.8*23
  1.  ; IHS/SD/POTT 04/13 CONDITIONAL DISPLAY OF TXD AND MESSSAGES   - BAR 1.8*23
  1.  ; IHS/SD/POTT HEAT148695 01/13/2014 BLOCK INVALID ENTRY (100;200;300 AS COMMANDS)   - BAR 1.8*24
  1.  ; ********************************************************************
  1.  ;
  1. EN ;EP - command processor
  1.  K DIR,^TEMP($J,"BARPOST"),BARTR
  1.  S (BARADJ,BARPMT)=0
  1.  S BARDFLT=""
  1.  W !!
  1.  ; -------------------------------
  1. EN1 ;
  1.  ;K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
  1.  K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN,REVERSAL,REVSCHED  ;BAR*1.8*4
  1.  S BARDSP=1
  1.  D HIT1^BARPST2(BARPASS)
  1.  ; -------------------------------
  1. EN2 ;
  1.  W !!
  1.  K BARCOM,BARAMT
  1.  D:$D(BARHLP)<10 SETHLP^BARPSTU
  1.  ; -------------------------------
  1. ASKLIN ;
  1.  I BARCNT=1 S (BARLIN,BARDFLT)=1 G ASKCOM1
  1.  D ASKLIN^BARFPST3
  1.  I $G(BARLIN)["^" G FINISH
  1.  I $G(BARLIN)=0 G FINISH
  1.  I BARLIN>0,BARLIN<(BARCNT+1) G ASKCOM1
  1.  ;
  1. LNHLP ;
  1. ASKCOM ;EP - select command
  1.  K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
  1.  S BARDSP=1
  1.  D HIT1^BARPST2(BARPASS)
  1.  W !
  1.  ; -------------------------------
  1. ASKCOM1 ;
  1.  I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q  ;IS SESSION STILL OPEN
  1.  K REVERSAL,REVSCHED  ;BAR*1.8*4 SCR56,SCR58
  1.  W !,"Select Command (Line # "_BARLIN_") : "
  1.  ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT 20490
  1.  ;-------
  1.  ;K DIR
  1.  ;S DIR(0)="FAO"
  1.  ;S DIR("A")="Select Command (Line # "_BARLIN_") "
  1.  ;S DIR("T")=DTIME
  1.  ;D ^DIR
  1.  ;K DIR
  1.  ;S BARCOM=$$UPC^BARUTL(X)
  1. XYZ R BARCOM:DTIME
  1.  S BARCOM=$$UPC^BARUTL(BARCOM)
  1.  S BARCOM=$E(BARCOM,1,10) ;BAR*1.8*23
  1. 0 ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
  1.  I ("P1A2"[BARCOM) D  I $D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!($G(Y)=0) G ASKCOM
  1.  .S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  .S BARTPB=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
  1.  .K DIROUT,DIRUT,DTOUT,DUOUT
  1.  .K DIR,DIE,DIC,X,Y,DA,DR
  1.  .Q:$G(BARTPB)=""
  1.  .S BARSTAT=$P($G(^ABMDBILL($P(BARTPB,","),$P(BARTPB,",",2),0)),U,4)
  1.  .Q:BARSTAT'="X"
  1.  .W !!,"STOP!  3P BILL ",$P($P($G(^BARBL(DUZ(2),BARBLDA,0)),U),"-")," has been cancelled."
  1.  .S DIR(0)="Y"
  1.  .S DIR("A")="Are you sure you want to post to this invoice"
  1.  .S DIR("B")="N"
  1.  .D ^DIR K DIR
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
  1.  S Q=0
  1.  F J=1:1 D  Q:Q  ;HEAT#76683 - BAR*1.8*.24
  1.  . ;S BARCOM(J)=$E($P(BARCOM,",",J)) ;OLD CODE ;1/13/2014 HEAT148695   - BAR 1.8*24
  1.  .S BARCOM(J)=$P(BARCOM,",",J) ;NEW CODE   - BAR 1.8*24
  1.  .Q:$L(BARCOM(J))
  1.  .K BARCOM(J)
  1.  .S J=J-1
  1.  .S Q=1 Q
  1.  I 'J!($L($G(BARCOM(1)))=0) G ASKCOM
  1.  I BARCOM(1)=1 S BARCOM(1)="P" W *7,*7,*7
  1.  I BARCOM(1)=2 S BARCOM(1)="A" W *7,*7,*7
  1.  I BARCOM(1)=3 S BARCOM(1)="Q" W *7,*7,*7
  1.  I '$D(BARHLP(BARCOM(1))) G COMHLP
  1.  I J=1,BARCOM(J)="M" D  G ASKCOM
  1.  .N DA,DIC,BARBLDA,BARACC
  1.  .S DA=BARITDA
  1.  .S DA(1)=BARCOL
  1.  .S DIC="^BARCOL(DUZ(2),DA(1),1,"
  1.  .S BARACC=$$GET1^DIQ(DIC,.DA,7,"I")
  1.  .S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  .D EN^BARPST6(BARPAT,BARBLDA,BARACC)
  1.  .Q
  1.  I J=1,BARCOM(J)="T" D  G ASKCOM
  1.  .S Y=$$DSPLY^BARPST4(BARLIN)
  1.  .D EOP^BARUTL(1)
  1.  I J=1,BARCOM(J)="H" D HISTORY^BARBAD3 G ASKCOM
  1.  ; -------------------------------
  1. GOQ ;
  1.  ;I J=1,BARCOM(J)="Q" G:BARCNT>1 EN1 G FINISH    ;BAR*1.8*4 DD 4.1.7.2
  1.  I J=1,BARCOM(J)="Q" D  G:BARCNT>1 EN1 G FINISH  ;BAR*1.8*4 DD 4.1.7.2
  1.  .D CKNEG(BARLIN)                                ;BAR*1.8*4 DD 4.1.7.2
  1. GOP ;
  1.  I J=1,BARCOM(J)="P" S BARTYP="P" G ASKAMT
  1.  I J=1,BARCOM(J)="1" S BARTYP="P" G ASKAMT
  1.  I J=1,BARCOM(J)="R" D ROLL G ASKCOM
  1.  ; enable posting rollback
  1. GOA ;
  1.  I J=1,BARCOM(J)="A" S BARTYP="A" G ASKAMT
  1.  I J=1,BARCOM(J)="2" S BARTYP="A" G ASKAMT
  1. GOD ;
  1.  I J=1,BARCOM(J)="D" D  G ASKCOM
  1.  . S DFN=BARPAT
  1.  . D VIEWR^XBLM("START^AGFACE")
  1. GOB ;
  1.  I J=1,BARCOM(J)="B" D  G ASKCOM
  1.  . S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  . D DIQ^XBLM(90050.01,BARBLDA)
  1.  I J=1,BARCOM(J)="E" G ^BARPST4
  1. B I J=2,BARCOM(1)="P" D  G:'BARAMT ASKCOM D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,,0) G ASKCOM
  1.  .S BARAMT=0,BARTYP="P"
  1.  .S X=$$AMT^BARPSTU(BARCOM(2))
  1.  .I X="^"!(X="?") W *7," (You must enter a valid number)" Q
  1.  .S BARAMT=BARCOM(2)
  1.  .S BARCAT=$O(^BAR(90052.01,"B","PAYMENT TYPE",""))
  1.  .W "  ($"_$J(BARAMT,0,2)_" payment applied to Line # "_BARLIN_")" H 2
  1.  W *7
  1.  W "   Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
  1.  G ASKCOM
  1.  ; *********************************************************************
  1. ASKAMT ;
  1.  S (BARCAT,BARATYP)=""
  1.  S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
  1.  ;W !,BARASK R X:DTIME
  1.  K DIR
  1.  S DIR(0)="FAO"
  1.  S DIR("A")=BARASK
  1.  S DIR("T")=DTIME
  1.  D ^DIR
  1.  K DIR
  1.  S X=$$AMT^BARPSTU(X,-9999999.99,9999999.99)  ;bar*1.8*20
  1.  I X="^" G ASKCOM
  1.  I X="?" W *7,"  Must be a valid number!" G ASKAMT
  1.  S BARAMT=X
  1.  ;IHS/SD/TPF BAR*1.8*3 UFMS REQUEST FOR REVERSAL RECEIPT
  1.  ;ONLY FOR IHS AFFILIATED SITES AND TRIBALS WITH FLAG 'RESTRICT POSTING NEG BAL'
  1.  I $$IHS^BARUFUT(DUZ(2)),(+BARAMT<0),(BARTYP="P") D  G:'REVERSAL!$D(DTOUT)!$D(DUOUT)!(Y="") ASKCOM  ;bar*1.8*20
  1.  . K REVERSAL,REVSCHED,REVERS
  1.  . S REVERS=$$REVERSAL()
  1.  . S REVERSAL=$P(REVERS,U)
  1.  . S REVSCHED=$P(REVERS,U,2)
  1.  . S Y=$G(Y)                                ;BAR*1.8*4 DD 4.1.7.3
  1.  ;END IHS/SD/TPF BAR*1.8*3, BAR*1.8*4
  1.  ;ONLY ALLOW ZERO DOLLAR PAYMENTS ON NONPAYMENT BATCHES; BAR*1.8*4 DD4.1.5.6
  1.  ;
  1.  I $$IHS^BARUFUT(DUZ(2)),(+BARAMT'=0),(BARTYP="P"),$P(BARCOL(0),U,28)["NONP" D  G ASKCOM  ;MRS:BAR*1.8*7 IM?? 
  1.  . W !!,"You can not post a payment of anything other than $0 if the TDN is NONPAYMENT"
  1.  . D EOP^BARUTL(1)
  1.  ;
  1.  I BARTYP="P" D  G S1
  1.  . S BARCAT=$O(^BAR(90052.01,"B","PAYMENT TYPE",""))
  1.  ;
  1.  ;** adjustment category/type dialog
  1.  S DIC=90052.01
  1.  S DIC(0)="AEMNQZ"
  1.  S DIC("A")="Adjustment Category: "
  1.  S DIC("S")="I "",3,4,13,14,15,16,20,21,22,""[("",""_Y_"","")"
  1.  K DD,DO
  1.  D ^DIC
  1.  K DIC
  1.  I +Y<0 W *7 K BARAMT W !! G ASKAMT
  1.  S BARCAT=+Y
  1.  S:BARCAT=16 BARAMT=-BARAMT ;grouper
  1.  S BARX=0,BARJ=0
  1.  K BARATYP
  1.  F  S BARX=$O(^BARTBL("D",BARCAT,BARX)) Q:'BARX  D  Q:BARJ>1
  1.  .S BARJ=BARJ+1
  1.  .Q:BARJ>1
  1.  .S BARATYP=BARX
  1.  I BARJ=1,$G(BARATYP) G S1
  1.  S DIC=90052.02
  1.  S DIC(0)="AEMNQZ"
  1.  S DIC("A")="Adjustment Type: "
  1.  S DIC("S")="I $P(^(0),U,2)=BARCAT"
  1.  K DD,DO
  1.  D ^DIC
  1.  K DIC
  1.  I +Y<0 K BARAMT W *7,!! G ASKAMT
  1.  S BARATYP=+Y
  1.  ;--------------------------------
  1. S1 ;
  1.  D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,0) ;BAR*1.8*4 DD 4.1.7.2
  1.  ;D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;BAR*1.8*4 DD 4.1.7.2
  1.  G ASKCOM
  1.  ; *********************************************************************
  1. COMHLP ;
  1.  D COMHLP^BARPSTU
  1.  G ASKCOM1
  1.  ; *********************************************************************
  1. FINISH ;
  1.  I '$G(BARPMT)&('$G(BARADJ))&('$D(BARROLL))&'$D(BARTR) D CANCEL Q
  1.  ; enable posting rollback
  1. FIN S BARQ=$$POST()                            ;BAR*1.8*4 DD 4.1.7.2
  1.  I BARQ="M" G EN1
  1.  I BARQ="C" D CANCEL Q
  1.  ;I BARQ="P" D POSTTX^BARPSTU,EN^BARROLL Q  ;BAR*1.8*4 DD 4.1.7.2
  1.  I BARQ="P" D POSTTX^BARPSTU
  1.  ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
  1.  I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) D CANCEL Q  ;IS SESSION STILL OPEN
  1.  I $G(BARSTOP)=1 G FIN                      ;BAR*1.8*4 DD 4.1.7.2
  1.  D EN^BARROLL
  1.  K ^BARTMP($J)                              ;BAR*1.8*4 DD 4.1.7.2
  1.  Q
  1.  ;--------------------------------
  1. POST() ;
  1. P1 ;
  1.  D HIT1^BARPST2(BARPASS)
  1.  D EOP^BARUTL(2)
  1. PDIR ;
  1.  K DIR
  1.  S DIR(0)="SAO^P:POST TO A/R;M:MORE;C:CANCEL"
  1.  S DIR("A")="Select Action (P/M/C): "
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DUOUT)!(Y="") W *7 G PDIR
  1.  Q Y
  1.  ; *********************************************************************
  1. ROLL ;EP - tag a bill for rollback to 3P
  1.  ; enable posting rollback
  1.  N BARBLDA
  1.  S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  S BARROLL(BARBLDA)=""
  1.  K DIC,DIE
  1.  S DIE="^BARBL(DUZ(2),"
  1.  S DA=BARBLDA
  1.  S DR="214///@"
  1.  D ^DIE
  1.  K DIC,DIE,X,Y,DR
  1.  K DIR
  1.  S DIR("A")="TAGGED for Rolling. Enter RETURN to continue."
  1.  D EOP^BARUTL(0)
  1. ROLLE Q
  1.  ; *********************************************************************
  1. CANCEL ;
  1.  ;B "S+"
  1.  K ^BARTMP($J)
  1.  K BARPMT,BARADJ,BARTR,BARROLL
  1.  Q
  1.  ;IHS/SD/TPF BAR*1.8*3 UFMS LATE REQUEST FOR RECEIPT REVERSAL
  1. REVERSAL() ;EP - GET THE ORIGINAL TRANSACTION
  1. ASKREV ;EP - ASK AGAIN
  1.  ;Begin new code                  ;MRS:BAR*1.8*10 D158-3
  1.  ;PREVENT ALL PAYMENT REVERSALS
  1.  W !!,"PAYMENT REVERSALS ARE NO LONGER ALLOWED,"
  1.  W !,"PLEASE USE THE 'PAYMENT CREDIT' TRANSACTION TYPE"
  1.  D EOP^BARUTL(1)
  1.  Q 0  ;End ;MRS:BAR*1.8*10 D158-3
  1.  D REVHDR
  1.  N ARBILLIN,TRANSDAT,TRANDATE,EXTRDT,TRANTYP,ACCT,RETURN,ARRAY,AMOUNT,BALANCE
  1.  N COLDA,ITEMDA,REVSCHED
  1.  N CREDIT,DEBIT
  1.  N BARCK S BARCK=0                       ;BAR*1.8*4 DD 4.1.7.3
  1.  S ARBILLIN=$O(^BARTMP($J,"B",BARLIN,""))
  1.  ;I $G(ARBILLIN)="" W !!,"There are no transactions to reverse!" H 2 Q  ;BAR*1.8*4 DD 4.1.7.3
  1.  I $G(ARBILLIN)="" D CKREV Q 0           ;BAR*1.8*4 DD 4.1.7.3
  1.  I $G(BARPMT)>0 S BARCK=1                ;BAR*1.8*4 DD 4.1.7.3
  1.  S BARBAL=0
  1.  S TRANSDAT=""
  1.  S CNT=0
  1.  K BARNOTZ                 ;FOR NEW CHECK;BAR*1.8*6 DD 4.2.6
  1.  F  S TRANSDAT=$O(^BARTR(DUZ(2),"AC",ARBILLIN,TRANSDAT)) Q:'TRANSDAT  D
  1.  .S DEBIT=$$GET1^DIQ(90050.03,TRANSDAT_",",3,"E")
  1.  .S CREDIT=$$GET1^DIQ(90050.03,TRANSDAT_",",2,"E")
  1.  .S:CREDIT>0 BARCK=1
  1.  .Q:+$G(BARAMT)'=-CREDIT
  1.  .S TRANTYP=$$GET1^DIQ(90050.03,TRANSDAT_",",101,"E")
  1.  .S COLDA=$$GET1^DIQ(90050.03,TRANSDAT_",",14,"I")
  1.  .S ITEMDA=$$GET1^DIQ(90050.03,TRANSDAT_",",15,"I")
  1.  .S REVSCHED=$$GET1^DIQ(90051.1101,ITEMDA_","_COLDA_",",20,"I")
  1.  .Q:TRANTYP'="PAYMENT"
  1.  .I '$$EXCHK(ARBILLIN,TRANSDAT) Q            ;NEW CHECK; BAR*1.8*6 DD 4.2.6
  1.  .S CNT=CNT+1
  1.  .S ARRAY(CNT)=TRANSDAT_U_REVSCHED
  1.  .W !,CNT,"."
  1.  .S EXTRDT=$P(TRANSDAT,".")
  1.  .S Y=EXTRDT X ^DD("DD") S EXTRDT=Y
  1.  .S ACCT=$$GET1^DIQ(90050.03,TRANSDAT_",",6,"E")
  1.  .S COLBAT=$$GET1^DIQ(90050.03,TRANSDAT_",",14,"E")
  1.  .S COLITEM=$$GET1^DIQ(90050.03,TRANSDAT_",",15,"E")
  1.  .S (BARX,X)=$S($G(CREDIT):-CREDIT,1:$G(DEBIT))
  1.  .S X2=2
  1.  .S X3=11
  1.  .D COMMA^%DTC
  1.  .I TRANTYP["PENDING" S X="**"_X_"**"
  1.  .S AMOUNT=X
  1.  .N X
  1.  .I TRANTYP'["PENDING"&(TRANTYP'["GENERAL") D
  1.  .. S BARBAL=BARBAL+BARX
  1.  . S X=BARBAL,X2=2,X3=11 D COMMA^%DTC
  1.  . S BALANCE=X
  1.  .W EXTRDT
  1.  .W ?25,TRANTYP
  1.  .W ?45,AMOUNT
  1.  .W ?60,BALANCE
  1.  .W !
  1.  .W ?10,ACCT
  1.  .W ?25,$E(COLBAT,1,20)
  1.  .W ?60,COLITEM
  1.  I 'BARCK D CKREV Q 0
  1.  I $G(BARNOTZ),CNT=0 D  Q 0                ;NEW CHECK; BAR*1.8*6 DD 4.2.6
  1.  .W !!,"TRANSACTION HAS ALREADY BEEN LINKED TO ANOTHER REVERSAL"
  1.  .D EOP^BARUTL(1)
  1.  I CNT=0 W !!,"NO TRANSACTIONS MATCH THE REVERSAL AMOUNT ENTERED!" H 2 Q 0
  1.  W !!,BARDSH
  1.  K DIR
  1.  S DIR(0)="NO^1:"_CNT_":0"""
  1.  S DIR("A")="Choose One"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!$D(DUOUT)!(Y="") 0
  1.  W !,"You have chosen "_TRANTYP_" dated "_EXTRDT_"."
  1.  K DIR
  1.  S DIR(0)="YO"
  1.  S DIR("B")="Y"
  1.  S DIR("A")="Is that correct"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!$D(DUOUT) 0
  1.  G ASKREV:'Y
  1.  Q ARRAY(Y)
  1. REVHDR ;EP - REVERSAL HEADER
  1.  W @IOF
  1.  W !!,"Which Original Payment does this apply to?"
  1.  W !
  1.  W "TRANS DATE",?25,"TRANS TYPE",?50,"AMOUNT",?65,"BALANCE"
  1.  W !,?10,"A/R ACCT",?25,"BATCH",?55,"BATCH ITEM"
  1.  W !,BARDSH
  1.  Q
  1. CKNEG(LIN) ;EP; CHECK FOR NEGATIVE BALANCE  ;BAR*1.8*4 DD 4.1.7.2
  1.  Q:'$$IHS^BARUFUT(DUZ(2))              ;IGNORE NON-IHS
  1.  N BARDA,BARB
  1. REDO S BARDA=$O(^BARTMP($J,"B",LIN,""))
  1.  S BARB=$P(^BARTMP($J,BARDA,LIN),U,5)
  1.  I BARB<0 D
  1.  .W !!,"THE TRANSACTION(S) YOU ARE ATTEMPTING TO POST WILL PUT THIS BILL INTO A NEGATIVE"
  1.  .W !,"BALANCE BY -$"_-BARB,"  PLEASE CANCEL OR USE 'M' FOR MORE TO EDIT YOUR TRANSACTION(S)"
  1.  .W !,"TO PREVENT A NEGATIVE BALANCE"
  1.  .D EOP^BARUTL(1)
  1.  Q
  1. CKREV ; CHECK FOR PAYMENT PRECEDING REVERSAL  ;BAR*1.8*4 DD 4.1.7.3
  1.  W !!,"<<YOU ARE ATTEMPTING TO POST A REVERSAL WHEN THERE IS NO PAYMENT ON THE BILL"  ;BAR*1.8*4 DD 4.1.7.3
  1.  W !,"PLEASE CHECK YOUR TRANSACTION AND TRY AGAIN"
  1.  D EOP^BARUTL(1)
  1.  Q
  1. EXCHK(BARDA,TX) ; BAR*1.8*6 DD 4.2.6
  1.  ;     ENTERS WITH TRANSACTION DATE/TIME OF ORIGINAL PAYMENT
  1.  I BARCOL'=COLDA!(BARITM'=ITEMDA) D  Q 0  ;MUST BE IN SAME COLLECTION BATCH/ITEM
  1.  .W !!,TX," CANNOT BE LINKED BECAUSE IT IS NOT IN SAME COLLECTION BATCH/ITEM"
  1.  .D EOP^BARUTL(1)
  1.  I TX<$P($G(^BAR(90052.06,DUZ(2),DUZ(2),15)),U,5) D  Q 0  ;MRS:BAR*1.8*10 D158-2
  1.  .W !!,TX," CANNOT BE LINKED BECAUSE IT IS BEFORE THE UFMS BOOKING DATE,"
  1.  .W !,"USE THE PAYMENT CREDIT TRANSACTION TYPE"
  1.  .D EOP^BARUTL(1)
  1.  N X,Y,Z                                  ;NOW CHECK IF PREVIOUS REVERSAL
  1.  S Z=1
  1.  S X=0
  1.  F  S X=$O(^BARTR(DUZ(2),"AC",BARDA,X)) Q:'X  D
  1.  .S Y=$P($G(^BARTR(DUZ(2),X,1)),U,10)     ;TRANSACTION REVERSAL DATE STAMP
  1.  .I Y=TX D
  1.  ..S Z=0
  1.  I Z D                                    ;CHECK IF PAIRED IN THIS SESSION
  1.  .S X=0
  1.  .F  S X=$O(BARTR(BARLIN,X)) Q:'X  D
  1.  ..I $P(BARTR(BARLIN,X),U,5)=TX S Z=0
  1.  I 'Z S BARNOTZ=1                         ;SET FLAG FOR DISPLAY MESSAGE
  1.  Q Z
  1.  ;*********************************************