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

BARCLU.m

Go to the documentation of this file. 
  1. BARCLU ; IHS/SD/LSL - USER ENTRY INTO COLLECTION BATCHES ;; 07/09/2010
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,16,18,19,23,24**;OCT 26,2005;Build 69
  1.  ;;
  1.  ; IHS/ASDS/LSL - 06/15/01 - V1.5 Patch 1 - HQW-0201-100027
  1.  ;     fm 22 issue.  Modified to include E in DIC(0)
  1.  ;
  1.  ; IHS/SD/SDR - v1.8 p4
  1.  ;   Added prompt for TDN and amount for batch
  1.  ;
  1.  ; IHS/SD/AR  03/31/2010 1.8*18, low priorities, TDN dupl
  1.  ; 
  1.  ; IHS/SD/TMM 06/18/2010 1.8*19 (M819), Add Prepayment functionality.
  1.  ;      See work order 3PMS10001
  1.  ;      ------------------------
  1.  ;      BARCLU4 is new routine for Prepayment functionality in collection entry.
  1.  ;      819_1. Display prepayments not assigned to a batch (^BARCLU,^BARCLU4)
  1.  ;      819_2. Remove prompt: AUTO PRINT RECEIPT (^BARCLU01)
  1.  ;      819_3. Prepayment entry ^BARPPY01 (new routine),^BARCLU1,^BARPUTL
  1.  ;      819_4. Display prepayments matching payment type selected (^BARCLU,^BARCLU4)
  1.  ;      819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU4,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
  1.  ;      819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
  1.  ;
  1.  ; IHS/SD/POTT HEAT148839 01/14/2014 FIXED UNDEF - BAR*1.8*24
  1.  ; ********************************************************************* ;
  1.  ;
  1. ENTRY ;
  1.  ; lookup collection id I '$D(BARUSR) D INIT^BARUTL
  1.  ;---select collection batch
  1.  S X1=$$GET1^DIQ(200,DUZ,20.4,"I")
  1.  I X1']"" D  Q
  1.  . W *7,!!,"NO ELECTRONIC SIGNATURE CODE ON FILE"
  1.  . W !,"Use ^TBOX to give yourself one",!
  1.  . D EOP^BARUTL(0)
  1.  D SIG^XUSESIG
  1.  Q:X1=""  ;elec signature test
  1.  ; -------------------------------
  1.  ;
  1. G ;
  1.  I '$D(BARUSR) D INIT^BARUTL
  1.  K DIC
  1.  S DIC="^BAR(90051.02,DUZ(2),"
  1.  S DIC(0)="AEZQM"
  1.  S DIC("S")="I $D(^BAR(90051.02,DUZ(2),""AB"",DUZ,+Y))" ;screen for user
  1.  D ^DIC  ;Select A/R COLLECTION POINT/IHS NAME:
  1.  Q:Y'>0
  1.  S BARDA=+Y
  1.  K BARCLID
  1.  D BARCLID ;setup BARCLID collection id array
  1.  D DISPPAY^BARCLU4       ;Display unassigned Prepayments
  1.  G:BARCLID(6)="" NEW
  1.  I BARCLID(6.5)="POSTABLE" G NEW
  1.  I BARCLID(6.5)'="OPEN",BARCLID(6.3)'=BARUSR(.01) G NEW
  1.  I BARCLID(6.5)="OPEN",BARCLID(6.3)=BARUSR(.01) G ENTER
  1.  I BARCLID(6.5)="OPEN",BARCLID(6.3)'=BARUSR(.01) G INUSE
  1.  I BARCLID(6.5)="REVIEW",BARCLID(6.3)=BARUSR(.01) G INREVIEW
  1.  G ENTER
  1.  ; *********************************************************************
  1.  ;
  1. NEW ; EP
  1.  ; open a new batch
  1.  D NEW^BARCLU1
  1.  ; -------------------------------
  1.  ;
  1. ENTER ; EP
  1.  ; Enter/Add new collection item
  1.  K DIC,DR,DA,BARQUIT
  1.  S BARDIC="^BARCOL(DUZ(2),"
  1.  S (BARDA,BARCLDA)=BARCLID(6,"I")
  1.  D BARCL
  1.  S X=+$$GET1^DIQ(90051.01,BARCLDA,7)
  1.  S Y=+$O(^BARCOL(DUZ(2),BARCLDA,1,"A"),-1)
  1.  I X'=Y D  G ENTER
  1.  .W !,*7,"An out of sequence item ",Y," has been detected and removed."
  1.  .W !,"Please recheck your entries"
  1.  .K DIK
  1.  .S DA(1)=BARCLDA
  1.  .S DA=Y
  1.  .S DIK=$$DIC^XBDIQ1(90051.1101)
  1.  .D ^DIK
  1.  .K DIK,DIR
  1.  .S DIR(0)="EA"
  1.  .S DIR("A")="<cr> to continue"
  1.  .D ^DIR
  1.  .K DIR
  1.  ;D NEWITEM  ;IHS/SD/SDR bar*1.8*4
  1.  W $$EN^BARVDF("IOF")
  1.  W !!,"ENTERING ",BARCL(.01)
  1.  W ?35,"TYPE: ",BARCLID(2)  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  W ?55,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15)  ;IHS/SD/SDR bar*1.8*4  DD item 4.1.5.1
  1.  I $P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)'="",(+$G(BARCLID(22,"I"))) D
  1.  .W !,"TDN/IPAC: ",$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
  1.  .W ?35,"TDN/IPAC AMOUNT: ",$FN($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2),!!
  1. TDN ;I $P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)=""!($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)="")&(+$G(BARCLID(22,"I"))) D  Q:$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)=""&($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)="")&($G(BARFLG)'=1)
  1.  I $P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)=""!(+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)=0)&(+$G(BARCLID(22,"I"))) D  Q:($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)="")&(+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)=0)&($G(BARFLG)'=1)
  1.  .W !,"You will now be prompted for the Treasury Deposit/IPAC and an amount."
  1.  .W !,"The Treasury Deposit/IPAC will be used for all items in this batch."
  1.  .W !,"The total of all the items entered must equal the amount entered here or"
  1.  .W !,"the batch will not finalize.",!!
  1.  .K DIC,DIE,DR,DA,X,Y
  1.  .K BARFLG
  1.  .S DIE="^BARCOL(DUZ(2),"
  1.  .S DA=BARCLDA
  1.  .;IHS/SD/AR 03/31/2010 low priorities, TDN dupl
  1.  .;;;old code: I '$$IHSERA^BARUFUT(DUZ(2)) D  ;BAR*1.8*23
  1.  .I '$$IHS^BARUFUT(DUZ(2)) D  ;1/14/2014 HEAT148839 BAR*1.8*24
  1.  ..K DIE("NO^")   ;BAR*1.8*16
  1.  ..S DR="28Enter TDN/IPAC//"  ;BAR*1.8*16
  1.  .E  D
  1.  ..S DIE("NO^")=""
  1.  ..S DR="28R~Enter TDN/IPAC//"  ;BAR*1.8*16
  1.  .;S DR="28Enter TDN/IPAC//;29Enter TDN/IPAC Dollar Amount for this Batch//"
  1.  .D ^DIE
  1.  .K DIE("NO^")
  1.  .N LIST,DOCARE,DUPFDA
  1.  .D CHECKDUP($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28),.LIST)
  1.  .I $D(LIST) D
  1.  ..K DIR
  1.  ..S DIR(0)="Y"
  1.  ..S DIR("B")="No"
  1.  .E  D
  1.  ..W "  No duplicates found."
  1.  .K LIST,DOCARE
  1.  .;;; old code I '$$IHSERA^BARUFUT(DUZ(2)) D  ;BAR*1.8*23
  1.  .I '$$IHS^BARUFUT(DUZ(2)) D  ;1/14/2014 HEAT148839 BAR*1.8*24
  1.  ..K DIE("NO^")   ;BAR*1.8*16
  1.  ..S DR="30Enter TDN/IPAC/Deposit Date;29Enter TDN/IPAC Dollar Amount for this Batch//"  ;BAR*1.8*16
  1.  .E  D
  1.  ..S DIE("NO^")=""
  1.  ..S DR="30R~Enter TDN/IPAC/Deposit Date;29R~Enter TDN/IPAC Dollar Amount for this Batch//"  ;BAR*1.8*16
  1.  .;S DR="28Enter TDN/IPAC//;29Enter TDN/IPAC Dollar Amount for this Batch//"
  1.  .D ^DIE
  1.  .K DIE("NO^")
  1.  .Q:$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)=""!($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)="")
  1.  .;IHS/SD/AR 03/31/2010 end low priorities, TDN dupl
  1.  .W !!,"----------------------------------",!
  1.  .W "TDN/IPAC: ",$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
  1.  .W !,"  Amount: ",$FN($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2),!
  1.  .W "TDN/IPAC/Deposit Date: ",$$GET1^DIQ(90051.01,BARCLDA_",",30,"E")  ;BAR*1.8*16
  1.  .;check for NONPAYMENT and dollar amt '=0
  1.  .I $P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)["NONPAY",(+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)'=0) D  Q
  1.  ..W !!,"Cannot batch a dollar amount to a NONPAYMENT TDN/IPAC"
  1.  ..S DIE="^BARCOL(DUZ(2),"
  1.  ..S DA=BARCLDA
  1.  ..S DR="28////@;29////@"
  1.  ..D ^DIE
  1.  .K DIR,DIC,DIE,DR,DA,X,Y
  1.  .S DIR(0)="Y"
  1.  .S DIR("A")="Correct? "
  1.  .S DIR("B")="YES"
  1.  .D ^DIR K DIR
  1.  .I Y<1 D
  1.  ..S DIE="^BARCOL(DUZ(2),"
  1.  ..S DA=BARCLDA
  1.  ..S DR="28////@;29////@"
  1.  ..D ^DIE
  1.  ..S BARFLG=1
  1.  .W !
  1.  ;
  1.  ;I $P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)="",(+$G(BARCLID(22,"I")))  G TDN  ;go back up and prompt for TDN again  ;IHS/SD/SDR bar*1.8*6 IM29168
  1.  ;I ($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)="")!(($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)'="NONPAYMENT")&(+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)=0)),(+$G(BARCLID(22,"I")))  G TDN  ;go back up & prompt for TDN again ;IHS/SD/SDR bar*1.8*6 IM29168
  1.  ;PER TONI JOHNSON TRIBALS DO NOT HAVE TO POPULATE THESE FIELDS BAR*1.8*16  
  1.  I ($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)="")!(($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)'="NONPAYMENT")&(+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)=0)),(+$G(BARCLID(22,"I"))),($$IHS^BARUFUT(DUZ(2)))  G TDN
  1.  D NEWITEM^BARCLU4
  1.  W !
  1.  S DA(1)=BARCLDA
  1.  S DA=BARITDA
  1.  S DIE="^BARCOL(DUZ(2),"_DA(1)_",1,"
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  W "ITEM ",BARITDA
  1.  ;
  1.  ;----  51:EOB 52:CASH 53:CC 55:REFUND 81:CHECK
  1.  ;
  1.  I BARCLID(2,"I")="E" S DR="2////51"
  1.  E  D
  1.  . S DR="2//^S X=$G(BARITTYP)"                   ;2=
  1.  . W !,"Up-Arrow at Transaction Type to exit loop and KILL New Entry"
  1.  S DIDEL=90050
  1.  D ^DIE                   ;prompts for PAYMENT TYPE:
  1.  K DIDEL
  1.  I $D(Y) S BARQUIT=1 G NOMORE
  1.  D BARCLIT
  1.  S BARITTYP=BARCLIT(2)
  1.  ; -------------------------------
  1.  ;
  1. DR ;EP
  1.  ; setup DR as to type of collection item
  1.  S BARX=BARCLIT(2,"I")
  1.  I 'BARX D  G NOMORE
  1.  . W *7,!,"ERROR IN TRANSACTION TYPE"
  1.  . S BARQUIT=1
  1.  ; -------------------------------
  1.  ; 
  1.  ; Display Prepayments of same PAYMENT TYPE
  1.  D SELPPAY^BARCLU4  ;M819*ADD*TMM*20100710
  1.  ;
  1. EDITEM ;EP
  1.  ; edit collection item
  1.  D EDITEM^BARCLU0   ;edit the various types of items    ;prompts for Credit:
  1.  ;
  1.  I $G(BARQUIT) G NOMORE ;can be set by EOB with "^" at check number
  1.  D BARCLIT
  1.  ; -------------------------------
  1.  ;
  1. REVIEW ;EP
  1.  ; review item
  1.  I $E(BARCLIT(2))'="E",BARCLID(20,"I") G ASK    ;20=NON EOB DATA REVIEW/EDIT
  1.  I $E(BARCLIT(2))="E",BARCLID(21,"I") G ASK     ;21=EOB DATA REVIEW/EDIT
  1.  G FILE
  1.  ; *********************************************************************
  1.  ;
  1. ASK ;
  1.  D DISPLAY
  1.  ;** check required fields
  1.  S BARERROR=0
  1.  ;F I=2,7,8,101 D
  1.  F I=2,7,8,101,20 D  ;BAR*1.8*3 UFMS MAKE TREASURY NUMBER REQUIRED
  1.  .I I=20,('$G(BARCLID(22,"I"))) Q  ;IHS/SD/TPF BAR*1.8*4 IM26177
  1.  .I $L(BARCLIT(I))'>0 D
  1.  ..W !,$P(^DD(90051.1101,I,0),U),?20," IS MISSING"
  1.  ..S BARERROR=1
  1.  K DIR
  1.  S DIR(0)="S^E:Edit;D:Delete;F:FILE"
  1.  S DIR("B")="F"
  1.  S:BARERROR DIR("B")="E"
  1.  D ^DIR
  1.  I Y="E" D  G EDITEM
  1.  .W $$EN^BARVDF("IOF")
  1.  .W !!,"ENTERING ",BARCL(.01),!!
  1.  .W "ITEM ",BARITDA
  1.  I Y="D" D  G ENTER
  1.  .S DIK=$$DIC^XBDIQ1(90051.1101)
  1.  .S DA(1)=BARCLDA
  1.  .S DA=BARITDA
  1.  .D ^DIK
  1.  G:BARERROR ASK
  1.  ;--------------------------------
  1.  ;
  1. FILE ; EP
  1.  K DIE,DR,DA
  1.  S DIE=$$DIC^XBDIQ1(90051.01)
  1.  S DR="7///^S X=BARCL(7)"
  1.  S DA=+BARCL("ID")
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL
  1.  K BARDA
  1.  S BARITAC=BARCLIT(7)
  1.  S BARITLC=BARCLIT(8) ;set defaults
  1.  I +$G(BARPPSEL)>0 D PPUPDT^BARCLU4   ;update A/R Prepayment file with batch assignment ;M819*ADD*TMM*20100711
  1.  W !!         ;M819*ADD*TMM*20100711
  1.  D PAZ^BARRUTL    ;Press return to continue        ;M819*ADD*TMM*20100711
  1.  G ENTER
  1.  ; *********************************************************************
  1.  ;
  1. SELECT ;EP
  1.  ; select action
  1.  ;W !,$$GET1^DIQ(90051.01,BARCLDA,15)  ;bar*1.8*4
  1.  K DIR,DIE
  1.  S DIR(0)="S^A:ADD;M:MORE;E:EDIT;Q:QUIT"
  1.  S DIR("A")="A/M/E/Q"
  1.  S DIR("B")="ADD"
  1.  D ^DIR
  1.  I Y="A" G ENTER
  1.  I Y="M" D ^BARCLU2 G SELECT
  1.  I Y="E" D ^BARCLU3 G SELECT
  1.  I Y="Q" G EXIT
  1.  ; -------------------------------
  1.  ;
  1. NOMORE ;EP
  1.  ; nomore entries backout last entry
  1.  S (DIK,DIE)=$$DIC^XBDIQ1(90051.1101)
  1.  S DA=BARITDA
  1.  S DA(1)=BARCLDA
  1.  D ^DIK
  1.  K BARQUIT
  1.  K DIE,DR,DA
  1.  S BARCL(7)=BARCL(7)-1
  1.  ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  W !!,"GETTING READY TO RUN DETAIL REPORT."
  1.  W "  PLEASE VALIDATE "_$S($G(BARCLID(22,"I")):"TREASURY DEPOSIT/IPAC AND ",1:"")_"AMOUNT FOR ACCURACY"
  1.  S BARSEL="D",BARBATCH=BARCLDA,BARBEX=BARCL(".01") D D2^BARCLRG G:$D(BAREFLG) SELECT D PRINT^BARCLRG
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  G SELECT
  1.  ; *********************************************************************
  1.  ;
  1. INUSE ;EP
  1.  ; in use
  1.  W !!,"Sorry  ",BARCLID(.01),"  is OPENED by  : ",BARCLID(6.3),!!
  1.  S DA=0
  1.  S DA(1)=+BARCLID("ID")
  1.  S BARCLDA=DA(1)
  1.  D ENPM^XBDIQ1(90051.2201,"BARCLDA,0",.01,"BARSUP(")
  1.  I $D(BARSUP(DUZ)) D  G ENTER
  1.  . W !,"YOU ARE A SUPERVISOR SO YOU ARE ENTERING THE BATCH",!
  1.  . D EOP^BARUTL(1)
  1.  . K BARSUP
  1.  D EOP^BARUTL(1)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. INREVIEW ;EP
  1.  ; in REVIEW
  1.  W !!,"Sorry  ",BARCLID(.01),"  is in REVIEW by >you< : ",BARCLID(6.3),!!
  1.  D EOP^BARUTL(1)
  1.  G ENTER
  1.  ; *********************************************************************
  1.  ;
  1. EXIT ;EP
  1.  ; exit program
  1.  ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  ;don't do for batches created prior to 10/1/07
  1.  I $P($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,4),".")<3071001 Q
  1.  Q:'$G(BARCLID(22,"I"))
  1.  S BARITTOT=$$ITEMTOT(BARCLDA)  ;get total of items
  1.  I +BARITTOT'=(+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)) D
  1.  .W !!,"BATCHED AMOUNT OF "_$FN(BARITTOT,",",2)_" DOES NOT MATCH THE TDN/IPAC AMOUNT OF "
  1.  .W $FN($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2)_" FOR"
  1.  .W !,"TDN/IPAC "_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)_".",!
  1.  .;
  1.  .I BARITTOT<($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)) D
  1.  ..W !,"PLEASE REVIEW YOUR ENTRIES AND EITHER CORRECT THE AMOUNT OF THE TDN/IPAC OR ADD ADDITIONAL ITEMS TO BALANCE."
  1.  .I BARITTOT>($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)) D
  1.  ..W !,"PLEASE REVIEW YOUR ENTRIES AND EITHER CORRECT THE AMOUNT OF THE TDN/IPAC, REMOVE ITEMS, OR CORRECT THE BATCH ITEM AMOUNTS."
  1.  .W ! K DIR S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. BARCLID ;EP
  1.  ; build BARCLID array:uses current da in array or BARDA if no array
  1.  D BARCLID^BARCLU1
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. BARCL ;EP
  1.  ; build BARCL array:uses current da in array of DA if no array
  1.  D BARCL^BARCLU1
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. BARCLIT ;EP
  1.  ; build the BARCLIT array
  1.  D BARCLIT^BARCLU1
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. DISPLAY ;EP
  1.  ; display item elements
  1.  D DISPLAY^BARCLU1
  1.  Q
  1. ITEMTOT(BARCLDA) ;EP - get total of items
  1.  S BARITDA=0,BARITTOT=0
  1.  F  S BARITDA=$O(^BARCOL(DUZ(2),BARCLDA,1,BARITDA)) Q:+BARITDA=0  D
  1.  .Q:$P($G(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,0)),U,17)="C"!($P($G(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,0)),U,17)="R")  ;no cancelled or rolled up items
  1.  .S BARITTOT=+$G(BARITTOT)+$P($G(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,1)),U)
  1.  Q BARITTOT
  1. CHECKDUP(NEWTDN,LIST) ;EP - CHECK FOR DUPLICATE TDN IN A/R COLLECTION BATCH
  1.  W !!,"Checking for duplicate TDN/IPAC..."
  1.  Q:NEWTDN=""
  1.  N CHECNUM,CHECK,COLBAT,ITEM,AMOUNT,COLNAM,COLSTATUS
  1.  K LIST
  1.  S CNT=0
  1.  S COLBAT=""
  1.  F  S COLBAT=$O(^BARCOL(DUZ(2),"E",NEWTDN,COLBAT)) Q:COLBAT=""  D
  1.  .Q:BARCLDA=COLBAT
  1.  .S CNT=CNT+1
  1.  .S COLNAM=$$GET1^DIQ(90051.01,COLBAT_",",.01,"E")
  1.  .S AMOUNT=$$GET1^DIQ(90051.01,BARCLDA,15)
  1.  .S COLSTATUS=$$GET1^DIQ(90051.01,BARCLDA,3)
  1.  .S LIST(CNT)=COLNAM_U_COLSTATUS_U_NEWTDN_U_AMOUNT
  1.  Q:'$D(LIST)
  1.  D DUPHDR(CNT)
  1.  D SHOLIST(.LIST)
  1.  Q
  1.  ;
  1. DUPHDR(CNT) ;EP - TDNDUP HEADER
  1.  W !!,"**Duplicate TDN/IPAC detected in the following batches**"
  1.  Q
  1.  ;
  1. SHOLIST(LIST) ;EP - SHOW LIST OF DUPES
  1.  N CNT
  1.  S CNT=""
  1.  W !
  1.  F  S CNT=$O(LIST(CNT)) Q:'CNT  D
  1.  .W !,CNT,"."
  1.  .W ?3,$P(LIST(CNT),U)    ;NAME
  1.  .W ?32,"TTL: $ ",$J($FN($P(LIST(CNT),U,4),",",2),10) ;TOTAL
  1.  .W ?35,"  ST: ",$P(LIST(CNT),U,2)
  1.  .W ?63," T/I: ",$P(LIST(CNT),U,3)
  1.  W !!
  1.  Q
  1.  ;
  1. BFLAG(BARDA) ; (tag called by Fileman trigger for field: BATCH FLAG)
  1.  ; Update BATCH FLAG field (triggered when BATCH field is updated)
  1.  S BARTMP=+$$GET1^DIQ(90050.06,BARDA_",",.14,"I")
  1.  S BARTMPX=$S(BARTMP=0:"N",1:"A")
  1.  Q BARTMPX