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