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

AFSLACHT.m

Go to the documentation of this file. 
  1. AFSLACHT ;IHS/OIRM/DSD/JLG - WRITE TO TRAVEL-ACH FORMAT FILE;  [ 09/26/2005  12:53 PM ]
  1.  ;;3.0t1;1166 APPROVALS FOR PAYMENT;**19**;AUG 31, 2005
  1.  ;Original JDM
  1.  ;Part 2 - Gen. Treasury ECS/ACH-format file from Unix Treasury Tape-format file.
  1. FRD ;EP
  1.  ;****** Open & rd tape file & send to ascii formatted file ******
  1.  ;
  1.  ;Var AFSLFY is being stuffed into a field that is being changed from
  1.  ;a 2 digit to a 4 digit FY.  The var is not being manipulated in this
  1.  ;routine so no change required here.
  1.  ;
  1.  S (AFSLRCT,AFSLSAMT)=0
  1.  S AFSLZROS="000000000000"
  1.  S AFSLSPAC="                                   "
  1.  F I=1:1:10 S AFSLASY(I)="                ",AFSLSAM(I)="000000000000"
  1. OPENFLS S %FN=AFSEXFN
  1.  S %IN=1
  1.  S (AFSLBFL1,AFSLBFL2,AFSLBFL3,AFSLBFL4,AFSLBFL5,AFSLGFLG)=0
  1.  S (AFSLXA,AFSLXC,AFSLXX,AFSLTMXX)=""
  1.  D OPENHFS^AFSLCK1
  1.  I $D(AFSERMSG) D ERROR^AFSLCK1 G FINI
  1.  I $D(AFSJFLG) G FINI
  1.  S AFSLTDEV=%DEV K %DEV
  1. READTFL ;rd tp fle
  1.  U AFSLTDEV R X:DTIME I X=""!($A(X)=-1)!($E(X,1,3))="C01" G FINI
  1. ITEM ;process pmt data
  1.  I $E(X,1,3)="C01" G FINI
  1.  I $E(X,1,3)="&01" D  G:$D(AFSJFLG) FINI G:$D(AFSLMFLG) FINI G READTFL
  1.  .S AFSLSCHD=$E(X,4,13)
  1.  .S AFSLALC=$E(X,27,34)
  1.  .S AFSLAID=$P(^AFSLPRM(1,2),U,8)
  1.  .S AFSLRECN="000000"
  1.  .S AFSLRFC=$P(^AFSLPRM(1,2),U,3)
  1.  .D ALCC
  1.  I $E(X,1,3)="A01"&($E(X,4,13)=AFSLSCHD) D  G READTFL
  1.  .S AFSLANAM=$E(X,72,80)
  1.  I $E(X,1,3)="A01"&($E(X,4,13)'=AFSLSCHD) D  G READTFL
  1.  .S AFSLANAM=AFSLANAM_$E(X,4,19)
  1.  .S AFSLADR1=$E(X,20,44)
  1.  .S AFSLADR2=$E(X,45,69)
  1.  .D BLCC
  1.  I $E(X,1,3)="B01"&($E(X,47)="B") D  G READTFL
  1.  .S AFSLRCT=AFSLRCT+1
  1.  .S AFSLENCD=$E(X,14)
  1.  .S AFSLTSSN=$E(X,15,23)
  1.  .S AFSLTAMT=$E(X,27,36)
  1.  .S AFSLSAMT=AFSLSAMT+AFSLTAMT
  1.  .S AFSLTNAM=$E(X,48,80)
  1.  .S AFSLBFL1=1
  1.  I $E(X,1,3)="B01"&(AFSLBFL1=1) D  G READTFL
  1.  .S AFSLBFL1=0
  1.  .S AFSLADD1=$E(X,4,38)
  1.  .S AFSLBFL2=1
  1.  I $E(X,1,3)="B01"&(AFSLBFL2=1) D  G READTFL
  1.  .S AFSLBFL2=0
  1.  .S AFSLADD2=$E(X,4,38)
  1.  .S AFSLADD3=$E(X,39,68)
  1.  .S AFSLBFL3=1
  1.  I $E(X,1,3)="B01"&(AFSLBFL3=1) D  G READTFL
  1.  .S AFSLBFL3=0
  1.  .S AFSLADD4=$E(X,4,33)
  1.  .S AFSLPTYP="A"
  1.  .S AFSLACSY=$E(X,34,49)
  1.  .S AFSLBFL4=1
  1.  I $E(X,1,3)="B01"&(AFSLBFL4=1) D  G READTFL
  1.  .S AFSLBFL4=0
  1.  .S AFSLPCNT=$E(X,5,6)
  1.  .S AFSLBFL5=1
  1.  .K AFSLPREC
  1.  .D READLP
  1.  G READTFL
  1.  Q
  1. READLP ;rd 1-14 pd-for rcds & create AFSLPREC(1-14)
  1.  F J=1:1:AFSLPCNT D
  1.  .U AFSLTDEV R X:DTIME
  1.  .U AFSLSDEV G:X=""!($A(X)=-1)!(AFSLGFLG=1) FINI D:AFSLXFLG'=1 SETPREC
  1.  D PMTREC
  1.  Q
  1. SETPREC ;set AFSLPREC(J)
  1.  S AFSLPREC(J)=$E(X,4,58)
  1.  Q
  1. ALCC ;********Create Transmission Hdr Rcd & ALC Ctl rcd*********
  1.  D SHDR^AFSLACH2 Q:$D(AFSLMFLG)
  1.  S AFSLAID=AFSLAID_$E("          ",1,10-$L(AFSLAID))
  1.  I AFSLXFLG=3 S AFSLPNOT="P"
  1.  I '$D(AFSLPNOT) S AFSLPNOT=" "
  1.  S AFSLPNOT=" "
  1.  S AFSLALCC="02"_"000001"_AFSLSCHD_"    "_"             "_AFSLALC_"           "_"&"_AFSLPNOT_$E(AFSLB50,2,50)_AFSLB50_AFSLB50_AFSLB50_AFSLB50_AFSLB50_AFSLB50_$E(AFSLB50,1,35)
  1.  D WRTALCC
  1.  Q
  1. BLCC ;******** Create Agcy Billing Addr Ctl Rcd ********
  1.  S AFSLBLCC="03"_"000002"_AFSLSCHD_"    "_"0000000000000"_"                   "_"A"_AFSLANAM_AFSLADR1_AFSLADR2_$E(AFSLB50,1,25)_"          "_AFSLB50_AFSLB50_AFSLB50_AFSLB50_AFSLB50_$E(AFSLB50,1,25)
  1.  U AFSLKDEV W AFSLBLCC
  1.  U AFSLKDEV
  1.  Q
  1. PMTREC ;***************** Create pmt rcd *****************
  1.  ;AFSLENCD=Enclosure Code (2) or Acct. Type (C=Ckg, S=Svgs)..GET FROM 1166 AFP ACH-PERSON file
  1.  S AFSLTNAM=AFSLTNAM_$E($$SPACE^AFSLUTLM(35),1,35-$L(AFSLTNAM)),AFSLRECN=$E($$ZERO^AFSLUTLM(6),1,6-$L(AFSLRCT))_AFSLRCT
  1.  S AFSLTAMT=$E($$ZERO^AFSLUTLM(10),1,10-$L(AFSLTAMT))_AFSLTAMT
  1.  S AFSLAID=AFSLAID_$E(AFSLB50,1,10-$L(AFSLAID))
  1. ASKSSN ;
  1.  S AFSLSKED=$E(AFSLSCHD,5,10) D ^AFSLSKLU
  1.  S AFSLNXPN=0
  1. SKLOOP ;
  1.  I '$O(^AFSLAFP(AFSLYNOD,1,AFSLSFND,1,AFSLNXPN)) G SKEND
  1.  S AFSLNXPN=$O(^AFSLAFP(AFSLYNOD,1,AFSLSFND,1,AFSLNXPN))
  1.  S AFSLPNDX=$P(^AFSLAFP(AFSLYNOD,1,AFSLSFND,1,AFSLNXPN,0),U,24) ;THL
  1.  S AFSLPSSN=$P(^AFSLAFP(AFSLYNOD,1,AFSLSFND,1,AFSLNXPN,1),U,22)
  1.  S AFSLPAMT=$P(^AFSLAFP(AFSLYNOD,1,AFSLSFND,1,AFSLNXPN,0),U,11)
  1.  S AFSLPAMT=$P(AFSLPAMT,".",1)_$P(AFSLPAMT,".",2),AFSLPAMT=$E("00000000",1,8-$L(AFSLPAMT))_AFSLPAMT
  1.  I AFSLTSSN=AFSLPSSN&(AFSLPAMT=AFSLTAMT) S AFSLAPPN=$P(^AFSLAFP(AFSLYNOD,1,AFSLSFND,1,AFSLNXPN,1),U,21) G SKEND
  1.  G SKLOOP
  1. SKEND ;
  1.  S AFSLAPPN=AFSLACSY
  1. SKPSK ;
  1.  I AFSLTSSN="" K DIR S DIR(0)="F^9:9",DIR("A")="Enter Person SSN (i.e., 123456789)" U AFSLSDEV D ^DIR I X'?9N W !,"FOLLOW EXAMPLES GIVEN!",*7,! G ASKSSN
  1.  S AFSLPID=AFSLTSSN
  1.  S AFSLVND=AFSLPID U 0 S AFSLTMPL=1 D ^AFSLEMLU K AFSLTMPL
  1.  I AFSLPFND'="XX" S AFSLPNDX=AFSLPNOD
  1.  I '$D(^ACRAU(AFSLPNDX,19)) S AFSLIDN="" D ASKACH
  1.  I $D(AFSLQFLG) S AFSLRFLG=1 K AFSLQFLG Q
  1.  S AFSLIDN=AFSLPNDX
  1.  S AFSLENCD=$P(^ACRAU(AFSLIDN,19),U,1),AFSLRTN=$P(^ACRAU(AFSLIDN,19),U,2),AFSLDAN=$P(^ACRAU(AFSLIDN,19),U,3)
  1.  S AFSLRTN=AFSLRTN_$E("000000000",1,9-$L(AFSLRTN))
  1.  S AFSLDAN=AFSLDAN_$E("                 ",1,17-$L(AFSLDAN))
  1.  S AFSLTSSN=AFSLTSSN_$E(AFSLB50,1,16-$L(AFSLTSSN))
  1.  S AFSLPYID=$E(AFSLTSSN,1,9)
  1.  S AFSLPYNM=$E(AFSLTNAM,1,22)
  1.  D GETPIDL
  1.  I '$D(AFSLPIDL) S AFSLPIDL=""
  1.  S AFSLPIDL=AFSLPIDL_$E(AFSLB80,1,80-$L(AFSLPIDL))
  1. WRTPMT ;
  1.  S AFSLALCP="04"_AFSLRECN_AFSLSCHD_"    "_AFSLENCD_AFSLPYID_"   "_"00000000000"
  1.  S AFSLAPPN=AFSLAPPN_$E("                ",1,16-$L(AFSLAPPN))
  1.  S AFSLALCP=AFSLALCP_AFSLTAMT_"B"_AFSLPYNM_"       "_AFSLRTN_AFSLDAN_AFSLB50_AFSLB50_"    "_" "_AFSLAPPN_AFSLB50_AFSLPIDL
  1.  S AFSLPCNT=$E("00",1,2-$L(AFSLPCNT))_AFSLPCNT
  1.  S AFSLSYMT=AFSLSYMT+AFSLTAMT
  1.  I '$D(AFSLTOT(AFSLAPPN)) S AFSLTOT(AFSLAPPN)=0
  1.  S AFSLTOT(AFSLAPPN)=AFSLTOT(AFSLAPPN)+AFSLTAMT
  1.  S AFSLASY(1)=AFSLAPPN,AFSLSAM(1)=$E("000000000000",1,12-$L(AFSLSYMT))_AFSLSYMT
  1.  U AFSLKDEV W AFSLALCP
  1. PIDLINE ;
  1.  U AFSLKDEV W AFSLB50_$E(AFSLB50,1,27)
  1.  Q
  1. WRTALCC ;write alc ctl rcd
  1.  S %FN="/usr/spool/afsdata/"_AFSLNXDK_"-"_AFSLMMDD,%IN=0
  1.  I '$D(^AFSLPRM(1,3)) G SKPPRM
  1.  I $P(^AFSLPRM(1,3),U,1)'="" S %FN=$P(^AFSLPRM(1,3),U,1)_"/"_AFSLNXDK_"-"_AFSLMMDD
  1. SKPPRM ;
  1.  D OPENHFS^AFSLCK1
  1.  I $D(AFSERMSG) U AFSLSDEV W !,AFSERMSG
  1.  I Y>0 U AFSLSDEV W !,"UNABLE TO OPEN DISKETTE FILE FOR WRITE!"
  1.  I Y=1 U AFSLSDEV W !,"No HFS Device available...",! R !,"PRESS <RETURN>",AFSLRTNX:300
  1.  I Y=2 U AFSLSDEV W !,"Trying to open a new file for read (R) mode...",!
  1.  I Y=3 U AFSLSDEV W !,"Passed fls by ref...",!
  1.  I Y=4 U AFSLSDEV W !,"Invalid fi length...",!
  1.  I Y>0 S AFSJFLG=1 Q
  1.  S AFSLKDEV=%DEV K %DEV
  1.  U AFSLKDEV W AFSLSHDR,AFSLALCC
  1.  U AFSLSDEV
  1.  Q
  1. WRTPRX ;
  1.  U AFSLKDEV W AFSLRCTY_AFSLRECN_AFSLSCHD_"    "
  1.  Q
  1. WRTSCR ;write alc schd ctl rcd
  1.  S %H=$H
  1.  D YX^%DTC
  1.  S AFSLNOW=X_$E(%,1,5)
  1.  S AFSLMMDD=$E(X,4,7)
  1.  S AFSLSICT=$E($$ZERO^AFSLUTLM(7),1,7-$L(AFSLRCT))_AFSLRCT
  1.  S AFSLSAMT=$E($$ZERO^AFSLUTLM(12),1,12-$L(AFSLSAMT))_AFSLSAMT
  1.  S AFSLRECN=AFSLRECN+1
  1.  S AFSLRECN=$E($$ZERO^AFSLUTLM(6),1,6-$L(AFSLRECN))_AFSLRECN
  1.  S AFSLSCR="09"_AFSLRECN_AFSLSCHD_"    "_"9999999999999"_AFSLSICT_AFSLSAMT_"C"
  1.  S AFSLNXAN="",AFSLACT=0
  1.  I '$D(AFSLTOT(AFSLENCD)) S AFSLTOT(AFSLENCD)=0
  1. NXAPN ;
  1.  I AFSLACT=10 G QNXAPN
  1.  I '$O(AFSLTOT(AFSLNXAN)) D  G NXAPN
  1.  .S AFSLSCR=AFSLSCR_"                000000000000"
  1.  .S AFSLACT=AFSLACT+1
  1.  S AFSLNXAN=$O(AFSLTOT(AFSLNXAN))
  1.  I AFSLTOT(AFSLNXAN)="" S AFSLTOT(AFSLNXAN)=0
  1.  S AFSLTOT(AFSLNXAN)=$E("000000000000",1,12-$L(AFSLTOT(AFSLNXAN)))_AFSLTOT(AFSLNXAN)
  1.  S AFSLSCR=AFSLSCR_AFSLNXAN_AFSLTOT(AFSLNXAN)
  1.  S AFSLACT=AFSLACT+1
  1.  G NXAPN
  1. QNXAPN ;
  1.  U AFSLKDEV W AFSLSCR
  1.  F M=1:1:105 U AFSLKDEV W " "
  1.  S AFSLNXTD=AFSLNXDK_"-"_AFSLMMDD
  1.  S X=AFSLNOW
  1.  S DIC="^AFSLDKGL("
  1.  S DIC(0)="ML"
  1.  U AFSLSDEV
  1.  D ^DIC
  1.  S DIE="^AFSLDKGL(",DA=$P(Y,U,1)
  1.  S DR="1///^S X=AFSLFY" D ^DIE     ;This field being changed to 4 digits
  1.  S DR="2///^S X=AFSLSCHD" D ^DIE
  1.  S DR="3///^S X=AFSLEXFN" D ^DIE
  1.  S DR="4///^S X=AFSLNXTD" D ^DIE
  1.  S DR="5///^S X=AFSLRCT" D ^DIE
  1.  S DR="6///^S X=AFSLSAMT" D ^DIE
  1.  Q
  1. FINI ;
  1.  I $E(X,1,3)="C01"&('$D(AFSJFLG)) D WRTSCR,WRTSTRL^AFSLACH2
  1.  I '$D(AFSLTDEV) G FINI2
  1.  S IO=AFSLTDEV D ^%ZISC
  1. FINI2 ;
  1.  I '$D(AFSLKDEV) G FINI3
  1.  S IO=AFSLKDEV D ^%ZISC
  1. FINI3 ;
  1.  I $D(%DEV) S IO=%DEV D ^%ZISC
  1.  Q
  1.  W AFSLSYMT
  1.  W AFSLSYMT
  1. ASKACH ;
  1.  I '$O(^VA(200,"SSN",AFSLTSSN,0)) D  Q
  1.  .U AFSLSDEV W !,"Can't find person: ",AFSLTNAM," in PERSON File anymore,",!,"or SSN/INFO been changed or person has been deleted!",!,"SKIPPING PAYMENT. "
  1.  .S AFSLQFLG=1
  1.  S AFSLNXVX=0
  1.  S AFSLVCT=0
  1. NXVNLP ;
  1.  I '$O(^VA(200,"SSN",AFSLTSSN,AFSLNXVX)) G EXITLP
  1.  S AFSLNXVX=$O(^VA(200,"SSN",AFSLTSSN,AFSLNXVX))
  1.  S AFSLVCT=AFSLVCT+1
  1.  G NXVNLP
  1. EXITLP ; 
  1.  I AFSLVCT>1 G SSNDUPS
  1.  S AFSLTNOD=$O(^VA(200,"SSN",AFSLTSSN,0))
  1.  ;S X=$P(^VA(200,AFSLTNOD,0),U,1)  ;ACR*2.1*19.02 IM16848
  1.  S X=$$NAME2^ACRFUTL1(AFSLTNOD)  ;ACR*2.1*19.02 IM16848
  1.  U AFSLSDEV W !,"Person: ",$E(AFSLTNAM,1,22)," doesn't yet have needed ACH information.",!,"PLEASE ENTER ALL REQUESTED INFO NOW...",!!
  1.  H 5
  1.  Q
  1. SSNDUPS ;
  1.  U AFSLSDEV W !!,"NAME: ",AFSLTNAM,!,"SSN: ",AFSLTSSN,!
  1.  W !,"There is more than one person in PERSON file with this person's SSN."
  1.  W !,"So, I need you to select the one to get information from.",!!
  1.  S X=$E(AFSLTSSN,1,10)
  1.  S DIC="^VA(200,"
  1.  S DIC(0)="QM"
  1.  D ^DIC
  1.  R !,"PRESS RETURN",AFSLRTNX:300
  1.  Q
  1. GETPIDX ;GET CORRECT ADDENDUM (PAYMENT IDENT INFO) FM PAYMENT
  1.  ;
  1. GETPIDL ;GET CORRECT ADDENDUM (PAYMENT IDENT INFO) FM PAYMENT
  1.  S AFSLPIDX=AFSLPREC(1)
  1.  I $E(AFSLPIDX,4)'="*" D FINDAST
  1.  S AFSLPIDL=$E(AFSLPIDX,1,80)
  1.  S AFSLPIDL=AFSLPIDL_$E(AFSLB80,1,80-$L(AFSLPIDL))
  1.  Q
  1. FINDAST ;
  1.  F K=1:1:79 I $E(AFSLPIDX,K)="*" S AFSLASTX=K Q
  1.  I AFSLASTX=80 Q
  1.  I AFSLASTX'>4 Q
  1.  S AFSLASTZ=AFSLASTX-3
  1.  S AFSLPIDX=$E(AFSLPIDX,AFSLASTZ,80)
  1.  Q