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
Begin DoDot:1
+24 WRITE !!,"Document not found in the OPEN DOCUMENT file."
+25 SET DIR(0)="YO"
+26 SET DIR("A")="Create Payment anyway"
+27 SET DIR("B")="NO"
+28 WRITE !
+29 DO DIR^ACRFDIC
+30 IF +Y'=1
SET ACRQUIT=""
QUIT
+31 KILL ACRQUIT
End DoDot:1
WRITE !
IF $DATA(ACRQUIT)
GOTO DOC
+32 IF ACRDFYDA
IF ACRODDA
Begin DoDot:1
+33 KILL ACRCAN,ACRCANDA,ACROBJ,ACROBJDA,ACRREF,ACRREFDA,ACRVDA,ACRALW,ACRALWDA,ACRAPP,ACRAPPDA,ACRLOC,ACRLOCDA,ACRACPT,ACRFYFUN
+34 NEW ACR0,ACR2,X,Y,Z
+35 SET X=$GET(^AFSLODOC(ACRDFYDA,1,ACRODDA,0))
+36 SET Y=$GET(^AFSLODOC(ACRDFYDA,1,ACRODDA,2))
+37 SET ACRFYFUN=$EXTRACT(DT,2)_$PIECE($GET(^AFSLODOC(ACRDFYDA,0)),U)
+38 SET $PIECE(ACRLBDT,U)=ACRFYFUN
+39 SET ACRCAN=$PIECE(X,U,3)
+40 SET ACRCANDA=$SELECT(ACRCAN]"":$ORDER(^AUTTCAN("B",ACRCAN,0)),1:"")
+41 SET $PIECE(ACRLBDT,U,11)=$PIECE($GET(^AUTTCAN(+ACRCANDA,0)),U,6)
+42 SET $PIECE(ACRLBDT,U,15)=$PIECE($GET(^AUTTCAN(+ACRCANDA,0)),U,15)
+43 SET ACROBJ=$PIECE(X,U,4)
+44 SET ACROBJDA=$ORDER(^AUTTOBJC("B",(ACROBJ_" "),0))
+45 ;ACR*2.1*16.06 IM15505
IF ACRBTYP="T"
IF $DATA(ACRX)
Begin DoDot:2
+46 ;ACR*2.1*16.06 IM15505
SET ACROBJDA=$PIECE($GET(^ACRDOC(+ACRX,"REQ")),U,6)
+47 ;ACR*2.1*16.06 IM15505
IF ACROBJDA]""
SET ACROBJ=$PIECE(^AUTTOBJC(ACROBJDA,0),U)
End DoDot:2
+48 SET (ACRREF,ACRREFX)=$PIECE(Y,U)
+49 SET ACRREFDA=$SELECT(ACRREF]"":$ORDER(^AUTTDOCR("B",ACRREF,0)),1:"")
+50 SET ACRVDA=$PIECE(Y,U,3)
+51 SET ACRALW=$PIECE(Y,U,10)
+52 SET ACRALW=$TRANSLATE(ACRALW," ","")
+53 SET ACRALWDA=$ORDER(^AUTTALLW("B",+ACRALW,0))
+54 SET ACRAPP=$PIECE(Y,U,11)
+55 SET ACRAPP=$TRANSLATE(ACRAPP," ","")
+56 IF ACRAPP]""
SET $PIECE(ACRLBDT,U,4)=$ORDER(^AUTTPRO("B",ACRAPP,0))
+57 KILL ACRLOC,ACRLOCDA
+58 SET ACRLOC=$PIECE(Y,U,12)
+59 IF ACRLOC]""
SET ACRLOCDA=$ORDER(^AUTTLCOD("B",ACRLOC,0))
+60 IF $GET(ACRLOCDA)
IF '$ORDER(^AUTTLCOD("B",ACRLOC,ACRLOCDA))
SET $PIECE(ACRLBDT,U,11)=ACRLOCDA
+61 SET ACRACPT=$EXTRACT(ACRCAN,2,3)
+62 NEW ACRX,ACRY
+63 SET ACRX=0
End DoDot:1
+64 IF $GET(ACRREFX)=326!($GET(ACRREFX)=371)
SET $PIECE(^TMP("ACRINV",$JOB,1),U,2)=ACRDOC
+65 QUIT
AMOUNT ;EP - ENTER PAYMENT AMOUNT
+1 SET DIR(0)="NOA^0:99999999.99:2"
+2 ;S DIR("A")="PAYMENT AMOUNT......: " ;ACR*2.1*16.06 IM15505
+3 ;ACR*2.1*16.06 IM15505
IF ACRBTYP="V"
SET DIR("A")="INVOICE AMOUNT......: "
+4 ;ACR*2.1*16.06 IM15505
IF ACRBTYP="T"
SET DIR("A")="AMOUNT CLAIMED......: "
+5 IF $GET(ACRAMTX)
IF $GET(ACRREF)=618
SET DIR("B")=ACRAMTX
+6 KILL ACRAMTX
+7 DO DIR^ACRFDIC
+8 IF X["^"
SET ACROUT=""
QUIT
+9 IF $DATA(DTOUT)!($DATA(DIRUT))
SET ACROUT=""
QUIT
+10 ;I '+Y W !!,"PAYMENT AMOUNT REQUIRED",! G AMOUNT ;ACR*2.1*16.06 IM15505
+11 ;ACR*2.1*16.06 IM15505
IF '+Y
Begin DoDot:1
+12 ;ACR*2.1*16.06 IM15505
IF ACRBTYP="V"
Begin DoDot:2
+13 ;ACR*2.1*16.06 IM15505
WRITE !!,"REQUIRED: ENTER AMOUNT OF INVOICE, EXCLUSIVE OF DISCOUNTS"
+14 ;ACR*2.1*16.06 IM15505
WRITE " OR INTEREST PENALTIES",!
End DoDot:2
+15 ;ACR*2.1*16.06 IM15505
IF ACRBTYP="T"
Begin DoDot:2
+16 ;ACR*2.1*16.06 IM15505
WRITE !!,"REQUIRED: ENTER AMOUNT CLAIMED ON TRAVEL VOUCHER",!
End DoDot:2
End DoDot:1
GOTO AMOUNT
+17 SET (ACRIVTF,ACRIVT)=Y
+18 SET ACRIVPAY(ACRCANDA,ACROBJDA)=Y
+19 QUIT
INVOICE ;EP; ENTER INVOICE INFORMATION
+1 SET DIR(0)="DO^::AE"
+2 SET DIR("A")="RECEIVING DATE......: "
+3 SET DIR("B")="TODAY"
+4 DO DIR^ACRFDIC
+5 IF 'Y
SET Y=DT
+6 SET ACRRRDAT=+Y
+7 DO EDIT^ACRFIVDX
+8 QUIT
FINAL ;EP - FINAL OR PARTIAL PAYMENT
+1 SET DIR(0)="SO^1:FINAL;2:PARTIAL"
+2 SET DIR("A")="FINAL/PARTIAL......."
+3 DO DIR^ACRFDIC
+4 IF X["^"
SET ACROUT=""
QUIT
+5 IF Y<1
SET ACRQUIT=""
QUIT
+6 SET ACRFINAL=Y
+7 QUIT
SOD ;SELECT OPEN DOCUMENT
+1 KILL ACRODDA
+2 DO SODH
+3 NEW J,ACRXX,ACRYY,ACRZ,ACRZ2
+4 SET (J,ACRXX)=0
+5 FOR
SET ACRXX=$ORDER(^AFSLODOC("DOCNO",ACRDOC,ACRXX))
IF 'ACRXX
QUIT
Begin DoDot:1
+6 SET ACRYY=0
+7 FOR
SET ACRYY=$ORDER(^AFSLODOC("DOCNO",ACRDOC,ACRXX,ACRYY))
IF 'ACRYY
QUIT
Begin DoDot:2
+8 SET J=J+1
+9 SET J(J)=ACRXX_U_ACRYY
+10 SET ACRZ=$GET(^AFSLODOC(ACRXX,1,ACRYY,0))
+11 SET ACRZ2=$GET(^AFSLODOC(ACRXX,1,ACRYY,2))
+12 SET ACRAMTX=$PIECE(ACRZ,U,10)/100
+13 WRITE !?10,J,?15,$PIECE(ACRZ,U),?27,$PIECE(ACRZ,U,3),?36,$PIECE(ACRZ,U,4),?42,$PIECE(ACRZ2,U),?48,$PIECE(^AFSLODOC(ACRXX,0),U),?52,$JUSTIFY($FNUMBER(ACRAMTX,"P,",2),14)
+14 IF IOSL-4<$Y
DO PAUSE^ACRFWARN
KILL ACRQUIT,ACROUT
DO SODH
End DoDot:2
End DoDot:1
+15 SET DIR(0)="NO^1:"_J
+16 SET DIR("A")="Which OPEN DOCUMENT"
+17 WRITE !
+18 DO DIR^ACRFDIC
+19 IF 'Y
SET ACRQUIT=""
QUIT
+20 IF '$DATA(J(Y))
SET ACRQUIT=""
QUIT
+21 SET ACRDFYDA=+J(Y)
+22 SET ACRODDA=$PIECE(J(Y),U,2)
+23 QUIT
SODH ;HEADER
+1 WRITE @IOF
+2 WRITE !?15,"Select OPEN DOCUMENT"
+3 WRITE !?36,"OBJ",?42,"REF"
+4 WRITE !?10,"NO.",?15,"DOCUMENT",?27,"CAN",?36,"CODE",?42,"CODE",?48,"FY",?52,"OBLG AMT"
+5 WRITE !?10,"---",?15,"----------",?27,"-------",?36,"----",?42,"----",?48,"--",?52,"-------------"
+6 QUIT
