ACRFPAY1.m

ACRFPAY1 ;IHS/OIRM/DSD/THL,AEF - CERTIFY AND EXPORT PAYMENT BATCH;  [ 06/30/2005  7:49 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**5,16,17**;NOV 05, 2001

 ;;

COMBINE ;EP;COMBINE BATCHES

 ;SELECT DESTINATION BATCH

 D BATCHL^ACRFPAY3

 K ACR

 D CSELECT

 I '$D(ACRDEST)!'$D(ACR("SOURCE")) K ACRQUIT Q

 D CDISPLAY

 D CCOMPLET^ACRFPAY8

 Q

CDISPLAY ;DISPLAY DESTINATION AND SOURCE BATCHES TO BE COMBINED

 W @IOF

 W !!,"You have selected BATCH ",@ACRON,$P(ACRDEST,U,3),@ACROF," as the DESTINATION batch."

 W !!,"You have selected the following SOURCE Batch(es)"

 W !,"to be moved to the DESTINATION Batch."

 W !

 S ACRJ=0

 F  S ACRJ=$O(ACR("SOURCE",ACRJ)) Q:'ACRJ  D

 .W !?5,ACRJ,?10,$P(ACR("SOURCE",ACRJ),U,3)

 Q

CSELECT K ACRDEST,ACRACH,ACRX

 S DIR("A")="Enter the number for the DESTINATION Batch"

 S DIR("?",1)="The DESTINATION Batch is the batch"

 S DIR("?")="to which the other batches will be moved."

 K ACRX

 W !

 D CS

 Q:'$D(ACRX)

 S ACRDEST=ACRX

 F ACRJ=1:1 D  Q:'$D(ACRX)

 .S DIR("A")="Enter the number for "_$S(ACRJ=1:"First",1:"Next")_" SOURCE Batch"

 .S DIR("?",1)="The SOURCE Batch is the batch"

 .S DIR("?")="will be moved to another batch"

 .K ACRX

 .D CS

 .Q:'$D(ACRX)

 .S ACR("SOURCE",ACRJ)=ACRX

 Q

CS I 'ACRMAX D  Q

 .W !!,"There are no open batches to select."

 .D PAUSE^ACRFWARN

 W !

 S DIR(0)="NO^1:"_ACRMAX

 D DIR^ACRFDIC

 Q:'$D(^TMP("ACRPAY",$J,+Y))

 S ACRX=^TMP("ACRPAY",$J,+X)

 S:'$D(ACRACH) ACRACH=$E($P(ACRX,U,3))

 I $D(ACRDEST),$E($P(ACRX,U,3))'=ACRACH D  G CS

 .;W !!,"The SOURCE Batch must be the same type (",$S("AD"[ACRACH:"ACH-Grouped","BE"[ACRACH:"ACH-NON-Grouped","CF"[ACRACH:"CHECK",ACRACH="G":"NO-Check",1:""),")"  ;ACR*2.1*17.13 IM17827

 .W !!,"The SOURCE Batch must be the same type (",$S("BE"[ACRACH:"ACH-NON-Grouped","CF"[ACRACH:"CHECK",ACRACH="G":"NO-Check",1:""),")"  ;ACR*2.1*17.13 IM17827

 .K ACRX

 .W !,"as the DESTINATION Batch."

 N ACRFYDA,ACRBATDA

 S ACRFYDA=$P(ACRX,U,2)

 S ACRBATDA=$P(ACRX,U)

 S ACRTOT=$G(ACRTOT)+$$COUNT^ACRFIV12(ACRFYDA,ACRBATDA)

 I ACRTOT>60 D

 .K ACRX

 .W !!,*7,*7,"You cannot combine batches containing more than 60 paymentts"

 .D PAUSE^ACRFWARN

 Q

NONARMS ;EP;TO GATHER DATA TO CREATE NON-ARMS PAYMENT

 K ACRVDA,ACRCAN,ACRCANDA,ACRLOC,ACRLOCDA,ACRAPP,ACRAPPDA,ACRTCODE,ACROBJ,ACROBJDA,ACRDFYDA,ACRODDA,ACRLBDT,ACRFYFUN,ACRIVPAY,ACRREFDA,ACRDUZ,ACRDOCDA

 W !!?22,"Required Data for new Payment"

 D DOC

 Q:$D(ACRQUIT)!$D(ACROUT)

 D REF:'$G(ACRREFDA)

 Q:$D(ACRQUIT)!$D(ACROUT)

 D VENDOR^ACRFPAY8:ACRBTYP="V"

 D TRAVELER^ACRFPAY8:ACRBTYP="T"&'$G(ACRDUZ)

 Q:$D(ACRQUIT)!$D(ACROUT)

 I ACRBTYP="T" D DATES^ACRFIV12

 Q:$D(ACRQUIT)!($D(ACROUT))

326 ;EP;TO ADD MULTIPLE CONTRACT PAYMENTS

 D CAN:'$G(ACRCANDA)!(ACRREF=326)!(ACRREF=371)

 Q:$D(ACRQUIT)!$D(ACROUT)

 D OCC:'$G(ACROBJDA)!(ACRREF=326)!(ACRREF=371)

 Q:$D(ACRQUIT)!$D(ACROUT)

 I '$P($G(ACRLBDT),U,11) S:$G(ACRLOC)]"" DIC("B")=ACRLOC D LCOD^ACRFPAY8

 Q:$D(ACRQUIT)!$D(ACROUT)

 D CCT:'$P($G(ACRLBDT),U,15)

 Q:$D(ACRQUIT)!$D(ACROUT)

 I $L($G(ACRFYFUN))'=2!(ACRREF=326)!(ACRREF=371) D FYFUN^ACRFPAY9

 Q:$D(ACRQUIT)!$D(ACROUT)

 D APP ;:'$P($G(ACRLBDT),U,4)

 Q:$D(ACRQUIT)!$D(ACROUT)

 I '$G(ACRVDA)&'$G(ACRDUZ) D

 .D VENDOR^ACRFPAY8:ACRBTYP="V"

 .D TRAVELER^ACRFPAY8:ACRBTYP="T"

 . I ACRBTYP="T" D DATES^ACRFIV12

 Q:$D(ACRQUIT)!$D(ACROUT)

 D AMOUNT

 Q:$D(ACRQUIT)!$D(ACROUT)

 D PTYPE^ACRFPAY9

 Q:$D(ACRQUIT)!$D(ACROUT)

 D INVOICE:ACRBTYP="V"

 Q:$D(ACRQUIT)!$D(ACROUT)

 I ACRBTYP="V" D

 .;ACRACHX TELLS BATCH TYPE SELECTION PROCESS TO RETAIN CURRENT BATCH

 .;TYPE

 .S ACRACHX=ACRACH

 .D ^ACRFIV4

 .K ACRACHX

 Q:$D(ACRQUIT)!$D(ACROUT)

 D FINAL

 Q:$D(ACRQUIT)!$D(ACROUT)

 S:ACRTCODE=19114 ACRTCODE=$S(ACRFINAL=1:19114,1:18114)

 S ACRPAYDA=$P(^AFSLAFP(ACRFYDA,1,ACRBATDA,2),U,2)

 Q

APP ;SELECT APPROPRIATION

 S DIC="^AUTTPRO("

 S DIC(0)="AEMQZ"

 S DIC("A")="APPROPRIATION.......: "

 I $P($G(ACRLBDT),U,4),$P($G(^AUTTPRO(+$P(ACRLBDT,U,4),0)),U)]"" S DIC("B")=$P(^(0),U) I DIC("B")?7N S DIC("B")=$E(DIC("B"),1,2)_$E(ACRFYFUN,4)_$E(DIC("B"),4,7)

 D DIC^ACRFDIC

 I X["^" S ACROUT="" Q

 I $D(DTOUT)!($D(DUOUT)) S ACROUT="" Q

 I +Y<1 W !!,"APPROPRIATION REQUIRED",! G APP

 S $P(ACRLBDT,U,4)=+Y

 Q

CAN ;SELECT CAN

 S DIC="^AUTTCAN("

 S DIC(0)="AEMQZ"

 S DIC("A")="CAN.................: "

 D DIC^ACRFDIC

 I $L($G(ACRCAN))=7 S DIC("B")=ACRCAN

 I X["^" S ACROUT="" Q

 I $D(DTOUT)!($D(DUOUT)) S ACROUT="" Q

 I +Y<1 W !!,"CAN NUMBER REQUIRED",! G CAN

 S ACRCANDA=+Y

 S ACRCAN=Y(0,0)

 S:$P(Y(0),U,3) $P(ACRLBDT,U,4)=$P(Y(0),U,3)

 S:$P(Y(0),U,6) $P(ACRLBDT,U,11)=$P(Y(0),U,6)

 S:$P(Y(0),U,15) $P(ACRLBDT,U,15)=$P(Y(0),U,15)

 Q

OCC ;SELECT OBJECT CLASS CODE

 S DIC="^AUTTOBJC("

 S DIC(0)="AEMQZ"

 S DIC("A")="OBJECT CLASS CODE...: "

 I $L($G(ACROBJ))=4 S DIC("B")=ACROBJ

 D DIC^ACRFDIC

 I X["^" S ACROUT="" Q

 I $D(DTOUT)!($D(DUOUT)) S ACROUT="" Q

 I +Y<1 W !!,"OBJECT CLASS CODE REQUIRED",! G OCC

 S ACROBJDA=+Y

 S ACROBJ=$P(Y(0),U)

 Q

CCT ;SELECT COST CENTER

 S DIC="^AUTTCCT("

 S DIC(0)="AEMQZ"

 S DIC("A")="COST CENTER.........: "

 D DIC^ACRFDIC

 I X["^" S ACROUT="" Q

 I $D(DTOUT)!($D(DUOUT)) S ACROUT="" Q

 I +Y<1 W !!,"COST CENTER CODE REQUIRED",! G CCT

 S $P(ACRLBDT,U,15)=+Y

 Q

REF ;SELECT DOCUMENT REFERENCE CODE

 S DIC="^AUTTDOCR("

 S DIC(0)="AEMQZ"

 S DIC("A")="REFERENCE CODE......: "

 D DIC^ACRFDIC

 I X["^" S ACROUT="" Q

 I $D(DTOUT)!($D(DUOUT)) S ACROUT="" Q

 I +Y<1 W !!,"REFERENCE CODE REQUIRED",! G REF

 S ACRREFDA=+Y

 S (ACRREF,ACRREFX)=$P(Y(0),U)

 Q

DOC ;ENTER DOCUMENT NUMBER

 S DIR(0)="FO^10:10"

 S DIR("A")="DOCUMENT NUMBER....."

 S DIR("B")=$G(ACRTDOC)                          ;ACR*2.1*5.13

 D DIR^ACRFDIC

 I X["^" S ACROUT="" Q

 I X'?10AN S ACRQUIT="" Q

DOCX ;EP

 S (ACRDOC,ACRDOC2,ACRDOCX,ACRTDOC)=X            ;ACR*2.1*5.13

 S ACRDFYDA=$O(^AFSLODOC("DOCNO",ACRDOC,0))

 S ACRODDA=$O(^AFSLODOC("DOCNO",ACRDOC,+ACRDFYDA,0))

 I ACRDFYDA,ACRODDA,$O(^AFSLODOC("DOCNO",ACRDOC,ACRDFYDA,ACRODDA)) D SOD Q:'$G(ACRODDA)

 I $D(^ACRDOC("B",ACRDOC))!$D(^ACRDOC("C",ACRDOC)) D

 .S ACRX=$O(^ACRDOC("B",ACRDOC,0))

 .S:'ACRX ACRX=$O(^ACRDOC("C",ACRDOC,0))

 .I ACRX,ACRBTYP="T",$P($G(^ACRDOC(ACRX,"TO")),U,9) S ACRDUZ=$P(^("TO"),U,9)

 .I ACRX,$P($G(^ACROBL(+ACRX,"APV")),U,8)'="A" D

 ..I $P($G(^ACROBL(+ACRX,"APV")),U)'="A",$P($G(^ACRDOC(+ACRX,0)),U,14)["CANCEL" D

 ...W !!,*7,*7,"This document has been cancelled."

 ...S DIR(0)="YO"

 ...S DIR("A")="Continue Payment Action anyway"

 ...S DIR("B")="NO"

 ...W !

 ...D DIR^ACRFDIC

 ...I Y=1 K ACRQUIT Q

 ...W !,"No payment action will be processed."

 ...D PAUSE^ACRFWARN

 ..I $P($G(^ACROBL(+ACRX,"APV")),U)="A" D

 ...W !!,*7,*7,"Final approval of this document has not been completed."

 ...D PAUSE^ACRFWARN

 I 'ACRDFYDA!'ACRODDA D  W ! G DOC:$D(ACRQUIT)

 .W !!,"Document not found in the OPEN DOCUMENT file."

 .S DIR(0)="YO"

 .S DIR("A")="Create Payment anyway"

 .S DIR("B")="NO"

 .W !

 .D DIR^ACRFDIC

 .I +Y'=1 S ACRQUIT="" Q

 .K ACRQUIT

 I ACRDFYDA,ACRODDA D

 .K ACRCAN,ACRCANDA,ACROBJ,ACROBJDA,ACRREF,ACRREFDA,ACRVDA,ACRALW,ACRALWDA,ACRAPP,ACRAPPDA,ACRLOC,ACRLOCDA,ACRACPT,ACRFYFUN

 .N ACR0,ACR2,X,Y,Z

 .S X=$G(^AFSLODOC(ACRDFYDA,1,ACRODDA,0))

 .S Y=$G(^AFSLODOC(ACRDFYDA,1,ACRODDA,2))

 .S ACRFYFUN=$E(DT,2)_$P($G(^AFSLODOC(ACRDFYDA,0)),U)

 .S $P(ACRLBDT,U)=ACRFYFUN

 .S ACRCAN=$P(X,U,3)

 .S ACRCANDA=$S(ACRCAN]"":$O(^AUTTCAN("B",ACRCAN,0)),1:"")

 .S $P(ACRLBDT,U,11)=$P($G(^AUTTCAN(+ACRCANDA,0)),U,6)

 .S $P(ACRLBDT,U,15)=$P($G(^AUTTCAN(+ACRCANDA,0)),U,15)

 .S ACROBJ=$P(X,U,4)

 .S ACROBJDA=$O(^AUTTOBJC("B",(ACROBJ_" "),0))

 .I ACRBTYP="T",$D(ACRX) D                      ;ACR*2.1*16.06 IM15505

 ..S ACROBJDA=$P($G(^ACRDOC(+ACRX,"REQ")),U,6)  ;ACR*2.1*16.06 IM15505

 ..S:ACROBJDA]"" ACROBJ=$P(^AUTTOBJC(ACROBJDA,0),U)   ;ACR*2.1*16.06 IM15505

 .S (ACRREF,ACRREFX)=$P(Y,U)

 .S ACRREFDA=$S(ACRREF]"":$O(^AUTTDOCR("B",ACRREF,0)),1:"")

 .S ACRVDA=$P(Y,U,3)

 .S ACRALW=$P(Y,U,10)

 .S ACRALW=$TR(ACRALW," ","")

 .S ACRALWDA=$O(^AUTTALLW("B",+ACRALW,0))

 .S ACRAPP=$P(Y,U,11)

 .S ACRAPP=$TR(ACRAPP," ","")

 .S:ACRAPP]"" $P(ACRLBDT,U,4)=$O(^AUTTPRO("B",ACRAPP,0))

 .K ACRLOC,ACRLOCDA

 .S ACRLOC=$P(Y,U,12)

 .I ACRLOC]"" S ACRLOCDA=$O(^AUTTLCOD("B",ACRLOC,0))

 .I $G(ACRLOCDA),'$O(^AUTTLCOD("B",ACRLOC,ACRLOCDA)) S $P(ACRLBDT,U,11)=ACRLOCDA

 .S ACRACPT=$E(ACRCAN,2,3)

 .N ACRX,ACRY

 .S ACRX=0

 S:$G(ACRREFX)=326!($G(ACRREFX)=371) $P(^TMP("ACRINV",$J,1),U,2)=ACRDOC

 Q

AMOUNT ;EP - ENTER PAYMENT AMOUNT

 S DIR(0)="NOA^0:99999999.99:2"

 ;S DIR("A")="PAYMENT AMOUNT......: "             ;ACR*2.1*16.06 IM15505

 S:ACRBTYP="V" DIR("A")="INVOICE AMOUNT......: "  ;ACR*2.1*16.06 IM15505

 S:ACRBTYP="T" DIR("A")="AMOUNT CLAIMED......: "  ;ACR*2.1*16.06 IM15505

 I $G(ACRAMTX),$G(ACRREF)=618 S DIR("B")=ACRAMTX

 K ACRAMTX

 D DIR^ACRFDIC

 I X["^" S ACROUT="" Q

 I $D(DTOUT)!($D(DIRUT)) S ACROUT="" Q

 ;I '+Y W !!,"PAYMENT AMOUNT REQUIRED",! G AMOUNT ;ACR*2.1*16.06 IM15505

 I '+Y D  G AMOUNT                               ;ACR*2.1*16.06 IM15505

 .I ACRBTYP="V" D                                ;ACR*2.1*16.06 IM15505

 ..W !!,"REQUIRED: ENTER AMOUNT OF INVOICE, EXCLUSIVE OF DISCOUNTS" ;ACR*2.1*16.06 IM15505

 ..W " OR INTEREST PENALTIES",!                  ;ACR*2.1*16.06 IM15505

 .I ACRBTYP="T" D                                ;ACR*2.1*16.06 IM15505

 ..W !!,"REQUIRED: ENTER AMOUNT CLAIMED ON TRAVEL VOUCHER",!  ;ACR*2.1*16.06 IM15505

 S (ACRIVTF,ACRIVT)=Y

 S ACRIVPAY(ACRCANDA,ACROBJDA)=Y

 Q

INVOICE ;EP;          ENTER INVOICE INFORMATION

 S DIR(0)="DO^::AE"

 S DIR("A")="RECEIVING DATE......: "

 S DIR("B")="TODAY"

 D DIR^ACRFDIC

 I 'Y S Y=DT

 S ACRRRDAT=+Y

 D EDIT^ACRFIVDX

 Q

FINAL ;EP - FINAL OR PARTIAL PAYMENT

 S DIR(0)="SO^1:FINAL;2:PARTIAL"

 S DIR("A")="FINAL/PARTIAL......."

 D DIR^ACRFDIC

 I X["^" S ACROUT="" Q

 I Y<1 S ACRQUIT="" Q

 S ACRFINAL=Y

 Q

SOD ;SELECT OPEN DOCUMENT

 K ACRODDA

 D SODH

 N J,ACRXX,ACRYY,ACRZ,ACRZ2

 S (J,ACRXX)=0

 F  S ACRXX=$O(^AFSLODOC("DOCNO",ACRDOC,ACRXX)) Q:'ACRXX  D

 .S ACRYY=0

 .F  S ACRYY=$O(^AFSLODOC("DOCNO",ACRDOC,ACRXX,ACRYY)) Q:'ACRYY  D

 ..S J=J+1

 ..S J(J)=ACRXX_U_ACRYY

 ..S ACRZ=$G(^AFSLODOC(ACRXX,1,ACRYY,0))

 ..S ACRZ2=$G(^AFSLODOC(ACRXX,1,ACRYY,2))

 ..S ACRAMTX=$P(ACRZ,U,10)/100

 ..W !?10,J,?15,$P(ACRZ,U),?27,$P(ACRZ,U,3),?36,$P(ACRZ,U,4),?42,$P(ACRZ2,U),?48,$P(^AFSLODOC(ACRXX,0),U),?52,$J($FN(ACRAMTX,"P,",2),14)

 ..I IOSL-4<$Y D PAUSE^ACRFWARN K ACRQUIT,ACROUT D SODH

 S DIR(0)="NO^1:"_J

 S DIR("A")="Which OPEN DOCUMENT"

 W !

 D DIR^ACRFDIC

 I 'Y S ACRQUIT="" Q

 I '$D(J(Y)) S ACRQUIT="" Q

 S ACRDFYDA=+J(Y)

 S ACRODDA=$P(J(Y),U,2)

 Q

SODH ;HEADER

 W @IOF

 W !?15,"Select OPEN DOCUMENT"

 W !?36,"OBJ",?42,"REF"

 W !?10,"NO.",?15,"DOCUMENT",?27,"CAN",?36,"CODE",?42,"CODE",?48,"FY",?52,"OBLG AMT"

 W !?10,"---",?15,"----------",?27,"-------",?36,"----",?42,"----",?48,"--",?52,"-------------"

 Q

ACRFPAY1  ;IHS/OIRM/DSD/THL,AEF - CERTIFY AND EXPORT PAYMENT BATCH;  [ 06/30/2005  7:49 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;**5,16,17**;NOV 05, 2001

 +2       ;;

COMBINE   ;EP;COMBINE BATCHES

 +1       ;SELECT DESTINATION BATCH

 +2        DO BATCHL^ACRFPAY3

 +3        KILL ACR

 +4        DO CSELECT

 +5        IF '$DATA(ACRDEST)!'$DATA(ACR("SOURCE"))

               KILL ACRQUIT

               QUIT 

 +6        DO CDISPLAY

 +7        DO CCOMPLET^ACRFPAY8

 +8        QUIT 

CDISPLAY  ;DISPLAY DESTINATION AND SOURCE BATCHES TO BE COMBINED

 +1        WRITE @IOF

 +2        WRITE !!,"You have selected BATCH ",@ACRON,$PIECE(ACRDEST,U,3),@ACROF," as the DESTINATION batch."

 +3        WRITE !!,"You have selected the following SOURCE Batch(es)"

 +4        WRITE !,"to be moved to the DESTINATION Batch."

 +5        WRITE !

 +6        SET ACRJ=0

 +7        FOR 

               SET ACRJ=$ORDER(ACR("SOURCE",ACRJ))

               IF 'ACRJ

                   QUIT 

               Begin DoDot:1

 +8                WRITE !?5,ACRJ,?10,$PIECE(ACR("SOURCE",ACRJ),U,3)

               End DoDot:1

 +9        QUIT 

CSELECT    KILL ACRDEST,ACRACH,ACRX

 +1        SET DIR("A")="Enter the number for the DESTINATION Batch"

 +2        SET DIR("?",1)="The DESTINATION Batch is the batch"

 +3        SET DIR("?")="to which the other batches will be moved."

 +4        KILL ACRX

 +5        WRITE !

 +6        DO CS

 +7        IF '$DATA(ACRX)

               QUIT 

 +8        SET ACRDEST=ACRX

 +9        FOR ACRJ=1:1

               Begin DoDot:1

 +10               SET DIR("A")="Enter the number for "_$SELECT(ACRJ=1:"First",1:"Next")_" SOURCE Batch"

 +11               SET DIR("?",1)="The SOURCE Batch is the batch"

 +12               SET DIR("?")="will be moved to another batch"

 +13               KILL ACRX

 +14               DO CS

 +15               IF '$DATA(ACRX)

                       QUIT 

 +16               SET ACR("SOURCE",ACRJ)=ACRX

               End DoDot:1

               IF '$DATA(ACRX)

                   QUIT 

 +17       QUIT 

CS         IF 'ACRMAX

               Begin DoDot:1

 +1                WRITE !!,"There are no open batches to select."

 +2                DO PAUSE^ACRFWARN

               End DoDot:1

               QUIT 

 +3        WRITE !

 +4        SET DIR(0)="NO^1:"_ACRMAX

 +5        DO DIR^ACRFDIC

 +6        IF '$DATA(^TMP("ACRPAY",$JOB,+Y))

               QUIT 

 +7        SET ACRX=^TMP("ACRPAY",$JOB,+X)

 +8        IF '$DATA(ACRACH)

               SET ACRACH=$EXTRACT($PIECE(ACRX,U,3))

 +9        IF $DATA(ACRDEST)

               IF $EXTRACT($PIECE(ACRX,U,3))'=ACRACH

                   Begin DoDot:1

 +10      ;W !!,"The SOURCE Batch must be the same type (",$S("AD"[ACRACH:"ACH-Grouped","BE"[ACRACH:"ACH-NON-Grouped","CF"[ACRACH:"CHECK",ACRACH="G":"NO-Check",1:""),")"  ;ACR*2.1*17.13 IM17827

 +11      ;ACR*2.1*17.13 IM17827

                       WRITE !!,"The SOURCE Batch must be the same type (",$SELECT("BE"[ACRACH:"ACH-NON-Grouped","CF"[ACRACH:"CHECK",ACRACH="G":"NO-Check",1:""),")"

 +12                   KILL ACRX

 +13                   WRITE !,"as the DESTINATION Batch."

                   End DoDot:1

                   GOTO CS

 +14       NEW ACRFYDA,ACRBATDA

 +15       SET ACRFYDA=$PIECE(ACRX,U,2)

 +16       SET ACRBATDA=$PIECE(ACRX,U)

 +17       SET ACRTOT=$GET(ACRTOT)+$$COUNT^ACRFIV12(ACRFYDA,ACRBATDA)

 +18       IF ACRTOT>60

               Begin DoDot:1

 +19               KILL ACRX

 +20               WRITE !!,*7,*7,"You cannot combine batches containing more than 60 paymentts"

 +21               DO PAUSE^ACRFWARN

               End DoDot:1

 +22       QUIT 

NONARMS   ;EP;TO GATHER DATA TO CREATE NON-ARMS PAYMENT

 +1        KILL ACRVDA,ACRCAN,ACRCANDA,ACRLOC,ACRLOCDA,ACRAPP,ACRAPPDA,ACRTCODE,ACROBJ,ACROBJDA,ACRDFYDA,ACRODDA,ACRLBDT,ACRFYFUN,ACRIVPAY,ACRREFDA,ACRDUZ,ACRDOCDA

 +2        WRITE !!?22,"Required Data for new Payment"

 +3        DO DOC

 +4        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +5        IF '$GET(ACRREFDA)

               DO REF

 +6        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +7        IF ACRBTYP="V"

               DO VENDOR^ACRFPAY8

 +8        IF ACRBTYP="T"&'$GET(ACRDUZ)

               DO TRAVELER^ACRFPAY8

 +9        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +10       IF ACRBTYP="T"

               DO DATES^ACRFIV12

 +11       IF $DATA(ACRQUIT)!($DATA(ACROUT))

               QUIT 

326       ;EP;TO ADD MULTIPLE CONTRACT PAYMENTS

 +1        IF '$GET(ACRCANDA)!(ACRREF=326)!(ACRREF=371)

               DO CAN

 +2        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +3        IF '$GET(ACROBJDA)!(ACRREF=326)!(ACRREF=371)

               DO OCC

 +4        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +5        IF '$PIECE($GET(ACRLBDT),U,11)

               IF $GET(ACRLOC)]""

                   SET DIC("B")=ACRLOC

               DO LCOD^ACRFPAY8

 +6        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +7        IF '$PIECE($GET(ACRLBDT),U,15)

               DO CCT

 +8        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +9        IF $LENGTH($GET(ACRFYFUN))'=2!(ACRREF=326)!(ACRREF=371)

               DO FYFUN^ACRFPAY9

 +10       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +11      ;:'$P($G(ACRLBDT),U,4)

           DO APP

 +12       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +13       IF '$GET(ACRVDA)&'$GET(ACRDUZ)

               Begin DoDot:1

 +14               IF ACRBTYP="V"

                       DO VENDOR^ACRFPAY8

 +15               IF ACRBTYP="T"

                       DO TRAVELER^ACRFPAY8

 +16               IF ACRBTYP="T"

                       DO DATES^ACRFIV12

               End DoDot:1

 +17       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +18       DO AMOUNT

 +19       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +20       DO PTYPE^ACRFPAY9

 +21       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +22       IF ACRBTYP="V"

               DO INVOICE

 +23       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +24       IF ACRBTYP="V"

               Begin DoDot:1

 +25      ;ACRACHX TELLS BATCH TYPE SELECTION PROCESS TO RETAIN CURRENT BATCH

 +26      ;TYPE

 +27               SET ACRACHX=ACRACH

 +28               DO ^ACRFIV4

 +29               KILL ACRACHX

               End DoDot:1

 +30       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +31       DO FINAL

 +32       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +33       IF ACRTCODE=19114

               SET ACRTCODE=$SELECT(ACRFINAL=1:19114,1:18114)

 +34       SET ACRPAYDA=$PIECE(^AFSLAFP(ACRFYDA,1,ACRBATDA,2),U,2)

 +35       QUIT 

APP       ;SELECT APPROPRIATION

 +1        SET DIC="^AUTTPRO("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="APPROPRIATION.......: "

 +4        IF $PIECE($GET(ACRLBDT),U,4)

               IF $PIECE($GET(^AUTTPRO(+$PIECE(ACRLBDT,U,4),0)),U)]""

                   SET DIC("B")=$PIECE(^(0),U)

                   IF DIC("B")?7N

                       SET DIC("B")=$EXTRACT(DIC("B"),1,2)_$EXTRACT(ACRFYFUN,4)_$EXTRACT(DIC("B"),4,7)

 +5        DO DIC^ACRFDIC

 +6        IF X["^"

               SET ACROUT=""

               QUIT 

 +7        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET ACROUT=""

               QUIT 

 +8        IF +Y<1

               WRITE !!,"APPROPRIATION REQUIRED",!

               GOTO APP

 +9        SET $PIECE(ACRLBDT,U,4)=+Y

 +10       QUIT 

CAN       ;SELECT CAN

 +1        SET DIC="^AUTTCAN("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="CAN.................: "

 +4        DO DIC^ACRFDIC

 +5        IF $LENGTH($GET(ACRCAN))=7

               SET DIC("B")=ACRCAN

 +6        IF X["^"

               SET ACROUT=""

               QUIT 

 +7        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET ACROUT=""

               QUIT 

 +8        IF +Y<1

               WRITE !!,"CAN NUMBER REQUIRED",!

               GOTO CAN

 +9        SET ACRCANDA=+Y

 +10       SET ACRCAN=Y(0,0)

 +11       IF $PIECE(Y(0),U,3)

               SET $PIECE(ACRLBDT,U,4)=$PIECE(Y(0),U,3)

 +12       IF $PIECE(Y(0),U,6)

               SET $PIECE(ACRLBDT,U,11)=$PIECE(Y(0),U,6)

 +13       IF $PIECE(Y(0),U,15)

               SET $PIECE(ACRLBDT,U,15)=$PIECE(Y(0),U,15)

 +14       QUIT 

OCC       ;SELECT OBJECT CLASS CODE

 +1        SET DIC="^AUTTOBJC("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="OBJECT CLASS CODE...: "

 +4        IF $LENGTH($GET(ACROBJ))=4

               SET DIC("B")=ACROBJ

 +5        DO DIC^ACRFDIC

 +6        IF X["^"

               SET ACROUT=""

               QUIT 

 +7        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET ACROUT=""

               QUIT 

 +8        IF +Y<1

               WRITE !!,"OBJECT CLASS CODE REQUIRED",!

               GOTO OCC

 +9        SET ACROBJDA=+Y

 +10       SET ACROBJ=$PIECE(Y(0),U)

 +11       QUIT 

CCT       ;SELECT COST CENTER

 +1        SET DIC="^AUTTCCT("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="COST CENTER.........: "

 +4        DO DIC^ACRFDIC

 +5        IF X["^"

               SET ACROUT=""

               QUIT 

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET ACROUT=""

               QUIT 

 +7        IF +Y<1

               WRITE !!,"COST CENTER CODE REQUIRED",!

               GOTO CCT

 +8        SET $PIECE(ACRLBDT,U,15)=+Y

 +9        QUIT 

REF       ;SELECT DOCUMENT REFERENCE CODE

 +1        SET DIC="^AUTTDOCR("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="REFERENCE CODE......: "

 +4        DO DIC^ACRFDIC

 +5        IF X["^"

               SET ACROUT=""

               QUIT 

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET ACROUT=""

               QUIT 

 +7        IF +Y<1

               WRITE !!,"REFERENCE CODE REQUIRED",!

               GOTO REF

 +8        SET ACRREFDA=+Y

 +9        SET (ACRREF,ACRREFX)=$PIECE(Y(0),U)

 +10       QUIT 

DOC       ;ENTER DOCUMENT NUMBER

 +1        SET DIR(0)="FO^10:10"

 +2        SET DIR("A")="DOCUMENT NUMBER....."

 +3       ;ACR*2.1*5.13

           SET DIR("B")=$GET(ACRTDOC)

 +4        DO DIR^ACRFDIC

 +5        IF X["^"

               SET ACROUT=""

               QUIT 

 +6        IF X'?10AN

               SET ACRQUIT=""

               QUIT 

DOCX      ;EP

 +1       ;ACR*2.1*5.13

           SET (ACRDOC,ACRDOC2,ACRDOCX,ACRTDOC)=X

 +2        SET ACRDFYDA=$ORDER(^AFSLODOC("DOCNO",ACRDOC,0))

 +3        SET ACRODDA=$ORDER(^AFSLODOC("DOCNO",ACRDOC,+ACRDFYDA,0))

 +4        IF ACRDFYDA

               IF ACRODDA

                   IF $ORDER(^AFSLODOC("DOCNO",ACRDOC,ACRDFYDA,ACRODDA))

                       DO SOD

                       IF '$GET(ACRODDA)

                           QUIT 

 +5        IF $DATA(^ACRDOC("B",ACRDOC))!$DATA(^ACRDOC("C",ACRDOC))

               Begin DoDot:1

 +6                SET ACRX=$ORDER(^ACRDOC("B",ACRDOC,0))

 +7                IF 'ACRX

                       SET ACRX=$ORDER(^ACRDOC("C",ACRDOC,0))

 +8                IF ACRX

                       IF ACRBTYP="T"

                           IF $PIECE($GET(^ACRDOC(ACRX,"TO")),U,9)

                               SET ACRDUZ=$PIECE(^("TO"),U,9)

 +9                IF ACRX

                       IF $PIECE($GET(^ACROBL(+ACRX,"APV")),U,8)'="A"

                           Begin DoDot:2

 +10                           IF $PIECE($GET(^ACROBL(+ACRX,"APV")),U)'="A"

                                   IF $PIECE($GET(^ACRDOC(+ACRX,0)),U,14)["CANCEL"

                                       Begin DoDot:3

 +11                                       WRITE !!,*7,*7,"This document has been cancelled."

 +12                                       SET DIR(0)="YO"

 +13                                       SET DIR("A")="Continue Payment Action anyway"

 +14                                       SET DIR("B")="NO"

 +15                                       WRITE !

 +16                                       DO DIR^ACRFDIC

 +17                                       IF Y=1

                                               KILL ACRQUIT

                                               QUIT 

 +18                                       WRITE !,"No payment action will be processed."

 +19                                       DO PAUSE^ACRFWARN

                                       End DoDot:3

 +20                           IF $PIECE($GET(^ACROBL(+ACRX,"APV")),U)="A"

                                   Begin DoDot:3

 +21                                   WRITE !!,*7,*7,"Final approval of this document has not been completed."

 +22                                   DO PAUSE^ACRFWARN

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +23       IF 'ACRDFYDA!'ACRODDA