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

BAREBCH.m

Go to the documentation of this file. 
  1. BAREBCH ; IHS/SD/SDR - EDIT COLLECTION BATCH/ITEMS JAN 15,1997 ; 11/21/2008
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,10,20,28**;OCT 26, 2005;Build 92
  1.  ; New routine in bar*1.8*4 for DD item 4.1.5.2
  1.  ;
  1.  ;BAR*1.8*28 IHS/DIT/CPC - Added Edit Check Number CR5994
  1.  ;BAR*1.8*28 IHS/DIT/CPC - Added Edit A/R Account CR5994
  1.  ;BAR*1.8*28 IHS/DIT/CPC - Added Item Change Audit CR5994
  1.  ; 
  1. EN ;EP;
  1.  K BARSTAR,BAREQUAL,BARDASH
  1.  K BARCBIEN,BARTRIEN,BARPFLG,BARVALUE
  1.  ;K BARNBCH,BARNAMT  ;IHS/SD/AML 5/3/2011 bar*1.8*20
  1.  K BARNBCH,BARNAMT,BARNDDT  ;IHS/SD/AML 5/3/2011 bar*1.8*20
  1.  ;
  1.  S $P(BARSTAR,"*",79)="*"
  1.  S $P(BAREQUAL,"=",79)="="
  1.  S $P(BARDASH,"-",79)="-"
  1.  ;
  1.  W !!,$$EN^BARVDF("RVN"),"Note: ",$$EN^BARVDF("RVF")
  1.  W "Collection Batch and Items that have not been posted may be modified."  ;IHS/DIT/CPC -20180425 Remove apostrophe BAR*1.8*28
  1.  W !?6,"If you entered a TDN/IPAC in error and the batch has been posted, you"
  1.  W !?6,"may not edit the TDN/IPAC and must notify your Finance Office to make"
  1.  W !?6,"adjustments in the financial system.",!!
  1.  ;
  1. SELECT ;
  1.  I $G(BARCBIEN)'="" D
  1.  .K BARCBIEN
  1.  .D CLEAR^VALM1
  1.  K DIC,DIE,X,Y,DA
  1.  S DIC="^BARCOL(DUZ(2),"
  1.  S DIC(0)="AEMQ"
  1.  D ^DIC
  1.  Q:$D(DTOUT)!$D(DUOUT)
  1.  Q:Y<0
  1.  S BARCBIEN=+Y
  1.  ;
  1.  ;check for payments posted to selected collection batch
  1.  S BARTRIEN=0
  1.  S BARPFLG=0
  1.  F  S BARTRIEN=$O(^BARTR(DUZ(2),"AD",BARCBIEN,BARTRIEN)) Q:+BARTRIEN=0!(BARPFLG=1)  D  Q:BARPFLG=1
  1.  .I $P($G(^BARTR(DUZ(2),BARTRIEN,1)),U)=40 S BARPFLG=1
  1.  ;
  1.  I BARPFLG=1 W !!,"ITEMS WITHIN THIS COLLECTION BATCH ALREADY HAVE PAYMENTS POSTED AND IS THEREFORE UNEDITABLE",!! H 2 K BARVALUE G SELECT
  1.  ;no payments posted so display batch/item info and confirm entry
  1.  S BARCNT=0,BAREND=0,BARITEM=0  ;;IHS/DIT/CPC - 20180418 V1.8 P28 CHECK FOR NO ITEMS IN BATCH
  1.  F  S BARITEM=$O(^BARCOL(DUZ(2),BARCBIEN,1,+BARITEM)) Q:+BARITEM=0  D
  1.  .S BARCNT=+$G(BARCNT)+1
  1.  I BARCNT=0 D
  1.  .S BAREND=1
  1.  .W !!,"There are no items associated with this batch.",!!
  1.  .W "Please use the Collections Entry option to add the",!
  1.  .W "missing batch item(s) before proceeding.",!!!
  1.  .S DIR(0)="E",DIR("A")="Enter RETURN to Continue"
  1.  .D ^DIR
  1.  .Q
  1.  I $G(BAREND) D CLEANUP Q  ;IHS/DIT/CPC - 20180418 V1.8 P28 END NO ITEM CHECK
  1.  W !!!!
  1.  W BARSTAR
  1.  W !?2,"Collection Batch: ",$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U),!
  1.  W BARSTAR
  1.  W !?4,"TDN/IPAC: ",$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,28)
  1.  W ?40,"TOTAL AMOUNT BATCHED: $",$FN($P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29),",",2)
  1.  W !?2,"Batched by: ",$P($G(^VA(200,$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,5),0)),U)
  1.  W ?48,"DATE CREATED: ",$$SDT^BARDUTL($P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,4))
  1.  W !,"DEPOSIT DATE: ",$$SDT^BARDUTL($P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,30)),!!  ;IHS/SD/AML 5/3/2011 - ADD TDN/IPAC DEPOSIT DATE bar*1.8*20
  1.  W "Item",?9,"Check#",?27,"A/R ACCOUNT",?46,"TDN/IPAC",?69,"Amount"
  1.  W !
  1.  W BARDASH
  1.  S BARITEM=0
  1.  F  S BARITEM=$O(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM)) Q:+BARITEM=0  D
  1.  .I $P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,17)'="",($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,17)'="E") Q
  1.  .W !,$J(BARITEM,3)  ;item number
  1.  .W ?5,$E($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,11),1,20)  ;item check#
  1.  .W ?27,$E($$GET1^DIQ(90051.1101,BARITEM_","_BARCBIEN_",",7,"E"),1,17)    ;item A/R Acct
  1.  .W ?46,$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,20)  ;item TDN
  1.  .W ?68,$J($FN($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U),",",2),12)  ;item amt
  1.  ;
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Correct"
  1.  S DIR("B")="Y"
  1.  D ^DIR K DIR
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
  1.  I Y<1 G SELECT
  1.  ;
  1.  ;edit the batch TDN and amount
  1.  ;it will prompt and display for user to confirm before filling new
  1.  ;data on the collection batch
  1. EDITBCH ;
  1.  W !,"Now Editing COLLECTION BATCH HEADER data:",!!
  1.  ;
  1.  K DIR,DIE,DIC,X,Y,DA
  1.  S DIR(0)="F^6:20^K:'$$GOODIPAC^BARUFEX3(X) X"
  1.  S DIR("A")="Collection Batch TDN/IPAC"
  1.  S DIR("B")=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,28)
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) W !!,"NOTHING CHANGED",!! H 2 G SELECT
  1.  S BARNBCH=Y
  1.  K DIR,DIE,DIC,S,Y,DA
  1.  S DIR(0)="NOA^0:999999999:2"
  1.  S DIR("A")="Total Amount Batched: "
  1.  S DIR("B")=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) W !!,"NOTHING CHANGED",!! H 2 G SELECT
  1.  S BARNAMT=Y
  1.  ;IHS/SD/AML 5/3/2011 - Added ability to edit Deposit Date bar*1.8*20
  1.  K DIR,DIE,DIC,D,Y,DA
  1.  S DIR(0)="DO"
  1.  S DIR("A")="TDN/IPAC Deposit Date: "
  1.  S DIR("B")=$$SDT^BARDUTL($P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,30))
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) W !!,"NOTHING CHANGED",!! H 2 G SELECT
  1.  S BARNDDT=Y
  1.  ;IHS/SD/AML 5/3/2011 - End ability to edit Deposit Date
  1.  ;
  1.  ;display header 
  1.  W !!,"You have edited the COLLECTION BATCH HEADER data to reflect:",!!
  1.  W BARSTAR
  1.  W !?2,"Collection Batch: ",$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U),!
  1.  W BARSTAR
  1.  W !?4,"TDN/IPAC: ",BARNBCH
  1.  W ?40,"TOTAL AMOUNT BATCHED: $",$FN(BARNAMT,",",2)
  1.  W !?2,"Batched by: ",$P($G(^VA(200,$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,5),0)),U)
  1.  W ?48,"DATE CREATED: ",$$SDT^BARDUTL($P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,4)),!
  1.  W "DEPOSIT DATE: ",$$SDT^BARDUTL(BARNDDT),!!  ;IHS/SD/AML 5/3/2011 - ADD TDN/IPAC DEPOSIT DATE bar*1.*20
  1.  W BARDASH
  1.  ;
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Is this correct"
  1.  D ^DIR K DIR
  1.  I Y<1 G EDITBCH
  1.  ;
  1.  ;TDN entered is the same one on file now; don't edit
  1.  S BAROBCH=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,28)
  1.  I BAROBCH=BARNBCH D
  1.  .W !!,"TDN not changed.  The TDN entered is the same one currently on file."
  1.  I BAROBCH'=BARNBCH D
  1.  .K DIC,DIE,DR,DA,X,Y
  1.  .S DA(1)=BARCBIEN
  1.  .S DIC="^BARCOL(DUZ(2),"_DA(1)_",1101,"
  1.  .S DIC(0)="LMQ"
  1.  .D NOW^%DTC
  1.  .S X=%
  1.  .S DIC("DR")=".02////28;.03////"_BAROBCH_";.04////"_BARNBCH_";.05////"_DUZ
  1.  .S DLAYGO=90050  ;Why not 90051.01? IHS/DIT/CPC - 20180309
  1.  .S DIC("P")=$P(^DD(90051.01,1101,0),U,2)
  1.  .D ^DIC
  1.  .K DIC,DIE,DR,DA,X,Y
  1.  .S DIE("NO^")="OUTOK"
  1.  .S DIE="^BARCOL(DUZ(2),"
  1.  .S DA=BARCBIEN
  1.  .S DR="28////"_BARNBCH
  1.  .D ^DIE
  1.  ;
  1.  I $P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)=BARNAMT D
  1.  .W !!,"Amount not changed.  The amount entered is the same one currently on file."
  1.  I $P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)'=BARNAMT D
  1.  .K DIC,DIE,DR,DA,X,Y
  1.  .S DA(1)=BARCBIEN
  1.  .S DIC="^BARCOL(DUZ(2),"_DA(1)_",1101,"
  1.  .S DIC(0)="LMQ"
  1.  .H 1
  1.  .D NOW^%DTC
  1.  .S X=%
  1.  .S DIC("DR")=".02////29;.03////"_$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)_";.04////"_BARNAMT_";.05////"_DUZ
  1.  .S DLAYGO=90050
  1.  .S DIC("P")=$P(^DD(90051.01,1101,0),U,2)
  1.  .D ^DIC
  1.  .K DIC,DIE,DR,DA,X,Y
  1.  .S DIE("NO^")="OUTOK"
  1.  .S DIE="^BARCOL(DUZ(2),"
  1.  .S DA=BARCBIEN
  1.  .S DR="29////"_BARNAMT
  1.  .D ^DIE
  1.  ;
  1.  ;IHS/SD/AML 5/3/2011 - BEGIN NEW CODE - ADD ABILITY TO EDIT DEPOSIT DATE bar*1.8*20
  1.  I $P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,30)=BARNDDT D
  1.  .W !!,"Date not changed.  The deposit date entered is the same one currently on file."
  1.  I $P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,30)'=BARNDDT D
  1.  .K DIC,DIE,DR,DA,D,X,Y
  1.  .S DA(1)=BARCBIEN
  1.  .S DIC="^BARCOL(DUZ(2),"_DA(1)_",1101,"
  1.  .S DIC(0)="LMQ"
  1.  .H 1
  1.  .D NOW^%DTC
  1.  .S X=%
  1.  .S DIC("DR")=".02////30;.03////"_$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,30)_";.04////"_BARNDDT_";.05////"_DUZ
  1.  .S DLAYGO=90050
  1.  .S DIC("P")=$P(^DD(90051.01,1101,0),U,2)
  1.  .D ^DIC
  1.  .K DIC,DIE,DR,DA,D,X,Y
  1.  .S DIE("NO^")="OUTOK"
  1.  .S DIE="^BARCOL(DUZ(2),"
  1.  .S DA=BARCBIEN
  1.  .S DR="30////"_BARNDDT
  1.  .D ^DIE
  1.  .;
  1.  .;IHS/SD/AML 5/3/2011 - END NEW CODE
  1.  ;now put this TDN on all items with the same TDN
  1.  S BARITEM=0
  1.  F  S BARITEM=$O(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM)) Q:+BARITEM=0  D
  1.  .I $P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,20)=BAROBCH D
  1.  ..K DIC,DIE,DR,DA,X,Y,D1
  1.  ..S D0=BARCBIEN,D1=BARITEM  ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
  1.  ..S DA(1)=BARCBIEN
  1.  ..S DA=BARITEM
  1.  ..S DIE("NO^")="OUTOK"
  1.  ..S DIE="^BARCOL(DUZ(2),"_DA(1)_",1,"
  1.  ..S DR="20////"_BARNBCH
  1.  ..D ^DIE
  1.  ;
  1.  ;now prompt to change items
  1. EDITITEM ;
  1.  W !!,"Now editing Collection Batch Items....",!
  1.  W BARDASH,!
  1.  ;W "Item",?9,"Check#",?27,"A/R ACCOUNT",?46,"TDN/IPAC",?69,"Amount"  ;bar*1.8*28 IHS/SD/AML HEAT305486 CR5994
  1.  I $P($G(^BARCOL(DUZ(2),BARCBIEN,1,+BARITEM,0)),U,2)=51 W "Item",?9,"Check#",?27,"A/R ACCOUNT",?46,"TDN/IPAC",?69,"Amount"  ;bar*1.8*28 IHS/SD/AML HEAT305486 CR5994 IHS/DIT/CPC 20180418
  1.  I $P($G(^BARCOL(DUZ(2),BARCBIEN,1,+BARITEM,0)),U,2)'=51 W "Item",?9,"Check#",?27,"A/R ACCOUNT",?46,"TDN/IPAC",?58,"TYPE",?69,"Amount"  ;bar*1.8*28 IHS/SD/AML HEAT305486 CR5994 IHS/DIT/CPC 20180418
  1.  W !
  1.  W BARDASH
  1.  S BARITEM=0,BARCNT=0
  1.  F  S BARITEM=$O(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM)) Q:+BARITEM=0  D
  1.  .S BARCNT=+$G(BARCNT)+1
  1.  .S BARPMTYP=$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,2)  ;bar*1.8*27 IHS/SD/AML HEAT305486 CR5994
  1.  .I $P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,17)'="",($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,17)'="E") Q
  1.  .W !,$J(BARITEM,3)  ;item number
  1.  .W ?5,$E($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,11),1,20)  ;item check#
  1.  .W ?27,$E($$GET1^DIQ(90051.1101,BARITEM_","_BARCBIEN_",",7,"E"),1,17)    ;item A/R Acct
  1.  .W ?46,$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,20)  ;item TDN
  1.  .I BARPMTYP'=51 W ?58,$P(^BARTBL(BARPMTYP,0),U,6)  ;bar*1.8*27 IHS/SD/AML HEAT305486 CR5994
  1.  .;W ?68,$J($FN($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U),",",2),12)  ;item amt  ;bar*1.8*27 IHS/SD/AML HEAT305486 CR5994
  1.  .W ?68,$J($FN($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U),",",2),12)  ;item amt  ;bar*1.8*27 IHS/SD/AML HEAT305486 CR5994
  1.  W !,BARDASH
  1.  K DIR,DIE,DIC,X,Y,DA
  1.  ;S DIR(0)="NO^1:"_BARCNT
  1.  S DIR(0)="NO"
  1.  S DIR("A")="Select Collection Batch Item to edit"
  1.  D ^DIR K DIR
  1.  ;
  1.  ;I +Y'=0,(($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,17)'="")&($P($G(^BARCOL(DUZ(2),BARCBIEN,1,+Y,0)),U,17)'="E")) W !!,"ITEM NOT EDITABLE; PLEASE CHOOSE FROM DISPLAYED ITEMS" H 1 W !! G EDITITEM  ;MRS:BAR*1.8*10 H1359
  1.  I +Y'=0,(($P($G(^BARCOL(DUZ(2),BARCBIEN,1,+Y,0)),U,17)'="")&($P($G(^BARCOL(DUZ(2),BARCBIEN,1,+Y,0)),U,17)'="E")) W !!,"ITEM NOT EDITABLE; PLEASE CHOOSE FROM DISPLAYED ITEMS" H 1 W !! G EDITITEM  ;MRS:BAR*1.8*10 H1359
  1.  ;display selection
  1.  I +Y'=0 D
  1.  .S BARITEM=Y
  1.  .S BARPMTYP=$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,2)  ;bar*1.8*28 IHS/SD/AML HEAT305486 CR 5994
  1.  .W !!,$J(BARITEM,3)  ;item number
  1.  .I '$G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)) D  ;IHS/DIT/CPC - 20180418 V1.8 P28
  1.  ..S BAREND=1
  1.  ..W !!,"There are no items associated with this batch.",!
  1.  ..W "Please use the Collections Entry option to add the ",!
  1.  ..W "missing batch item(s) before proceeding.",!!
  1.  ..S DIR(0)="E",DIR("A")="Enter RETURN to Continue"
  1.  ..D ^DIR
  1.  ..Q  ;IHS/DIT/CPC - 20180418 V1.8 P28
  1.  .Q:$G(BAREND)
  1.  .W ?5,$E($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,11),1,20)  ;item check#
  1.  .W ?27,$E($$GET1^DIQ(90051.1101,BARITEM_","_BARCBIEN_",",7,"E"),1,17)    ;item A/R Acct
  1.  .W ?46,$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,20)  ;item TDN
  1.  .I BARPMTYP'=51 W ?58,$P(^BARTBL(BARPMTYP,0),U,6)  ;bar*1.8*27 IHS/SD/AML HEAT305486 CR 5994
  1.  .W ?68,$J($FN($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U),",",2),12)  ;item amt
  1.  .W !
  1.  .;bar*1.8*28 IHS/DIT/CPC HEAT 305486 CR 5994 SET UP ITEM AUDIT TEST VALUES
  1.  .S BARITMCK=$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,11)  ;item check#
  1.  .S BARITMACCT=$E($$GET1^DIQ(90051.1101,BARITEM_","_BARCBIEN_",",7,"I"),1,20)    ;item A/R Acct
  1.  .S BARITMTDN=$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,20)  ;item TDN
  1.  .S BARITMAMT=$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U)  ;item amt
  1.  .;
  1.  .;IHS/SD/AML 10/24/2013 - Edit Check Number - IHS/DIT/CPC - 20180309 Start New Code BAR*1.8*28 CR5994
  1.  .K DIC,DIE,X,Y,DA,DR
  1.  .S DA(1)=BARCBIEN
  1.  .S DA=BARITEM
  1.  .S DIE("NO^")="OUTOK"
  1.  .S DIE="^BARCOL(DUZ(2),"_DA(1)_",1,"
  1.  .S DR="11Check Number"
  1.  .D ^DIE
  1.  .I $D(Y) K DIC,DIE,X,Y,DA,DR Q
  1.  .D ITMAUDIT(BARCBIEN,BARITEM,"11",BARITMCK,$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,0)),U,11),DUZ)
  1.  .;Edit A/R Account
  1.  .K DIC,DIE,X,Y,DA,DR
  1.  .S DA(1)=BARCBIEN
  1.  .S DA=BARITEM
  1.  .S DIE("NO^")="OUTOK"
  1.  .S DIE="^BARCOL(DUZ(2),"_DA(1)_",1,"
  1.  .S DR="7A/R Account"
  1.  .D ^DIE
  1.  .I $D(Y) K DIC,DIE,X,Y,DA,DR Q
  1.  .D ITMAUDIT(BARCBIEN,BARITEM,"7",BARITMACCT,$E($$GET1^DIQ(90051.1101,BARITEM_","_BARCBIEN_",",7,"I"),1,20),DUZ)
  1.  .K DIC,DIE,X,Y,DA,DR
  1.  .S DA(1)=BARCBIEN
  1.  .S DA=BARITEM
  1.  .S DIE("NO^")="OUTOK"
  1.  .S DIE="^BARCOL(DUZ(2),"_DA(1)_",1,"
  1.  .S DR="101Item Amount"
  1.  .I $P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,28)="" S DR="20Item TDN;"_DR
  1.  .D ^DIE
  1.  .I $D(Y) K DIC,DIE,X,Y,DA,DR Q
  1.  .D ITMAUDIT(BARCBIEN,BARITEM,"101",BARITMAMT,$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U),DUZ)
  1.  .;end new bar*1.8*28 IHS/SD/AML HEAT305486 CR5994
  1. EDITEOB .;
  1.  .I $P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,0)),U,4)>1 D  ;more than one EOB
  1.  ..;list EOBs
  1.  ..S BAREOB=0,BARCNT=0
  1.  ..W !!,"Edit EOB Locations..."
  1.  ..W !!?2,"#",?5,"VISIT LOCATION",?40,"AMOUNT",!,BARDASH
  1.  ..F  S BAREOB=$O(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,BAREOB)) Q:+BAREOB=0  D
  1.  ...S BARCNT=+$G(BARCNT)+1
  1.  ...W !,$J(BARCNT,3),?5,$P($G(^AUTTLOC($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,BAREOB,0)),U),0)),U,2)
  1.  ...W ?40,$J($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,BAREOB,0)),U,2),",",2)
  1.  ...S BARLIST(BARCNT)=BAREOB
  1.  ..W !,BARDASH
  1.  ..K DIR,DIE,DIC,X,Y,DA
  1.  ..S DIR(0)="NO^1:"_BARCNT
  1.  ..S DIR("A")="Select Item EOB to edit"
  1.  ..D ^DIR K DIR
  1.  ..S BARSEL=+Y
  1.  ..Q:BARSEL<1
  1.  ..K DIC,DIE,DA,X,Y,DR
  1.  ..S DA(2)=BARCBIEN
  1.  ..S DA(1)=BARITEM
  1.  ..S DIE("NO^")="OUTOK"
  1.  ..S DIE="^BARCOL(DUZ(2),"_DA(2)_",1,"_DA(1)_",6,"
  1.  ..S DA=$G(BARLIST(BARSEL))
  1.  ..S DR="2//"
  1.  ..D ^DIE
  1.  .I +$G(BARSEL)>0 G EDITEOB
  1.  .;
  1.  .I $P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,0)),U,4)=1 D  ;one EOB
  1.  ..K DIC,DIE,DA,X,Y,DR
  1.  ..S DA(2)=BARCBIEN
  1.  ..S DA(1)=BARITEM
  1.  ..S DIE("NO^")="OUTOK"
  1.  ..S DIE="^BARCOL(DUZ(2),"_DA(2)_",1,"_DA(1)_",6,"
  1.  ..S DA=$O(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,0))
  1.  ..S DR="2////"_$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U)
  1.  ..D ^DIE
  1.  .;
  1.  .S BAREOB=0,BAREOBT=0
  1.  .F  S BAREOB=$O(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,BAREOB)) Q:+BAREOB=0  D
  1.  ..S BAREOBT=+$G(BAREOBT)+($P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,6,BAREOB,0)),U,2))
  1.  .I BAREOBT'=+$P($G(^BARCOL(DUZ(2),BARCBIEN,1,BARITEM,1)),U) W !!,"Total of EOBs don't match item amount." G EDITEOB
  1.  ;
  1.  S BARITTOT=$$ITEMTOT^BARCLU(BARCBIEN)
  1.  ;
  1. PICKEDIT ;
  1.  I $G(BAREND) D CLEANUP Q
  1.  I BARITTOT'=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29) D
  1.  .W !!,"Batched amount of $",$FN(BARITTOT,",",2)," does not match TDN/IPAC amount of $",$FN($P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29),",",2)
  1.  .K DIR,DIE,DIC,X,Y,DA
  1.  .S DIR(0)="SO^B:BATCH;I:ITEM"
  1.  .S DIR("A")="Which would you like to correct"
  1.  .D ^DIR K DIR
  1.  .S BARSEL=Y
  1.  I $G(BARSEL)="",(BARITTOT'=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)) G PICKEDIT
  1.  I "IB"'[($G(BARSEL)),(BARITTOT'=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)) G PICKEDIT
  1.  G:(BARITTOT'=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)&($G(BARSEL)="I")) EDITITEM
  1.  G:(BARITTOT'=$P($G(^BARCOL(DUZ(2),BARCBIEN,0)),U,29)&($G(BARSEL)="B")) EDITBCH
  1.  ;
  1.  ;if it gets here the batch and items balance and they haven't selected an item to edit
  1.  ;I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) W !!,"NOTHING CHANGED",!!
  1.  ;
  1.  S DIR(0)="E",DIR("A")="Enter RETURN to Continue"  D EN
  1.  D ^DIR K DIR
  1.  D CLEANUP
  1.  Q
  1. ITMAUDIT(BATCHIEN,ITEMIEN,FIELD,OLD,NEW,USER) ;BAR*1.8*28 ITEM AUDIT - IHS/DIT/CPC CR 5994
  1.  I OLD'=NEW  D
  1.  .K DIC,DIE,DR,DA,D,X,Y
  1.  .S DA(1)=ITEMIEN
  1.  .S DA(2)=BATCHIEN
  1.  .S DIC="^BARCOL(DUZ(2),"_DA(2)_",1,"_DA(1)_",1101,"
  1.  .S DIC(0)="LMQ"
  1.  .H 1
  1.  .D NOW^%DTC
  1.  .S X=%
  1.  .S DIC("DR")=".02////"_FIELD_";.03////"_OLD_";.04////"_NEW_";.05////"_DUZ
  1.  .S DLAYGO=90051.1101
  1.  .D ^DIC
  1.  Q
  1. CLEANUP ;BAR*1.8*28 - IHS/DIT/CPC CR 5994
  1.  K BARCNT,BARDASH,BAREND,BAREOB,BAREOBT,BAREQUAL,BARITDA,BARITEM,BARITMACCT,BARITMAMT
  1.  K BARITMCK,BARITMTDN,BARITTOT,BAROBCH,BARPMTYP,BARSTAR,BARVDDF
  1.  K C,D,D0,D1,DI,DIC,DR,X,Y
  1.  Q
  1.  ;EOR - IHS/DIT/CPC 1.8*28