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