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

AFSLDKG2.m

Go to the documentation of this file. 
  1. AFSLDKG2 ;IHS/OIRM/DSD/JDM,HJT - WRITE TO ECS-CHECKS FORMAT FILE;  [ 10/27/2004   4:21 PM ]
  1.  ;;3.0t1;1166 APPROVALS FOR PAYMENT;**13**;FEB 07, 1997
  1.  ;ACR*2.1*13.02 IM13574
  1.  ;Verified for Y2K Compliance   1/11/1999HJT
  1.  ;  2-digit or 1-digit dates in this rout cannot be changed - output is
  1.  ;  directed to a fixed format file dictated to the Treasury Dept.
  1.  ;  1/11/1999HJT
  1.  ;Part 2 - Gen. Treasury ECS-format file from Unix Tape-format file.
  1.  ;ACR*2.1*13.02 IM13574    ;REMOVED DUPLICATE SUBROUTINES
  1. FRD ;EP-open & rd tape file & send to ascii formatted file
  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,AFSLXFLG)=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
  1.  K %DEV
  1. READTFL ;rd tp fle
  1.  U AFSLTDEV R X:DTIME    ; READ FILE         ;ACR*2.1*13.02 IM13574
  1.  D ^AFSLCKZC                                 ;ACR*2.1*13.02 IM13574
  1.  I X=""!($A(X)=-1)!($E(X,1,3))="C01" G FINI  ;ACR*2.1*13.02 IM13574
  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. B01 ;EVALUATE 'B01' RECORDS AND SET VARIABLES ACCORDING TO WHETHER THE
  1.  ;FIRST THROUGH FIFTH RECORD IS BEING READ
  1.  ;Removed redundant subroutine & commented-out code;ACR*2.1*13.02 IM13574
  1.  I $E(X,1,3)="B01",'$G(AFSLBFL1) D
  1.  .S AFSLRCT=AFSLRCT+1
  1.  .S AFSLENCD=$E(X,14)
  1.  .S AFSLVEIN=$E(X,15,26)
  1.  .S AFSLTAMT=$E(X,27,36)
  1.  .S AFSLSAMT=AFSLSAMT+AFSLTAMT
  1.  .S AFSLVNAM=$E(X,48,80)
  1.  .S AFSLBFL1=1
  1.  I $E(X,1,3)="B01",AFSLBFL1=1 D
  1.  .S AFSLADD1=$E(X,4,38)
  1.  .S AFSLBFL1=2
  1.  I $E(X,1,3)="B01",AFSLBFL1=2 D
  1.  .S AFSLADD2=$E(X,4,38)
  1.  .S AFSLADD3=$E(X,39,68)
  1.  .S AFSLBFL1=3
  1.  I $E(X,1,3)="B01",AFSLBFL1=3 D
  1.  .S AFSLADD4=$E(X,4,33)
  1.  .S AFSLPTYP="A"
  1.  .S AFSLACSY=$E(X,34,49)
  1.  .S AFSLBFL1=4
  1.  I $E(X,1,3)="B01",AFSLBFL1=4 D
  1.  .S AFSLPCNT=$E(X,5,6)
  1.  .S AFSLBFL1=0
  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 D ^AFSLCKZC
  1.  .U IO(0) 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 ALC ctl rcd
  1.  D SHDR^AFSLDKG3
  1.  Q:$D(AFSLMFLG)
  1.  S AFSLAID=AFSLAID_$E("          ",1,10-$L(AFSLAID))
  1.  S AFSLALCC="02"_"000001"_AFSLSCHD_"    "_"             "_AFSLALC_"           "_"&"_AFSLB50_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.  S AFSLPYID=$E(AFSLVEIN,2,10)
  1.  S AFSLPYID=AFSLPYID_$E("                ",1,16-$L(AFSLPYID))
  1.  S AFSLVNAM=AFSLVNAM_$E($$SPACE^AFSLUTLM(35),1,35-$L(AFSLVNAM))
  1.  S 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.  S AFSLVEIN=AFSLVEIN_$E(AFSLB50,1,16-$L(AFSLVEIN))
  1. WRTPMT ;
  1.  S AFSLALCP="04"_AFSLRECN_AFSLSCHD_"    "_AFSLENCD_"       "_"0"_AFSLTAMT_AFSLAID_"B"_AFSLVNAM_AFSLADD1_AFSLADD2_AFSLADD3_AFSLADD4_AFSLPTYP_AFSLACSY_AFSLPYID_$E(AFSLB50,1,33)
  1.  S AFSLAPPN=AFSLACSY
  1.  S AFSLPCNT=$E("00",1,2-$L(AFSLPCNT))_AFSLPCNT
  1.  S AFSLALCP=AFSLALCP_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
  1.  S AFSLSAM(1)=$E("000000000000",1,12-$L(AFSLSYMT))_AFSLSYMT
  1.  U AFSLKDEV W AFSLALCP
  1. PIDLINE ;
  1.  F L=1:1:14 D WRTPLINS
  1.  U AFSLKDEV W AFSLB50_$E(AFSLB50,1,38)
  1.  Q
  1. WRTALCC ;write alc ctl rcd
  1.  S %FN=$$ARMSDIR^ACRFSYS(1)                ;ACR*2.1*13.06 IM14144
  1.  S %FN=%FN_AFSLNXDK_"-"_AFSLMMDD,%IN=0     ;ACR*2.1*13.06 IM14144
  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...",! D PAUSE^ACRFWARN ; ACR*2.1*13.06 IM14144
  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 IO(0)
  1.  Q
  1. WRTPLINS ;write pmt lns 1-14
  1.  I L=3 S AFSLRCTY="05" D WRTPRX
  1.  I L=9 S AFSLRCTY="06" D WRTPRX
  1.  I '$D(AFSLPREC(L)) S AFSLPREC(L)=AFSLB50_"     "
  1.  U AFSLKDEV W AFSLPREC(L)
  1.  I L=2 U AFSLKDEV W $E(AFSLB50,1,45)
  1.  I L=8 U AFSLKDEV W AFSLB50_$E(AFSLB50,1,38)
  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,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. NXAPN ;
  1.  I AFSLACT=10 G QNXAPN
  1.  I '$O(AFSLTOT(AFSLNXAN)) S AFSLSCR=AFSLSCR_"                000000000000",AFSLACT=AFSLACT+1 G NXAPN
  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),AFSLACT=AFSLACT+1
  1.  G NXAPN
  1. QNXAPN ;
  1.  S E=10-AFSLACT
  1.  F M=1:1:E S AFSLSCR=AFSLSCR_AFSLASY(2)_AFSLSAM(2)
  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
  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^AFSLDKG3
  1.  I '$D(AFSLTDEV) G FINI2
  1.  D CLOSE^%ZISH("")                       ; ACR*2.1*13.06 IM14144
  1. FINI2 ;
  1.  I '$D(AFSLKDEV) G FINI3
  1.  D CLOSE^%ZISH("")                       ; ACR*2.1*13.06 IM14144
  1. FINI3 ;
  1.  Q