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

ACRFIV12.m

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