ACRFIV12 ;IHS/OIRM/DSD/THL,AEF - ACRFIV11 CON'T; [ 7/20/2006 10:25 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,5,16,17,19,20**;NOV 05, 2001
;;
;ACRFIV11 CON'T
SCHNO ;EP;TO CREATE THE NEXT TREASURY SCHEDULE NUMBER
Q:'$D(ACRFY)#2
S ACRX=$O(^ACRSYS(1,50,"B",ACRFY,0))
Q:'ACRX
S X=1
S DA(2)=1
S DA(1)=ACRX
S DIC="^ACRSYS(1,50,"_ACRX_",1,"
S DIC(0)="L"
D FILE^ACRFDIC
I '$G(ACRACPT) D ACPT
S ACRSCHNO=ACRACPT_"A"_$E("000",1,3-$L(+Y))_Y
S DA(2)=1
S DA(1)=ACRX
S DA=+Y
S DIE="^ACRSYS(1,50,"_ACRX_",1,"
S DR=".02////"_ACRSCHNO
D DIE^ACRFDIC
Q
ACPT ;SET ACCOUNING POINT
S ACRACPT=$P($G(^ACRSYS(1,"DT1")),U,13)
S ACRACPT=$P($G(^AUTTACPT(ACRACPT,0)),U)
Q
AIRLINE ;EP;TO PAY AIRLINE EXPENSES
F D A1 Q:$D(ACRQUIT)!$D(^ACROUT)
K ACRQUIT,ACRDOCDA,ACRFYFUN
Q
A1 W @IOF
N ACRINV
K ACRIVTF
W !?22,"TRAVEL ORDER/VOUCHER for Airline Payment",!
S DIC="^ACRDOC("
S DIC(0)="AEMQZ"
S DIC("A")="TRAVEL ORDER/VOUCHER: "
S DIC("S")="I $P(^(0),U,13)=133,$D(^ACRAL(""C"",+Y)),$P(^ACROBL(+Y,""APV""),U)=""A"",'$P(^(""APV""),U,10)"
D DIC^ACRFDIC
I +Y<1 S ACRQUIT="" Q
;
S ACRDOCDA=+Y
S ACRDOC=$P(^ACRDOC(ACRDOCDA,0),U)
;S ACRFYFUN=$P($G(^ACRLOCB(+$P(^ACRDOC(ACRDOCDA,0),U,6),"DT")),U) ;ACR*2.1*16.06 IM15505
S ACRLBDA=$P(^ACRDOC(ACRDOCDA,0),U,6) ;ACR*2.1*16.06 IM15505
S ACRFYFUN=$P($G(^ACRLOCB(ACRLBDA,"DT")),U) ;ACR*2.1*16.06 IM15505
W !
S ACRBTYP="V" ;ACR*2.1*16.06 IM15505
D AMOUNT
Q:'$D(ACRIVPAY)
K ACRVDA
S DIC("B")=$P($G(^ACRSYS(1,501)),U)
D VENDOR^ACRFPAY8
Q:$D(ACRQUIT)!$D(ACROUT)!'$G(ACRVDA)
D INVOICE^ACRFPAY1 ;ADD INVOICE NUMBER ACR*2.1*5.03
Q:$D(ACRQUIT)!$D(ACROUT) ; ACR*2.1*5.03
;S ACRBTYP="V" ;ACR*2.1*16.06 IM15505
;D PTYPE^ACRFPAY9 ;ACR*2.1*16.06 IM15505
;Q:$D(ACRQUIT)!$D(ACROUT) ;ACR*2.1*16.06 IM15505
S DIR("B")=19214
D PTYPE^ACRFPAY9
Q:$D(ACRQUIT)!$D(ACROUT)
S DIR("B")="FINAL"
D FINAL^ACRFPAY1
Q:$D(ACRQUIT)!$D(ACROUT)
D PAYDUE^ACRFIV41
Q:$D(ACRQUIT)!$D(ACROUT)!'$G(ACRPAYDA)!'$G(ACRPAYDU)
;S ACRACH="A" ;ACR*2.1*17.01 IM17097
D SCHT^ACRFIV4 ;GET PAYMENT TYPE ;ACR*2.1*17.01 IM17097
S ACRREF=618
;D ^ACRFIV11 ;ACR*2.1*17.01 IM17097
D BCHECK^ACRFIV12 ;ACR*2.1*17.01 IM17097
Q:$D(ACRQUIT) ;ACR*2.1*17.01 IM17097
D N1166^ACRFIV11 ;ACR*2.1*17.01 IM17097
Q:$D(ACRQUIT) ;ACR*2.1*17.01 IM17097
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR="913////1"
D DIE^ACRFDIC
Q
AMOUNT ;CALCULATE PAYMENT AMOUNT
K ACRIVPAY
N ACRX
S ACRX=0
F S ACRX=$O(^ACRAL("C",ACRDOCDA,ACRX)) Q:'ACRX S ACRIVTF=$G(ACRIVTF)+$P($G(^ACRAL(ACRX,"DT")),U,9)
Q:'$G(ACRIVTF)
S ACRCANDA=$O(^ACRSS("J",ACRDOCDA,0))
Q:'ACRCANDA
S ACROBJDA=$P($G(^ACRSS(ACRCANDA,0)),U,4)
S ACRCANDA=$P($G(^ACRSS(ACRCANDA,0)),U,5)
Q:'ACRCANDA!'ACROBJDA
S DIR("B")=ACRIVTF
D AMOUNT^ACRFPAY1
Q:'$G(ACRIVTF)
S ACRIVPAY(ACRCANDA,ACROBJDA)=ACRIVTF
Q
;SEQNO ;EP;FIND NEXT SEQUENCE NUMBER ;ACR*2.1*16.06 IM15505
SEQNO(ACRFYDA,ACRBATDA,ACRSEQNO) ;EP;FIND NEXT SEQUENCE NUMBER ;ACR*2.1*16.06 IM15505
N X,Y
S Y=0
S X=""
F S X=$O(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,"B",X)) Q:X="" S Y=X
SEQNO1 S ACRSEQNO=Y+1
S ACRSEQNO=$E("0000",1,4-$L(ACRSEQNO))_ACRSEQNO
I $D(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,"B",ACRSEQNO)) S Y=ACRSEQNO G SEQNO1
Q
BCHECK ;EP;TO CHECK FOR BATCH NUMBER AND CREATE NEW BATCH
S ACRFY=$S($E(ACRPAYDA,4,5)<10:$E(ACRPAYDA,1,3),1:$E(ACRPAYDA,1,3)+1)
S ACRFY=ACRFY+1700
I '$D(^AFSLAFP("B",ACRFY)) D
.S X=ACRFY
.S DIC="^AFSLAFP("
.S DIC(0)="L"
.D FILE^ACRFDIC
S ACRFYDA=$O(^AFSLAFP("B",ACRFY,0))
Q:'ACRFYDA
Q:'$D(^AFSLAFP(ACRFYDA,0))
BAT ;DETERMINE IF BATCH EXISTS FOR PAYMENT DATE AND TYPE (PO vs TRAVEL)
K ACRBATNO,ACRQUIT
N J,X,Y,Z
S X=ACRPAYDA-1
F S X=$O(^AFSLAFP("J",X)) Q:'X!(ACRPAYDA<X)!$D(ACRQUIT) D ;ACR*2.1*3.42
.S Y=0
.F S Y=$O(^AFSLAFP("J",X,ACRFYDA,Y)) Q:'Y!$D(ACRQUIT) D
..Q:$P($G(^AFSLAFP(ACRFYDA,1,Y,2)),U,3)'="O"
..S J=$G(J)+1
..S ACRBATNO(J)=$P($G(^AFSLAFP(ACRFYDA,1,Y,0)),U)_U_Y
I '$D(ACRBATNO) D NEWBAT(ACRPAYDA,ACRBTYP,ACRACH,ACRFYDA,.ACRBATNO,.ACRBATDA) Q
S X=0
F S X=$O(ACRBATNO(X)) Q:'X!$D(ACRQUIT) D
.S Y=ACRBATNO(X)
.S J=$E(Y)
.Q:J=""
.I $G(ACRBTYP)="T","DEFO"[J D
..I J="D",ACRACH'="A" Q
..I J="E",ACRACH'="B" Q
..I J="F",ACRACH'="C" Q
..I J="O",ACRACH'="N" Q
..S Z=Y
.I "ABCGN"[J,$G(ACRBTYP)="V",$P($G(^AFSLAFP(ACRFYDA,1,+$P(Y,U,2),2)),U,8)=ACRACH S Z=Y
.I $G(Z)]"" D I 1
..S ACRBATDA=$P(Z,U,2)
..I $G(ACRBATDA),$$COUNT(ACRFYDA,ACRBATDA)<59!$P(^ACRSYS(1,"DT1"),U,16) D I 1
...K ACRBATNO
...S ACRQUIT=""
...S ACRBATNO=$P(Z,U)
..E K ACRBATDA
K ACRQUIT
I $G(ACRBATDA),$G(ACRFYDA) D
. I $P($G(^AFSLAFP(ACRFYDA,1,ACRBATDA,2)),U,3)="C" K ACRBATNO,ACRBATDA Q
. I $P($G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,0)),U,4)>59 K ACRBATNO,ACRBATDA
I $G(ACRBATNO)=""!'$G(ACRBATDA) D NEWBAT(ACRPAYDA,ACRBTYP,ACRACH,ACRFYDA,.ACRBATNO,.ACRBATDA)
Q
NEWBAT(ACRPAYDA,ACRBTYP,ACRACH,ACRFYDA,ACRBATNO,ACRBATDA) ;
;----- CREATE NEW 1166 BATCH
;
; ACRPAYDA = PAYMENT DUE DATE
; ACRBTYP = BATCH TYPE (V=VENDOR,T=TRAVEL)
; ACRACH = ACH SCHEDULE FORMAT
; ACRFYDA = FISCAL YEAR IEN IN 1166 APPROVALS FOR PAYMENT FILE
; ACRJDATE = JULIAN DATE
; V = BATCH PREFIX
; ACRBATNO = BATCH NUMBER (RETURNED)
; ACRBATDA = BATCH IEN IN 1166 APPROVALS FOR PAYMENT FILE (RETURNED)
;
N ACRJDATE,DA,DIC,DR,I,V,X,Y
S ACRJDATE=$$JDATE(ACRPAYDA)
I ACRBTYP="V" S V=ACRACH
I ACRBTYP="T" D
.S:ACRACH="A" V="D"
.S:ACRACH="B" V="E"
.S:ACRACH="C" V="F"
.S:ACRACH="N" V="O"
.S:ACRACH="G" V="G"
F I=1:1:99 D Q:'$D(^AFSLAFP("L",X,ACRFYDA))
. S X=V_ACRJDATE_$$PAD^ACRFUTL(I,"L",2,0)
Q:$D(^AFSLAFP("L",X,ACRFYDA))
S ACRBATNO=X
S DA(1)=ACRFYDA
S DIC="^AFSLAFP("_DA(1)_",1,"
S DIC(0)="L"
S DIC("P")=$P(^DD(9002325,1,0),U,2)
S DIC("DR")=".04////"_$G(ACRBTYP)_";1////"_DT_";3////"_ACRPAYDA_";6////O;8////"_DUZ_";22////"_ACRACH
K DD,DO
D FILE^DICN
S ACRBATDA=+Y
Q
JDATE(X) ;EP;CALCULATE JULIAN DATE
S X1=X
S X2=$E(X,1,3)_"0101"
D ^%DTC
S X=X+1
S X=$E("000",1,3-$L(X))_X
Q X
COUNT(X,Y) ;EP;COUNT NUMBER OF PAYMENTS
;FORCE NEW BATCH IF MORE THAN 60 PAYMENTS
N A,J,K,Z
S Z=$P($G(^AFSLAFP(X,1,Y,2)),U,8)
S (J,K)=0
F S K=$O(^AFSLAFP(X,1,Y,1,K)) Q:'K D
.;IF ACH-GROUPED BATCH THEN COUNT ONLY NUMBER OF VENDORS/TRAVELERS
.I Z]"","AD"[Z D Q:A
..S A=$G(^AFSLAFP(X,1,Y,1,K,0))
..S A=$S($P(A,U,10):$P(A,U,10),$P(A,U,24):$P(A,U,24),1:"")
..I A,'$D(Z(A)) S J=J+1,Z(A)=""
.K A
.S J=J+1
N X,Y
S X=0
F S X=$O(ACRIVPAY(X)) Q:'X D
.S Y=0
.F S Y=$O(ACRIVPAY(X,Y)) Q:'Y S J=J+1
S X=0
F S X=$O(ACRIVDIS(X)) Q:'X D
.S Y=0
.F S Y=$O(ACRIVDIS(X,Y)) Q:'Y S J=J+1
Q J
VENDOR ;EP;GATHER ALL VENDOR DATA ; SUBROUTINE REWRITTEN ACR*2.1*20.10 IM18953
Q:'$G(ACRVDA)
S ACR3=$S($G(ACR3):ACR3,1:1)
S ACRV11=$G(^AUTTVNDR(ACRVDA,11))
S ACRV13=$G(^AUTTVNDR(ACRVDA,13))
S ACRV14=$G(^AUTTVNDR(ACRVDA,14))
S ACR16=ACRVDA
S ACR33=$E($P($G(^AUTTVNDR(ACRVDA,0)),U),1,40)
S ACR33=$$UPPER(ACR33)
S ACR58=$P(ACRV11,U,13)
S ACR56=$E($P(ACRV11,U,13),11,12)
S ACR65=ACRVDA
;BEGIN OLD CODE
;S ACR28=$P(ACRV14,U,6)
;S ACR28=$$UPPER(ACR28)
;S ACR29=$E($S($P(ACRV14,U,1)]"":$P(ACRV14,U,1),1:$P(ACRV13,U,1)),1,30)
;S ACR29=$$UPPER(ACR29)
;S ACR30=$E($S($P(ACRV14,U,3)]"":$P(ACRV14,U,3),1:$P(ACRV13,U,2)),1,20)
;S ACR30=$$UPPER(ACR30)
;S ACR31=$S($P(ACRV14,U,4)]"":$P(ACRV14,U,4),1:$P(ACRV13,U,3))
;S ACR31=$P($G(^DIC(5,+ACR31,0)),U,2)
;S ACR32=$E($S($P(ACRV14,U,5)]"":$P(ACRV14,U,5),1:$P(ACRV13,U,4)),1,10)
;S ACR68=$E($S($P(ACRV14,U,2)]"":$P(ACRV14,U,2),1:$P(ACRV13,U,10)),1,30)
;S ACR68=$$UPPER(ACR68)
;Q
;BEGIN NEW CODE
S ACR28=$P(ACRV14,U,6) ;REMIT ATTN
S ACR29=$P(ACRV14,U,1) ;REMIT STREET
S ACR68=$P(ACRV14,U,2) ;REMIT STREET 2
S ACR30=$P(ACRV14,U,3) ;REMIT CITY
S ACR31=$P(ACRV14,U,4) ;REMIT STATE
S ACR32=$P(ACRV14,U,5) ;REMIT ZIP
I ACR29=""!(ACR30="")!(ACR31="") S (ACR28,ACR29,ACR30,ACR31,ACR32,ACR68)=""
I ACR29="" D
.S ACR28=$P(ACRV13,U,5) ;MAIL ATTN
.S ACR29=$P(ACRV13,U,1) ;MAIL STREET
.S ACR68=$P(ACRV13,U,10) ;MAIL STREET 2
.S ACR30=$P(ACRV13,U,2) ;MAIL CITY
.S ACR31=$P(ACRV13,U,3) ;MAIL STATE
.S ACR32=$P(ACRV13,U,4) ;MAIL ZIP
.I ACR29=""!(ACR30="")!(ACR31="") S (ACR28,ACR29,ACR30,ACR31,ACR32)=""
S ACR31=$P($G(^DIC(5,+ACR31,0)),U,2)
S ACR28=$$UPPER(ACR28)
S ACR29=$$UPPER(ACR29)
S ACR30=$$UPPER(ACR30)
S ACR68=$$UPPER(ACR68)
Q
TRAVELER ;EP;GATHER TRAVELER DATA FOR TRAVEL PAYMENT
N X,Z
S (X,ACRDUZ)=$S($G(ACRDUZ):ACRDUZ,1:$P($G(^ACRDOC(ACRDOCDA,"TO")),U,9))
;S ACR33=$P($G(^VA(200,+X,0)),U) ;ACR*2.1*19.02 IM16848
S ACR33=$$NAME2^ACRFUTL1(+X) ;ACR*2.1*19.02 IM16848
I ACR33="" S ACROUT="" Q
I $G(ACRDOCDA) S ACRBEG=$G(^ACRDOC(ACRDOCDA,"TO"))
I $G(ACRDOCDA) S ACREND=$P(ACRBEG,U,15)
I $G(ACRDOCDA) S ACRBEG=$P(ACRBEG,U,14)
S ACR58=$P($G(^VA(200,+X,1)),U,9)
S ACR27=X
S Z=$G(^VA(200,X,.11))
S ACR29=$P(Z,U)
S ACR29=$$UPPER(ACR29)
S ACR68=$P(Z,U,2)
S ACR68=$$UPPER(ACR68)
S ACR30=$P(Z,U,4)
S ACR30=$$UPPER(ACR30)
S ACR31=$P($G(^DIC(5,+$P(Z,U,5),0)),U,2)
S ACR32=$P(Z,U,6)
S ACRREF2=$P($G(^ACRDOC(+$G(ACRDOCDA),18)),U,5)
S ACR18=+$P($G(^ACRDOC(+$G(ACRDOCDA),"TO")),U,25) ;TRAVEL ADVANCE
S ACR18=$P(ACR18,".")
S:ACRREF2 ACRREF2=$P($G(^AUTTDOCR(ACRREF2,0)),U)
S ACRDOC2=$P($G(^ACRDOC(+$G(ACRDOCDA),18)),U,4)
S ACR3=$S($G(ACR3):ACR3,1:4)
S ACRFINAL=1
S ACR64=ACRDUZ
S ACRTCODE=$S($G(ACRTCODE)]"":ACRTCODE,1:19214)
S:$G(ACRFYFUN)="" ACRFYFUN=$P($G(^ACRLOCB(+$P($G(^ACRDOC(+$G(ACRDOCDA),0)),U,6),"DT")),U)
Q
UPPER(X) ;CONVERT TO UPPER CASE
X ^%ZOSF("UPPERCASE")
Q Y
DATES ;EP -- GET TRAVEL BEGIN AND END DATES
;
; RETURNS: ACRBEG = BEGINNING TRAVEL DATE
; ACREND = ENDING TRAVEL DATE
;
N DIR,X,Y
K ACRBEG,ACREND
N ACRTMP ;ACR*2.1*3.37
I +$G(ACRX),$G(ACRDOC) D ;ACR*2.1*3.37
.S ACRTMP=$G(^ACRDOC(ACRX,"TO")) ;ACR*2.1*3.37
.S ACRBEG=$P(ACRTMP,U,14),ACREND=$P(ACRTMP,U,15) ;ACR*2.1*3.37
I +$G(ACRBEG) D ;ACR*2.1*3.37
.N Y S Y=ACRBEG X ^DD("DD") S DIR("B")=Y ;ACR*2.1*3.37
S DIR(0)="D^::E"
S DIR("A")="TRAVEL BEGIN DATE..."
S DIR("?")="Enter the beginning date of travel"
D ^DIR
I $D(DTOUT)!($D(DIRUT)) S ACROUT="" Q
S ACRBEG=Y
I +$G(ACREND) D ;ACR*2.1*3.37
.N Y S Y=ACREND X ^DD("DD") S DIR("B")=Y ;ACR*2.1*3.37
S DIR("A")="TRAVEL END DATE....."
S DIR("?")="Enter the ending date of travel"
D ^DIR
I $D(DTOUT)!($D(DIRUT)) K ACRBEG S ACROUT="" Q
S ACREND=Y
I ACREND<ACRBEG W !,*7," ENDING DATE CANNOT BE BEFORE BEGINNING DATE!" G DATES
Q
ACRFIV12 ;IHS/OIRM/DSD/THL,AEF - ACRFIV11 CON'T; [ 7/20/2006 10:25 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,5,16,17,19,20**;NOV 05, 2001
+2 ;;
+3 ;ACRFIV11 CON'T
SCHNO ;EP;TO CREATE THE NEXT TREASURY SCHEDULE NUMBER
+1 IF '$DATA(ACRFY)#2
QUIT
+2 SET ACRX=$ORDER(^ACRSYS(1,50,"B",ACRFY,0))
+3 IF 'ACRX
QUIT
+4 SET X=1
+5 SET DA(2)=1
+6 SET DA(1)=ACRX
+7 SET DIC="^ACRSYS(1,50,"_ACRX_",1,"
+8 SET DIC(0)="L"
+9 DO FILE^ACRFDIC
+10 IF '$GET(ACRACPT)
DO ACPT
+11 SET ACRSCHNO=ACRACPT_"A"_$EXTRACT("000",1,3-$LENGTH(+Y))_Y
+12 SET DA(2)=1
+13 SET DA(1)=ACRX
+14 SET DA=+Y
+15 SET DIE="^ACRSYS(1,50,"_ACRX_",1,"
+16 SET DR=".02////"_ACRSCHNO
+17 DO DIE^ACRFDIC
+18 QUIT
ACPT ;SET ACCOUNING POINT
+1 SET ACRACPT=$PIECE($GET(^ACRSYS(1,"DT1")),U,13)
+2 SET ACRACPT=$PIECE($GET(^AUTTACPT(ACRACPT,0)),U)
+3 QUIT
AIRLINE ;EP;TO PAY AIRLINE EXPENSES
+1 FOR
DO A1
IF $DATA(ACRQUIT)!$DATA(^ACROUT)
QUIT
+2 KILL ACRQUIT,ACRDOCDA,ACRFYFUN
+3 QUIT
A1 WRITE @IOF
+1 NEW ACRINV
+2 KILL ACRIVTF
+3 WRITE !?22,"TRAVEL ORDER/VOUCHER for Airline Payment",!
+4 SET DIC="^ACRDOC("
+5 SET DIC(0)="AEMQZ"
+6 SET DIC("A")="TRAVEL ORDER/VOUCHER: "
+7 SET DIC("S")="I $P(^(0),U,13)=133,$D(^ACRAL(""C"",+Y)),$P(^ACROBL(+Y,""APV""),U)=""A"",'$P(^(""APV""),U,10)"
+8 DO DIC^ACRFDIC
+9 IF +Y<1
SET ACRQUIT=""
QUIT
+10 ;
+11 SET ACRDOCDA=+Y
+12 SET ACRDOC=$PIECE(^ACRDOC(ACRDOCDA,0),U)
+13 ;S ACRFYFUN=$P($G(^ACRLOCB(+$P(^ACRDOC(ACRDOCDA,0),U,6),"DT")),U) ;ACR*2.1*16.06 IM15505
+14 ;ACR*2.1*16.06 IM15505
SET ACRLBDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,6)
+15 ;ACR*2.1*16.06 IM15505
SET ACRFYFUN=$PIECE($GET(^ACRLOCB(ACRLBDA,"DT")),U)
+16 WRITE !
+17 ;ACR*2.1*16.06 IM15505
SET ACRBTYP="V"
+18 DO AMOUNT
+19 IF '$DATA(ACRIVPAY)
QUIT
+20 KILL ACRVDA
+21 SET DIC("B")=$PIECE($GET(^ACRSYS(1,501)),U)
+22 DO VENDOR^ACRFPAY8
+23 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$GET(ACRVDA)
QUIT
+24 ;ADD INVOICE NUMBER ACR*2.1*5.03
DO INVOICE^ACRFPAY1
+25 ; ACR*2.1*5.03
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+26 ;S ACRBTYP="V" ;ACR*2.1*16.06 IM15505
+27 ;D PTYPE^ACRFPAY9 ;ACR*2.1*16.06 IM15505
+28 ;Q:$D(ACRQUIT)!$D(ACROUT) ;ACR*2.1*16.06 IM15505
+29 SET DIR("B")=19214
+30 DO PTYPE^ACRFPAY9
+31 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+32 SET DIR("B")="FINAL"
+33 DO FINAL^ACRFPAY1
+34 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+35 DO PAYDUE^ACRFIV41
+36 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$GET(ACRPAYDA)!'$GET(ACRPAYDU)
QUIT
+37 ;S ACRACH="A" ;ACR*2.1*17.01 IM17097
+38 ;GET PAYMENT TYPE ;ACR*2.1*17.01 IM17097
DO SCHT^ACRFIV4
+39 SET ACRREF=618
+40 ;D ^ACRFIV11 ;ACR*2.1*17.01 IM17097
+41 ;ACR*2.1*17.01 IM17097
DO BCHECK^ACRFIV12
+42 ;ACR*2.1*17.01 IM17097
IF $DATA(ACRQUIT)
QUIT
+43 ;ACR*2.1*17.01 IM17097
DO N1166^ACRFIV11
+44 ;ACR*2.1*17.01 IM17097
IF $DATA(ACRQUIT)
QUIT
+45 SET DA=ACRDOCDA
+46 SET DIE="^ACROBL("
+47 SET DR="913////1"
+48 DO DIE^ACRFDIC
+49 QUIT
AMOUNT ;CALCULATE PAYMENT AMOUNT
+1 KILL ACRIVPAY
+2 NEW ACRX
+3 SET ACRX=0
+4 FOR
SET ACRX=$ORDER(^ACRAL("C",ACRDOCDA,ACRX))
IF 'ACRX
QUIT
SET ACRIVTF=$GET(ACRIVTF)+$PIECE($GET(^ACRAL(ACRX,"DT")),U,9)
+5 IF '$GET(ACRIVTF)
QUIT
+6 SET ACRCANDA=$ORDER(^ACRSS("J",ACRDOCDA,0))
+7 IF 'ACRCANDA
QUIT
+8 SET ACROBJDA=$PIECE($GET(^ACRSS(ACRCANDA,0)),U,4)
+9 SET ACRCANDA=$PIECE($GET(^ACRSS(ACRCANDA,0)),U,5)
+10 IF 'ACRCANDA!'ACROBJDA
QUIT
+11 SET DIR("B")=ACRIVTF
+12 DO AMOUNT^ACRFPAY1
+13 IF '$GET(ACRIVTF)
QUIT
+14 SET ACRIVPAY(ACRCANDA,ACROBJDA)=ACRIVTF
+15 QUIT
+16 ;SEQNO ;EP;FIND NEXT SEQUENCE NUMBER ;ACR*2.1*16.06 IM15505
SEQNO(ACRFYDA,ACRBATDA,ACRSEQNO) ;EP;FIND NEXT SEQUENCE NUMBER ;ACR*2.1*16.06 IM15505
+1 NEW X,Y
+2 SET Y=0
+3 SET X=""
+4 FOR
SET X=$ORDER(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,"B",X))
IF X=""
QUIT
SET Y=X
SEQNO1 SET ACRSEQNO=Y+1
+1 SET ACRSEQNO=$EXTRACT("0000",1,4-$LENGTH(ACRSEQNO))_ACRSEQNO
+2 IF $DATA(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,"B",ACRSEQNO))
SET Y=ACRSEQNO
GOTO SEQNO1
+3 QUIT
BCHECK ;EP;TO CHECK FOR BATCH NUMBER AND CREATE NEW BATCH
+1 SET ACRFY=$SELECT($EXTRACT(ACRPAYDA,4,5)<10:$EXTRACT(ACRPAYDA,1,3),1:$EXTRACT(ACRPAYDA,1,3)+1)
+2 SET ACRFY=ACRFY+1700
+3 IF '$DATA(^AFSLAFP("B",ACRFY))
Begin DoDot:1
+4 SET X=ACRFY
+5 SET DIC="^AFSLAFP("
+6 SET DIC(0)="L"
+7 DO FILE^ACRFDIC
End DoDot:1
+8 SET ACRFYDA=$ORDER(^AFSLAFP("B",ACRFY,0))
+9 IF 'ACRFYDA
QUIT
+10 IF '$DATA(^AFSLAFP(ACRFYDA,0))
QUIT
BAT ;DETERMINE IF BATCH EXISTS FOR PAYMENT DATE AND TYPE (PO vs TRAVEL)
+1 KILL ACRBATNO,ACRQUIT
+2 NEW J,X,Y,Z
+3 SET X=ACRPAYDA-1
+4 ;ACR*2.1*3.42
FOR
SET X=$ORDER(^AFSLAFP("J",X))
IF 'X!(ACRPAYDA<X)!$DATA(ACRQUIT)
QUIT
Begin DoDot:1
+5 SET Y=0
+6 FOR
SET Y=$ORDER(^AFSLAFP("J",X,ACRFYDA,Y))
IF 'Y!$DATA(ACRQUIT)
QUIT
Begin DoDot:2
+7 IF $PIECE($GET(^AFSLAFP(ACRFYDA,1,Y,2)),U,3)'="O"
QUIT
+8 SET J=$GET(J)+1
+9 SET ACRBATNO(J)=$PIECE($GET(^AFSLAFP(ACRFYDA,1,Y,0)),U)_U_Y
End DoDot:2
End DoDot:1
+10 IF '$DATA(ACRBATNO)
DO NEWBAT(ACRPAYDA,ACRBTYP,ACRACH,ACRFYDA,.ACRBATNO,.ACRBATDA)
QUIT
+11 SET X=0
+12 FOR
SET X=$ORDER(ACRBATNO(X))
IF 'X!$DATA(ACRQUIT)
QUIT
Begin DoDot:1
+13 SET Y=ACRBATNO(X)
+14 SET J=$EXTRACT(Y)
+15 IF J=""
QUIT
+16 IF $GET(ACRBTYP)="T"
IF "DEFO"[J
Begin DoDot:2
+17 IF J="D"
IF ACRACH'="A"
QUIT
+18 IF J="E"
IF ACRACH'="B"
QUIT
+19 IF J="F"
IF ACRACH'="C"
QUIT
+20 IF J="O"
IF ACRACH'="N"
QUIT
+21 SET Z=Y
End DoDot:2
+22 IF "ABCGN"[J
IF $GET(ACRBTYP)="V"
IF $PIECE($GET(^AFSLAFP(ACRFYDA,1,+$PIECE(Y,U,2),2)),U,8)=ACRACH
SET Z=Y
+23 IF $GET(Z)]""
Begin DoDot:2
+24 SET ACRBATDA=$PIECE(Z,U,2)
+25 IF $GET(ACRBATDA)
IF $$COUNT(ACRFYDA,ACRBATDA)<59!$PIECE(^ACRSYS(1,"DT1"),U,16)
Begin DoDot:3
+26 KILL ACRBATNO
+27 SET ACRQUIT=""
+28 SET ACRBATNO=$PIECE(Z,U)
End DoDot:3
IF 1
+29 IF '$TEST
KILL ACRBATDA
End DoDot:2
IF 1
End DoDot:1
+30 KILL ACRQUIT
+31 IF $GET(ACRBATDA)
IF $GET(ACRFYDA)
Begin DoDot:1
+32 IF $PIECE($GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,2)),U,3)="C"
KILL ACRBATNO,ACRBATDA
QUIT
+33 IF $PIECE($GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,0)),U,4)>59
KILL ACRBATNO,ACRBATDA
End DoDot:1
+34 IF $GET(ACRBATNO)=""!'$GET(ACRBATDA)
DO NEWBAT(ACRPAYDA,ACRBTYP,ACRACH,ACRFYDA,.ACRBATNO,.ACRBATDA)
+35 QUIT
NEWBAT(ACRPAYDA,ACRBTYP,ACRACH,ACRFYDA,ACRBATNO,ACRBATDA) ;
+1 ;----- CREATE NEW 1166 BATCH
+2 ;
+3 ; ACRPAYDA = PAYMENT DUE DATE
+4 ; ACRBTYP = BATCH TYPE (V=VENDOR,T=TRAVEL)
+5 ; ACRACH = ACH SCHEDULE FORMAT
+6 ; ACRFYDA = FISCAL YEAR IEN IN 1166 APPROVALS FOR PAYMENT FILE
+7 ; ACRJDATE = JULIAN DATE
+8 ; V = BATCH PREFIX
+9 ; ACRBATNO = BATCH NUMBER (RETURNED)
+10 ; ACRBATDA = BATCH IEN IN 1166 APPROVALS FOR PAYMENT FILE (RETURNED)
+11 ;
+12 NEW ACRJDATE,DA,DIC,DR,I,V,X,Y
+13 SET ACRJDATE=$$JDATE(ACRPAYDA)
+14 IF ACRBTYP="V"
SET V=ACRACH
+15 IF ACRBTYP="T"
Begin DoDot:1
+16 IF ACRACH="A"
SET V="D"
+17 IF ACRACH="B"
SET V="E"
+18 IF ACRACH="C"
SET V="F"
+19 IF ACRACH="N"
SET V="O"
+20 IF ACRACH="G"
SET V="G"
End DoDot:1
+21 FOR I=1:1:99
Begin DoDot:1
+22 SET X=V_ACRJDATE_$$PAD^ACRFUTL(I,"L",2,0)
End DoDot:1
IF '$DATA(^AFSLAFP("L",X,ACRFYDA))
QUIT
+23 IF $DATA(^AFSLAFP("L",X,ACRFYDA))
QUIT
+24 SET ACRBATNO=X
+25 SET DA(1)=ACRFYDA
+26 SET DIC="^AFSLAFP("_DA(1)_",1,"
+27 SET DIC(0)="L"
+28 SET DIC("P")=$PIECE(^DD(9002325,1,0),U,2)
+29 SET DIC("DR")=".04////"_$GET(ACRBTYP)_";1////"_DT_";3////"_ACRPAYDA_";6////O;8////"_DUZ_";22////"_ACRACH
+30 KILL DD,DO
+31 DO FILE^DICN
+32 SET ACRBATDA=+Y
+33 QUIT
JDATE(X) ;EP;CALCULATE JULIAN DATE
+1 SET X1=X
+2 SET X2=$EXTRACT(X,1,3)_"0101"
+3 DO ^%DTC
+4 SET X=X+1
+5 SET X=$EXTRACT("000",1,3-$LENGTH(X))_X
+6 QUIT X
COUNT(X,Y) ;EP;COUNT NUMBER OF PAYMENTS
+1 ;FORCE NEW BATCH IF MORE THAN 60 PAYMENTS
+2 NEW A,J,K,Z
+3 SET Z=$PIECE($GET(^AFSLAFP(X,1,Y,2)),U,8)
+4 SET (J,K)=0
+5 FOR
SET K=$ORDER(^AFSLAFP(X,1,Y,1,K))
IF 'K
QUIT
Begin DoDot:1
+6 ;IF ACH-GROUPED BATCH THEN COUNT ONLY NUMBER OF VENDORS/TRAVELERS
+7 IF Z]""
IF "AD"[Z
Begin DoDot:2
+8 SET A=$GET(^AFSLAFP(X,1,Y,1,K,0))
+9 SET A=$SELECT($PIECE(A,U,10):$PIECE(A,U,10),$PIECE(A,U,24):$PIECE(A,U,24),1:"")
+10 IF A
IF '$DATA(Z(A))
SET J=J+1
SET Z(A)=""
End DoDot:2
IF A
QUIT
+11 KILL A
+12 SET J=J+1
End DoDot:1
+13 NEW X,Y
+14 SET X=0
+15 FOR
SET X=$ORDER(ACRIVPAY(X))
IF 'X
QUIT
Begin DoDot:1
+16 SET Y=0
+17 FOR
SET Y=$ORDER(ACRIVPAY(X,Y))
IF 'Y
QUIT
SET J=J+1
End DoDot:1
+18 SET X=0
+19 FOR
SET X=$ORDER(ACRIVDIS(X))
IF 'X
QUIT
Begin DoDot:1
+20 SET Y=0
+21 FOR
SET Y=$ORDER(ACRIVDIS(X,Y))
IF 'Y
QUIT
SET J=J+1
End DoDot:1
+22 QUIT J
VENDOR ;EP;GATHER ALL VENDOR DATA ; SUBROUTINE REWRITTEN ACR*2.1*20.10 IM18953
+1 IF '$GET(ACRVDA)
QUIT
+2 SET ACR3=$SELECT($GET(ACR3):ACR3,1:1)
+3 SET ACRV11=$GET(^AUTTVNDR(ACRVDA,11))
+4 SET ACRV13=$GET(^AUTTVNDR(ACRVDA,13))
+5 SET ACRV14=$GET(^AUTTVNDR(ACRVDA,14))
+6 SET ACR16=ACRVDA
+7 SET ACR33=$EXTRACT($PIECE($GET(^AUTTVNDR(ACRVDA,0)),U),1,40)
+8 SET ACR33=$$UPPER(ACR33)
+9 SET ACR58=$PIECE(ACRV11,U,13)
+10 SET ACR56=$EXTRACT($PIECE(ACRV11,U,13),11,12)
+11 SET ACR65=ACRVDA
+12 ;BEGIN OLD CODE
+13 ;S ACR28=$P(ACRV14,U,6)
+14 ;S ACR28=$$UPPER(ACR28)
+15 ;S ACR29=$E($S($P(ACRV14,U,1)]"":$P(ACRV14,U,1),1:$P(ACRV13,U,1)),1,30)
+16 ;S ACR29=$$UPPER(ACR29)
+17 ;S ACR30=$E($S($P(ACRV14,U,3)]"":$P(ACRV14,U,3),1:$P(ACRV13,U,2)),1,20)
+18 ;S ACR30=$$UPPER(ACR30)
+19 ;S ACR31=$S($P(ACRV14,U,4)]"":$P(ACRV14,U,4),1:$P(ACRV13,U,3))
+20 ;S ACR31=$P($G(^DIC(5,+ACR31,0)),U,2)
+21 ;S ACR32=$E($S($P(ACRV14,U,5)]"":$P(ACRV14,U,5),1:$P(ACRV13,U,4)),1,10)
+22 ;S ACR68=$E($S($P(ACRV14,U,2)]"":$P(ACRV14,U,2),1:$P(ACRV13,U,10)),1,30)
+23 ;S ACR68=$$UPPER(ACR68)
+24 ;Q
+25 ;BEGIN NEW CODE
+26 ;REMIT ATTN
SET ACR28=$PIECE(ACRV14,U,6)
+27 ;REMIT STREET
SET ACR29=$PIECE(ACRV14,U,1)
+28 ;REMIT STREET 2
SET ACR68=$PIECE(ACRV14,U,2)
+29 ;REMIT CITY
SET ACR30=$PIECE(ACRV14,U,3)
+30 ;REMIT STATE
SET ACR31=$PIECE(ACRV14,U,4)
+31 ;REMIT ZIP
SET ACR32=$PIECE(ACRV14,U,5)
+32 IF ACR29=""!(ACR30="")!(ACR31="")
SET (ACR28,ACR29,ACR30,ACR31,ACR32,ACR68)=""
+33 IF ACR29=""
Begin DoDot:1
+34 ;MAIL ATTN
SET ACR28=$PIECE(ACRV13,U,5)
+35 ;MAIL STREET
SET ACR29=$PIECE(ACRV13,U,1)
+36 ;MAIL STREET 2
SET ACR68=$PIECE(ACRV13,U,10)
+37 ;MAIL CITY
SET ACR30=$PIECE(ACRV13,U,2)
+38 ;MAIL STATE
SET ACR31=$PIECE(ACRV13,U,3)
+39 ;MAIL ZIP
SET ACR32=$PIECE(ACRV13,U,4)
+40 IF ACR29=""!(ACR30="")!(ACR31="")
SET (ACR28,ACR29,ACR30,ACR31,ACR32)=""
End DoDot:1
+41 SET ACR31=$PIECE($GET(^DIC(5,+ACR31,0)),U,2)
+42 SET ACR28=$$UPPER(ACR28)
+43 SET ACR29=$$UPPER(ACR29)
+44 SET ACR30=$$UPPER(ACR30)
+45 SET ACR68=$$UPPER(ACR68)
+46 QUIT
TRAVELER ;EP;GATHER TRAVELER DATA FOR TRAVEL PAYMENT
+1 NEW X,Z
+2 SET (X,ACRDUZ)=$SELECT($GET(ACRDUZ):ACRDUZ,1:$PIECE($GET(^ACRDOC(ACRDOCDA,"TO")),U,9))
+3 ;S ACR33=$P($G(^VA(200,+X,0)),U) ;ACR*2.1*19.02 IM16848
+4 ;ACR*2.1*19.02 IM16848
SET ACR33=$$NAME2^ACRFUTL1(+X)
+5 IF ACR33=""
SET ACROUT=""
QUIT
+6 IF $GET(ACRDOCDA)
SET ACRBEG=$GET(^ACRDOC(ACRDOCDA,"TO"))
+7 IF $GET(ACRDOCDA)
SET ACREND=$PIECE(ACRBEG,U,15)
+8 IF $GET(ACRDOCDA)
SET ACRBEG=$PIECE(ACRBEG,U,14)
+9 SET ACR58=$PIECE($GET(^VA(200,+X,1)),U,9)
+10 SET ACR27=X
+11 SET Z=$GET(^VA(200,X,.11))
+12 SET ACR29=$PIECE(Z,U)
+13 SET ACR29=$$UPPER(ACR29)
+14 SET ACR68=$PIECE(Z,U,2)
+15 SET ACR68=$$UPPER(ACR68)
+16 SET ACR30=$PIECE(Z,U,4)
+17 SET ACR30=$$UPPER(ACR30)
+18 SET ACR31=$PIECE($GET(^DIC(5,+$PIECE(Z,U,5),0)),U,2)
+19 SET ACR32=$PIECE(Z,U,6)
+20 SET ACRREF2=$PIECE($GET(^ACRDOC(+$GET(ACRDOCDA),18)),U,5)
+21 ;TRAVEL ADVANCE
SET ACR18=+$PIECE($GET(^ACRDOC(+$GET(ACRDOCDA),"TO")),U,25)
+22 SET ACR18=$PIECE(ACR18,".")
+23 IF ACRREF2
SET ACRREF2=$PIECE($GET(^AUTTDOCR(ACRREF2,0)),U)
+24 SET ACRDOC2=$PIECE($GET(^ACRDOC(+$GET(ACRDOCDA),18)),U,4)
+25 SET ACR3=$SELECT($GET(ACR3):ACR3,1:4)
+26 SET ACRFINAL=1
+27 SET ACR64=ACRDUZ
+28 SET ACRTCODE=$SELECT($GET(ACRTCODE)]"":ACRTCODE,1:19214)
+29 IF $GET(ACRFYFUN)=""
SET ACRFYFUN=$PIECE($GET(^ACRLOCB(+$PIECE($GET(^ACRDOC(+$GET(ACRDOCDA),0)),U,6),"DT")),U)
+30 QUIT
UPPER(X) ;CONVERT TO UPPER CASE
+1 XECUTE ^%ZOSF("UPPERCASE")
+2 QUIT Y
DATES ;EP -- GET TRAVEL BEGIN AND END DATES
+1 ;
+2 ; RETURNS: ACRBEG = BEGINNING TRAVEL DATE
+3 ; ACREND = ENDING TRAVEL DATE
+4 ;
+5 NEW DIR,X,Y
+6 KILL ACRBEG,ACREND
+7 ;ACR*2.1*3.37
NEW ACRTMP
+8 ;ACR*2.1*3.37
IF +$GET(ACRX)
IF $GET(ACRDOC)
Begin DoDot:1
+9 ;ACR*2.1*3.37
SET ACRTMP=$GET(^ACRDOC(ACRX,"TO"))
+10 ;ACR*2.1*3.37
SET ACRBEG=$PIECE(ACRTMP,U,14)
SET ACREND=$PIECE(ACRTMP,U,15)
End DoDot:1
+11 ;ACR*2.1*3.37
IF +$GET(ACRBEG)
Begin DoDot:1
+12 ;ACR*2.1*3.37
NEW Y
SET Y=ACRBEG
XECUTE ^DD("DD")
SET DIR("B")=Y
End DoDot:1
+13 SET DIR(0)="D^::E"
+14 SET DIR("A")="TRAVEL BEGIN DATE..."
+15 SET DIR("?")="Enter the beginning date of travel"
+16 DO ^DIR
+17 IF $DATA(DTOUT)!($DATA(DIRUT))
SET ACROUT=""
QUIT
+18 SET ACRBEG=Y
+19 ;ACR*2.1*3.37
IF +$GET(ACREND)
Begin DoDot:1
+20 ;ACR*2.1*3.37
NEW Y
SET Y=ACREND
XECUTE ^DD("DD")
SET DIR("B")=Y
End DoDot:1
+21 SET DIR("A")="TRAVEL END DATE....."
+22 SET DIR("?")="Enter the ending date of travel"
+23 DO ^DIR
+24 IF $DATA(DTOUT)!($DATA(DIRUT))
KILL ACRBEG
SET ACROUT=""
QUIT
+25 SET ACREND=Y
+26 IF ACREND<ACRBEG
WRITE !,*7," ENDING DATE CANNOT BE BEFORE BEGINNING DATE!"
GOTO DATES
+27 QUIT
