AFSLDKG2 ;IHS/OIRM/DSD/JDM,HJT - WRITE TO ECS-CHECKS FORMAT FILE; [ 10/27/2004 4:21 PM ]
;;3.0t1;1166 APPROVALS FOR PAYMENT;**13**;FEB 07, 1997
;ACR*2.1*13.02 IM13574
;Verified for Y2K Compliance 1/11/1999HJT
; 2-digit or 1-digit dates in this rout cannot be changed - output is
; directed to a fixed format file dictated to the Treasury Dept.
; 1/11/1999HJT
;Part 2 - Gen. Treasury ECS-format file from Unix Tape-format file.
;ACR*2.1*13.02 IM13574 ;REMOVED DUPLICATE SUBROUTINES
FRD ;EP-open & rd tape file & send to ascii formatted file
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,AFSLXFLG)=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 ; READ FILE ;ACR*2.1*13.02 IM13574
D ^AFSLCKZC ;ACR*2.1*13.02 IM13574
I X=""!($A(X)=-1)!($E(X,1,3))="C01" G FINI ;ACR*2.1*13.02 IM13574
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
B01 ;EVALUATE 'B01' RECORDS AND SET VARIABLES ACCORDING TO WHETHER THE
;FIRST THROUGH FIFTH RECORD IS BEING READ
;Removed redundant subroutine & commented-out code;ACR*2.1*13.02 IM13574
I $E(X,1,3)="B01",'$G(AFSLBFL1) D
.S AFSLRCT=AFSLRCT+1
.S AFSLENCD=$E(X,14)
.S AFSLVEIN=$E(X,15,26)
.S AFSLTAMT=$E(X,27,36)
.S AFSLSAMT=AFSLSAMT+AFSLTAMT
.S AFSLVNAM=$E(X,48,80)
.S AFSLBFL1=1
I $E(X,1,3)="B01",AFSLBFL1=1 D
.S AFSLADD1=$E(X,4,38)
.S AFSLBFL1=2
I $E(X,1,3)="B01",AFSLBFL1=2 D
.S AFSLADD2=$E(X,4,38)
.S AFSLADD3=$E(X,39,68)
.S AFSLBFL1=3
I $E(X,1,3)="B01",AFSLBFL1=3 D
.S AFSLADD4=$E(X,4,33)
.S AFSLPTYP="A"
.S AFSLACSY=$E(X,34,49)
.S AFSLBFL1=4
I $E(X,1,3)="B01",AFSLBFL1=4 D
.S AFSLPCNT=$E(X,5,6)
.S AFSLBFL1=0
.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 D ^AFSLCKZC
.U IO(0) 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 ALC ctl rcd
D SHDR^AFSLDKG3
Q:$D(AFSLMFLG)
S AFSLAID=AFSLAID_$E(" ",1,10-$L(AFSLAID))
S AFSLALCC="02"_"000001"_AFSLSCHD_" "_" "_AFSLALC_" "_"&"_AFSLB50_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
S AFSLPYID=$E(AFSLVEIN,2,10)
S AFSLPYID=AFSLPYID_$E(" ",1,16-$L(AFSLPYID))
S AFSLVNAM=AFSLVNAM_$E($$SPACE^AFSLUTLM(35),1,35-$L(AFSLVNAM))
S 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))
S AFSLVEIN=AFSLVEIN_$E(AFSLB50,1,16-$L(AFSLVEIN))
WRTPMT ;
S AFSLALCP="04"_AFSLRECN_AFSLSCHD_" "_AFSLENCD_" "_"0"_AFSLTAMT_AFSLAID_"B"_AFSLVNAM_AFSLADD1_AFSLADD2_AFSLADD3_AFSLADD4_AFSLPTYP_AFSLACSY_AFSLPYID_$E(AFSLB50,1,33)
S AFSLAPPN=AFSLACSY
S AFSLPCNT=$E("00",1,2-$L(AFSLPCNT))_AFSLPCNT
S AFSLALCP=AFSLALCP_AFSLPCNT
S AFSLSYMT=AFSLSYMT+AFSLTAMT
I '$D(AFSLTOT(AFSLAPPN)) S AFSLTOT(AFSLAPPN)=0
S AFSLTOT(AFSLAPPN)=AFSLTOT(AFSLAPPN)+AFSLTAMT
S AFSLASY(1)=AFSLAPPN
S AFSLSAM(1)=$E("000000000000",1,12-$L(AFSLSYMT))_AFSLSYMT
U AFSLKDEV W AFSLALCP
PIDLINE ;
F L=1:1:14 D WRTPLINS
U AFSLKDEV W AFSLB50_$E(AFSLB50,1,38)
Q
WRTALCC ;write alc ctl rcd
S %FN=$$ARMSDIR^ACRFSYS(1) ;ACR*2.1*13.06 IM14144
S %FN=%FN_AFSLNXDK_"-"_AFSLMMDD,%IN=0 ;ACR*2.1*13.06 IM14144
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...",! D PAUSE^ACRFWARN ; ACR*2.1*13.06 IM14144
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 IO(0)
Q
WRTPLINS ;write pmt lns 1-14
I L=3 S AFSLRCTY="05" D WRTPRX
I L=9 S AFSLRCTY="06" D WRTPRX
I '$D(AFSLPREC(L)) S AFSLPREC(L)=AFSLB50_" "
U AFSLKDEV W AFSLPREC(L)
I L=2 U AFSLKDEV W $E(AFSLB50,1,45)
I L=8 U AFSLKDEV W AFSLB50_$E(AFSLB50,1,38)
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,AFSLRECN=$E($$ZERO^AFSLUTLM(6),1,6-$L(AFSLRECN))_AFSLRECN
S AFSLSCR="09"_AFSLRECN_AFSLSCHD_" "_"9999999999999"_AFSLSICT_AFSLSAMT_"C"
S AFSLNXAN="",AFSLACT=0
NXAPN ;
I AFSLACT=10 G QNXAPN
I '$O(AFSLTOT(AFSLNXAN)) S AFSLSCR=AFSLSCR_" 000000000000",AFSLACT=AFSLACT+1 G NXAPN
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),AFSLACT=AFSLACT+1
G NXAPN
QNXAPN ;
S E=10-AFSLACT
F M=1:1:E S AFSLSCR=AFSLSCR_AFSLASY(2)_AFSLSAM(2)
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
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^AFSLDKG3
I '$D(AFSLTDEV) G FINI2
D CLOSE^%ZISH("") ; ACR*2.1*13.06 IM14144
FINI2 ;
I '$D(AFSLKDEV) G FINI3
D CLOSE^%ZISH("") ; ACR*2.1*13.06 IM14144
FINI3 ;
Q
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
+2 ;ACR*2.1*13.02 IM13574
+3 ;Verified for Y2K Compliance 1/11/1999HJT
+4 ; 2-digit or 1-digit dates in this rout cannot be changed - output is
+5 ; directed to a fixed format file dictated to the Treasury Dept.
+6 ; 1/11/1999HJT
+7 ;Part 2 - Gen. Treasury ECS-format file from Unix Tape-format file.
+8 ;ACR*2.1*13.02 IM13574 ;REMOVED DUPLICATE SUBROUTINES
FRD ;EP-open & rd tape file & send to ascii formatted file
+1 SET (AFSLRCT,AFSLSAMT)=0
+2 SET AFSLZROS="000000000000"
+3 SET AFSLSPAC=" "
+4 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,AFSLXFLG)=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
+8 KILL %DEV
READTFL ;rd tp fle
+1 ; READ FILE ;ACR*2.1*13.02 IM13574
USE AFSLTDEV
READ X:DTIME
+2 ;ACR*2.1*13.02 IM13574
DO ^AFSLCKZC
+3 ;ACR*2.1*13.02 IM13574
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"
IF $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"
IF $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
B01 ;EVALUATE 'B01' RECORDS AND SET VARIABLES ACCORDING TO WHETHER THE
+1 ;FIRST THROUGH FIFTH RECORD IS BEING READ
+2 ;Removed redundant subroutine & commented-out code;ACR*2.1*13.02 IM13574
+3 IF $EXTRACT(X,1,3)="B01"
IF '$GET(AFSLBFL1)
Begin DoDot:1
+4 SET AFSLRCT=AFSLRCT+1
+5 SET AFSLENCD=$EXTRACT(X,14)
+6 SET AFSLVEIN=$EXTRACT(X,15,26)
+7 SET AFSLTAMT=$EXTRACT(X,27,36)
+8 SET AFSLSAMT=AFSLSAMT+AFSLTAMT
+9 SET AFSLVNAM=$EXTRACT(X,48,80)
+10 SET AFSLBFL1=1
End DoDot:1
+11 IF $EXTRACT(X,1,3)="B01"
IF AFSLBFL1=1
Begin DoDot:1
+12 SET AFSLADD1=$EXTRACT(X,4,38)
+13 SET AFSLBFL1=2
End DoDot:1
+14 IF $EXTRACT(X,1,3)="B01"
IF AFSLBFL1=2
Begin DoDot:1
+15 SET AFSLADD2=$EXTRACT(X,4,38)
+16 SET AFSLADD3=$EXTRACT(X,39,68)
+17 SET AFSLBFL1=3
End DoDot:1
+18 IF $EXTRACT(X,1,3)="B01"
IF AFSLBFL1=3
Begin DoDot:1
+19 SET AFSLADD4=$EXTRACT(X,4,33)
+20 SET AFSLPTYP="A"
+21 SET AFSLACSY=$EXTRACT(X,34,49)
+22 SET AFSLBFL1=4
End DoDot:1
+23 IF $EXTRACT(X,1,3)="B01"
IF AFSLBFL1=4
Begin DoDot:1
+24 SET AFSLPCNT=$EXTRACT(X,5,6)
+25 SET AFSLBFL1=0
+26 KILL AFSLPREC
+27 DO READLP
End DoDot:1
+28 GOTO READTFL
+29 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
DO ^AFSLCKZC
+3 USE IO(0)
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 ALC ctl rcd
+1 DO SHDR^AFSLDKG3
+2 IF $DATA(AFSLMFLG)
QUIT
+3 SET AFSLAID=AFSLAID_$EXTRACT(" ",1,10-$LENGTH(AFSLAID))
+4 SET AFSLALCC="02"_"000001"_AFSLSCHD_" "_" "_AFSLALC_" "_"&"_AFSLB50_AFSLB50_AFSLB50_AFSLB50_AFSLB50_AFSLB50_AFSLB50_$EXTRACT(AFSLB50,1,35)
+5 DO WRTALCC
+6 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 SET AFSLPYID=$EXTRACT(AFSLVEIN,2,10)
+2 SET AFSLPYID=AFSLPYID_$EXTRACT(" ",1,16-$LENGTH(AFSLPYID))
+3 SET AFSLVNAM=AFSLVNAM_$EXTRACT($$SPACE^AFSLUTLM(35),1,35-$LENGTH(AFSLVNAM))
+4 SET AFSLRECN=$EXTRACT($$ZERO^AFSLUTLM(6),1,6-$LENGTH(AFSLRCT))_AFSLRCT
+5 SET AFSLTAMT=$EXTRACT($$ZERO^AFSLUTLM(10),1,10-$LENGTH(AFSLTAMT))_AFSLTAMT
+6 SET AFSLAID=AFSLAID_$EXTRACT(AFSLB50,1,10-$LENGTH(AFSLAID))
+7 SET AFSLVEIN=AFSLVEIN_$EXTRACT(AFSLB50,1,16-$LENGTH(AFSLVEIN))
WRTPMT ;
+1 SET AFSLALCP="04"_AFSLRECN_AFSLSCHD_" "_AFSLENCD_" "_"0"_AFSLTAMT_AFSLAID_"B"_AFSLVNAM_AFSLADD1_AFSLADD2_AFSLADD3_AFSLADD4_AFSLPTYP_AFSLACSY_AFSLPYID_$EXTRACT(AFSLB50,1,33)
+2 SET AFSLAPPN=AFSLACSY
+3 SET AFSLPCNT=$EXTRACT("00",1,2-$LENGTH(AFSLPCNT))_AFSLPCNT
+4 SET AFSLALCP=AFSLALCP_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
+9 SET AFSLSAM(1)=$EXTRACT("000000000000",1,12-$LENGTH(AFSLSYMT))_AFSLSYMT
+10 USE AFSLKDEV
WRITE AFSLALCP
PIDLINE ;
+1 FOR L=1:1:14
DO WRTPLINS
+2 USE AFSLKDEV
WRITE AFSLB50_$EXTRACT(AFSLB50,1,38)
+3 QUIT
WRTALCC ;write alc ctl rcd
+1 ;ACR*2.1*13.06 IM14144
SET %FN=$$ARMSDIR^ACRFSYS(1)
+2 ;ACR*2.1*13.06 IM14144
SET %FN=%FN_AFSLNXDK_"-"_AFSLMMDD
SET %IN=0
+3 IF '$DATA(^AFSLPRM(1,3))
GOTO SKPPRM
+4 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 ; ACR*2.1*13.06 IM14144
IF Y=1
USE AFSLSDEV
WRITE !,"No HFS Device available...",!
DO PAUSE^ACRFWARN
+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 IO(0)
+12 QUIT
WRTPLINS ;write pmt lns 1-14
+1 IF L=3
SET AFSLRCTY="05"
DO WRTPRX
+2 IF L=9
SET AFSLRCTY="06"
DO WRTPRX
+3 IF '$DATA(AFSLPREC(L))
SET AFSLPREC(L)=AFSLB50_" "
+4 USE AFSLKDEV
WRITE AFSLPREC(L)
+5 IF L=2
USE AFSLKDEV
WRITE $EXTRACT(AFSLB50,1,45)
+6 IF L=8
USE AFSLKDEV
WRITE AFSLB50_$EXTRACT(AFSLB50,1,38)
+7 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
SET AFSLRECN=$EXTRACT($$ZERO^AFSLUTLM(6),1,6-$LENGTH(AFSLRECN))_AFSLRECN
+8 SET AFSLSCR="09"_AFSLRECN_AFSLSCHD_" "_"9999999999999"_AFSLSICT_AFSLSAMT_"C"
+9 SET AFSLNXAN=""
SET AFSLACT=0
NXAPN ;
+1 IF AFSLACT=10
GOTO QNXAPN
+2 IF '$ORDER(AFSLTOT(AFSLNXAN))
SET AFSLSCR=AFSLSCR_" 000000000000"
SET AFSLACT=AFSLACT+1
GOTO NXAPN
+3 SET AFSLNXAN=$ORDER(AFSLTOT(AFSLNXAN))
+4 IF AFSLTOT(AFSLNXAN)=""
SET AFSLTOT(AFSLNXAN)=0
+5 SET AFSLTOT(AFSLNXAN)=$EXTRACT("000000000000",1,12-$LENGTH(AFSLTOT(AFSLNXAN)))_AFSLTOT(AFSLNXAN)
+6 SET AFSLSCR=AFSLSCR_AFSLNXAN_AFSLTOT(AFSLNXAN)
SET AFSLACT=AFSLACT+1
+7 GOTO NXAPN
QNXAPN ;
+1 SET E=10-AFSLACT
+2 FOR M=1:1:E
SET AFSLSCR=AFSLSCR_AFSLASY(2)_AFSLSAM(2)
+3 USE AFSLKDEV
WRITE AFSLSCR
+4 FOR M=1:1:105
USE AFSLKDEV
WRITE " "
+5 SET AFSLNXTD=AFSLNXDK_"-"_AFSLMMDD
+6 SET X=AFSLNOW
+7 SET DIC="^AFSLDKGL("
+8 SET DIC(0)="ML"
+9 USE AFSLSDEV
+10 DO ^DIC
+11 SET DIE="^AFSLDKGL("
SET DA=$PIECE(Y,U,1)
+12 SET DR="1///^S X=AFSLFY"
DO ^DIE
+13 SET DR="2///^S X=AFSLSCHD"
DO ^DIE
+14 SET DR="3///^S X=AFSLEXFN"
DO ^DIE
+15 SET DR="4///^S X=AFSLNXTD"
DO ^DIE
+16 SET DR="5///^S X=AFSLRCT"
DO ^DIE
+17 SET DR="6///^S X=AFSLSAMT"
DO ^DIE
+18 QUIT
FINI ;
+1 IF $EXTRACT(X,1,3)="C01"
IF '$DATA(AFSJFLG)
DO WRTSCR
DO WRTSTRL^AFSLDKG3
+2 IF '$DATA(AFSLTDEV)
GOTO FINI2
+3 ; ACR*2.1*13.06 IM14144
DO CLOSE^%ZISH("")
FINI2 ;
+1 IF '$DATA(AFSLKDEV)
GOTO FINI3
+2 ; ACR*2.1*13.06 IM14144
DO CLOSE^%ZISH("")
FINI3 ;
+1 QUIT
