AFSLLDO2 ;IHS/OIRM/DSD/JDM,HJT - LOAD ODF FROM DOWNLOAD FILE; [ 10/27/2004 4:21 PM ]
;;3.0t1;1166 APPROVALS FOR PAYMENT;**1,13**;JAN 31, 1999
;;ACR*2.1*9 MODIFIED FOR CACHE' COMPLIANCE
;Modified for Y2k compliance IHS/DSD/HJT 1/15/1999
;Read & check records from H.A.S. download file
FRD D ^XBCLS
W !,"READY TO IMPORT SELECTED DOWNLOAD FILE."
W !!,"Some Area Offices make obligations/payments for multiple accounting points."
W !,"I must CLEAR the local obligations database before importing the 1ST",!,"Accounting Point download file ONLY."
W !!,@AFSLRVON,"***WARNING! ANSWERING ""Y"" TO THE NEXT QUESTION WILL CLEAR THE DATABASE.",@AFSLRVOF,*7
N DIR,X,Y ; ACR*2.1*13.02 IM13574
S DIR(0)="Y^A" ; ACR*2.1*13.02 IM13574
S DIR("A")="IS THIS THE 1ST ACCOUNTING POINT (OF THIS DOWNLOAD) TO BE IMPORTED? (Y/N/^)" ; ACR*2.1*13.02 IM13574
S DIR("B")="N" ; ACR*2.1*13.02 IM13574
D DIR^ACRFDIC ; ACR*2.1*13.02 IM13574
S AFSLAPIN=$S(ACRY=1:"Y",1:"N") ; ACR*2.1*13.02 IM13574
N DIR,X,Y ; ACR*2.1*13.02 IM13574
S DIR(0)="Y^A" ; ACR*2.1*13.02 IM13574
S DIR("A")="ENTER ""Y"" AGAIN TO BEGIN (Y/N)" ; ACR*2.1*13.02 IM13574
S DIR("B")="N" ; ACR*2.1*13.02 IM13574
D DIR^ACRFDIC ; ACR*2.1*13.02 IM13574
S AFSLCONT=$S(ACRY=1:"Y",1:"N") ;AFSLCONT IS EXPECTED TO BE Y OR N
I AFSLCONT="N"!($D(ACRQUIT))!($D(ACROUT)) Q ; ACR*2.1*13.02 IM13574
D ^XBCLS
S %FN=AFSEXFN,%IN=1 S (AFSLXY,AFSLXZ)="",AFSLDUP=0,AFSLZROS="000000000000",AFSLDUPF=""
W !,"LOADING RECORDS FOR A/P ",AFSLAPN,!,"WORKING "
I AFSLAPIN'="Y"&(AFSLAPIN'="y") G SKPCLR
K ^AFSLODOC,^AFSLREJT ;EXEMPTION ************** H.A.S. DOWNLOAD GBLS
S ^AFSLODOC(0)="1166 AFP OPEN DOCUMENTS^9002325.3^0^0",^AFSLREJT(0)="1166 AFP REJECTED HAS RCDS^9002325.7^0^0"
SKPCLR ;
I '$D(X) S X="000"
S AFSLWCTR=0
D OPENHFS^AFSLCK1 ; ACR*2.1*13.02 IM13574
;S IO=%DEV ; ACR*2.1*13.02 IM13574
F AFSLI=1:1 S AFSLWCTR=AFSLWCTR+1 U IO R X:60 D ^AFSLCKZC Q:X="" Q:AFSLNZC=-1 D CHKS D:AFSLDUP=1 @(AFSLEMSG) I AFSLWCTR=1000 U IO(0) W "." S AFSLWCTR=0
U IO(0) W AFSLI K AFSLWCTR
U IO(0) W !!,"BEGINNING COMPILED RE-CROSSREFERENCING. PLEASE WAIT WHILE FILEMAN REINDEXES.",!,"BEGIN: " D NOW^%DTC,YX^%DTC W Y
S DIK="^AFSLODOC(" D IXALL^DIK
U IO(0) W !?58,"END: " D NOW^%DTC,YX^%DTC W Y
L -^AFSLODOC
;D ^%ZISC ; ACR*2.1*13.02 IM13574
D CLOSE^%ZISH("") ; ACR*2.1*13.02 IM13574
D VARKIL K %FN,%IN,AFSLXY,AFSLXZ,AFSLXZ2,%DEV
K AFSEXFN,AFSLCMD,AFSLCONT,AFSLDNOD,AFSLDNXT,AFSLDOCX,AFSLDT,AFSLDUP,AFSLDUPV,AFSLFFND,AFSLFY,AFSLI,AFSLLTDL,AFSLLTH,AFSLLTR
K AFSLOBLD,AFSLOK,AFSLSN,AFSLSNX,AFSLVAL,AFSLXC,AFSLXFND,AFSLXY2,AFSLYNOD,AFSLYNXT,AFSLZROS,AFSLRVOF,AFSLRVON,DIK,DX,DY,I,K,X,XY
Q
CHKS ;
S X=$E(X,1,132)
I $E(X,4)="J" S X=$E(X,2,132)
Q:$E(X,1,2)'=AFSLAPN
U IO(0) L +^AFSLODOC:15 I '$T S AFSLDUPF=1 W !,"FILE IN USE AT THIS TIME. TRY LATER." H 3 Q
S AFSLDUP=0,AFSLEMSG="",AFSLOFLG=0,AFSLCFLG=0
S AFSLFY=$E(X,43,44),AFSLDOC=$E(X,17,26),AFSLCAN=$E(X,27,33),AFSLOBJ=$E(X,34,37),AFSLDREF=$E(X,14,16),AFSLLCD=$E(X,125,127),AFSLOBDT=$E(X,39,44)
S AFSLIMN=$E(X,4,6),AFSLCRDT=$E(X,45,50),AFSLLADT=$E(X,51,56),AFSLACRL=$E(X,99,111),AFSLDSBT=$E(X,112,124)
I AFSLFY'?2N S AFSLEMSG=5 G CHKEND
I AFSLDOC=" " S AFSLEMSG=6 G CHKEND
I AFSLCAN'?1UN2N4UN S AFSLEMSG=12 G CHKEND
I $E(AFSLCAN,2,3)'=AFSLAPN S AFSLEMSG=12 G CHKEND
I AFSLOBJ[" " S AFSLEMSG=8 G CHKEND
I AFSLLCD=" " S AFSLLCD="000"
I AFSLLCD?1" "2N S AFSLLCD="0"_$E(AFSLLCD,2,3)
I AFSLLCD?1" "1N S AFSLLCD="00"_$E(AFSLLCD,3)
I AFSLLCD?1N1" " S AFSLLCD="00"_$E(AFSLLCD,1)
I AFSLLCD?2N1" " S AFSLLCD="0"_$E(AFSLLCD,1,2)
I AFSLLCD'?3E S AFSLEMSG=9 G CHKEND
CHKSX ;
I AFSLOBDT'?6N S AFSLEMSG=10 G CHKEND
I AFSLDREF'?3N S AFSLEMSG=11 G CHKEND
;Begin Y2k fix HJT1/15/1999
; Var AFSLFY must be converted to a 4-digit date before looking up
; in glob ^AFSLODOC("B"..). The subscript is 4 digits (i.e. 1999)
S XSAVEX=X ;ACR*2.0T1*1
S X=AFSLFY D ^%DT S AFSLFY=Y\10000+1700 ;Y2000
S X=XSAVEX ;ACR*2.0T1*1
;End Y2k fix
I $D(^AFSLODOC("B",AFSLFY)) S AFSLFYN=$O(^AFSLODOC("B",AFSLFY,0))
E S AFSLDUP=0 G CHKEND
I $D(^AFSLODOC(AFSLFYN,1,"B",AFSLDOC)) S AFSLDOCN=$O(^AFSLODOC(AFSLFYN,1,"B",AFSLDOC,0))
E S AFSLDUP=0 G CHKEND
I $D(^AFSLODOC("C",AFSLCAN,AFSLFYN,AFSLDOCN)) S AFSLCFLG=1
E S AFSLDUP=0 G CHKEND
I $D(^AFSLODOC("D",AFSLOBJ,AFSLFYN,AFSLDOCN)) S AFSLOFLG=1,AFSLDUP=1,AFSLEMSG=1
CHKEND ;
I AFSLEMSG=5 D @(AFSLEMSG),VARKIL Q ;OBLIG.YR ERROR
I AFSLEMSG=6 D @(AFSLEMSG),VARKIL Q ;DOC# ERROR
I AFSLEMSG=8 D @(AFSLEMSG),VARKIL Q ;OBJ CLASS ERROR
I AFSLEMSG=9 D @(AFSLEMSG),VARKIL Q ;LOC CODE ERROR
I AFSLEMSG=10 D @(AFSLEMSG),VARKIL Q ;OBLIG.DT ERROR
I AFSLEMSG=11 D @(AFSLEMSG),VARKIL Q ;DOC REF ERROR
I AFSLEMSG=12 D @(AFSLEMSG),VARKIL Q ;CAN NUM ERROR
I AFSLDUP'=1 D ^AFSLLDO3,VARKIL ;IF NOT DUPLICATE, DO ROUT TO SAVE RCD
I AFSLDUP=1 D @(AFSLEMSG),VARKIL
Q
EMSG ;ERROR MESSAGES
1 W !!,"DUPLICATE ENTRY! DOC.# "_$E(X,17,26)_" ALREADY EXISTS YOU CANNOT CREATE A DUPLICATE." D NOSAV S AFSLDUP=0 K AFSLEMSG Q
3 W !!,"CHS FI PAYMENT! DOC.# "_$P(AFSLXZ,U,1)_" CANNOT BE ENTERED INTO THE 1166 DOCUMENTS FILE." D NOSAV K AFSLEMSG Q
5 W !!,"OBLIGATION YR FORMAT ERROR ON RECORD# "_AFSLI D NOSAV K AFSLEMSG Q
6 W !!,"DOCUMENT NO. FORMAT ERROR ON RECORD# "_AFSLI D NOSAV K AFSLEMSG Q
7 W !!,"RECORD# ",AFSLI," DOC# ",$P(AFSLXZ,U,1)," NOT SAVED (CLOSED & AGE>",AFSLPY," YRS." D NOSAV K AFSLEMSG Q
8 W !!,"OBJECT CLASS FORMAT ERROR ON RECORD# "_AFSLI D NOSAV K AFSLEMSG Q
9 W !!,"LOCATION CODE FORMAT ERROR ON RECORD# "_AFSLI D NOSAV K AFSLEMSG Q
10 W !!,"OBLIGATION DT FORMAT ERROR ON RECORD# "_AFSLI D NOSAV K AFSLEMSG Q
11 W !!,"DOC.REF. CODE FORMAT ERROR ON RECORD# "_AFSLI D NOSAV K AFSLEMSG Q
12 W !!,"CAN NUMBER FORMAT ERROR ON RECORD# "_AFSLI D NOSAV K AFSLEMSG Q
VARKIL ;
K DIE,DR,DA,AFSLEMSG,AFSLOFLG,AFSLCFLG,AFSLDOC
K AFSLCAN,AFSLOBJ,AFSLFYN,AFSLDOCN,AFSLYY,AFSLDDAT,AFSLFNUM
S (AFSLXY,AFSLXY2,AFSLXZ)=""
Q
NOSAV ;
I K=0 S ^AFSLREJT(K)="1166 AFP REJECTED HAS RCDS^9002325.7^0^0"
S K=K+1,$P(^AFSLREJT(0),U,3)=K,$P(^AFSLREJT(0),U,4)=K,$P(^AFSLREJT(K,0),U,1)=K
I AFSLEMSG=5 S $P(^AFSLREJT(K,0),U,2)=$E(X,1,52)_"^"_AFSLEMSG_"^"_AFSLI,^AFSLREJT("B",K,K)="" Q
S $P(^AFSLREJT(K,0),U,2)=$E(X,14,16)_" "_$E(X,17,26)_" "_$E(X,27,33)_" "_$E(X,34,37)_" "_$E(X,39,44)_" "_$E(X,60,73)_"^"_AFSLEMSG_"^"_AFSLI
S ^AFSLREJT("B",K,K)=""
Q
AFSLLDO2 ;IHS/OIRM/DSD/JDM,HJT - LOAD ODF FROM DOWNLOAD FILE; [ 10/27/2004 4:21 PM ]
+1 ;;3.0t1;1166 APPROVALS FOR PAYMENT;**1,13**;JAN 31, 1999
+2 ;;ACR*2.1*9 MODIFIED FOR CACHE' COMPLIANCE
+3 ;Modified for Y2k compliance IHS/DSD/HJT 1/15/1999
+4 ;Read & check records from H.A.S. download file
FRD DO ^XBCLS
+1 WRITE !,"READY TO IMPORT SELECTED DOWNLOAD FILE."
+2 WRITE !!,"Some Area Offices make obligations/payments for multiple accounting points."
+3 WRITE !,"I must CLEAR the local obligations database before importing the 1ST",!,"Accounting Point download file ONLY."
+4 WRITE !!,@AFSLRVON,"***WARNING! ANSWERING ""Y"" TO THE NEXT QUESTION WILL CLEAR THE DATABASE.",@AFSLRVOF,*7
+5 ; ACR*2.1*13.02 IM13574
NEW DIR,X,Y
+6 ; ACR*2.1*13.02 IM13574
SET DIR(0)="Y^A"
+7 ; ACR*2.1*13.02 IM13574
SET DIR("A")="IS THIS THE 1ST ACCOUNTING POINT (OF THIS DOWNLOAD) TO BE IMPORTED? (Y/N/^)"
+8 ; ACR*2.1*13.02 IM13574
SET DIR("B")="N"
+9 ; ACR*2.1*13.02 IM13574
DO DIR^ACRFDIC
+10 ; ACR*2.1*13.02 IM13574
SET AFSLAPIN=$SELECT(ACRY=1:"Y",1:"N")
+11 ; ACR*2.1*13.02 IM13574
NEW DIR,X,Y
+12 ; ACR*2.1*13.02 IM13574
SET DIR(0)="Y^A"
+13 ; ACR*2.1*13.02 IM13574
SET DIR("A")="ENTER ""Y"" AGAIN TO BEGIN (Y/N)"
+14 ; ACR*2.1*13.02 IM13574
SET DIR("B")="N"
+15 ; ACR*2.1*13.02 IM13574
DO DIR^ACRFDIC
+16 ;AFSLCONT IS EXPECTED TO BE Y OR N
SET AFSLCONT=$SELECT(ACRY=1:"Y",1:"N")
+17 ; ACR*2.1*13.02 IM13574
IF AFSLCONT="N"!($DATA(ACRQUIT))!($DATA(ACROUT))
QUIT
+18 DO ^XBCLS
+19 SET %FN=AFSEXFN
SET %IN=1
SET (AFSLXY,AFSLXZ)=""
SET AFSLDUP=0
SET AFSLZROS="000000000000"
SET AFSLDUPF=""
+20 WRITE !,"LOADING RECORDS FOR A/P ",AFSLAPN,!,"WORKING "
+21 IF AFSLAPIN'="Y"&(AFSLAPIN'="y")
GOTO SKPCLR
+22 ;EXEMPTION ************** H.A.S. DOWNLOAD GBLS
KILL ^AFSLODOC,^AFSLREJT
+23 SET ^AFSLODOC(0)="1166 AFP OPEN DOCUMENTS^9002325.3^0^0"
SET ^AFSLREJT(0)="1166 AFP REJECTED HAS RCDS^9002325.7^0^0"
SKPCLR ;
+1 IF '$DATA(X)
SET X="000"
+2 SET AFSLWCTR=0
+3 ; ACR*2.1*13.02 IM13574
DO OPENHFS^AFSLCK1
+4 ;S IO=%DEV ; ACR*2.1*13.02 IM13574
+5 FOR AFSLI=1:1
SET AFSLWCTR=AFSLWCTR+1
USE IO
READ X:60
DO ^AFSLCKZC
IF X=""
QUIT
IF AFSLNZC=-1
QUIT
DO CHKS
IF AFSLDUP=1
DO @(AFSLEMSG)
IF AFSLWCTR=1000
USE IO(0)
WRITE "."
SET AFSLWCTR=0
+6 USE IO(0)
WRITE AFSLI
KILL AFSLWCTR
+7 USE IO(0)
WRITE !!,"BEGINNING COMPILED RE-CROSSREFERENCING. PLEASE WAIT WHILE FILEMAN REINDEXES.",!,"BEGIN: "
DO NOW^%DTC
DO YX^%DTC
WRITE Y
+8 SET DIK="^AFSLODOC("
DO IXALL^DIK
+9 USE IO(0)
WRITE !?58,"END: "
DO NOW^%DTC
DO YX^%DTC
WRITE Y
+10 LOCK -^AFSLODOC
+11 ;D ^%ZISC ; ACR*2.1*13.02 IM13574
+12 ; ACR*2.1*13.02 IM13574
DO CLOSE^%ZISH("")
+13 DO VARKIL
KILL %FN,%IN,AFSLXY,AFSLXZ,AFSLXZ2,%DEV
+14 KILL AFSEXFN,AFSLCMD,AFSLCONT,AFSLDNOD,AFSLDNXT,AFSLDOCX,AFSLDT,AFSLDUP,AFSLDUPV,AFSLFFND,AFSLFY,AFSLI,AFSLLTDL,AFSLLTH,AFSLLTR
+15 KILL AFSLOBLD,AFSLOK,AFSLSN,AFSLSNX,AFSLVAL,AFSLXC,AFSLXFND,AFSLXY2,AFSLYNOD,AFSLYNXT,AFSLZROS,AFSLRVOF,AFSLRVON,DIK,DX,DY,I,K,X,XY
+16 QUIT
CHKS ;
+1 SET X=$EXTRACT(X,1,132)
+2 IF $EXTRACT(X,4)="J"
SET X=$EXTRACT(X,2,132)
+3 IF $EXTRACT(X,1,2)'=AFSLAPN
QUIT
+4 USE IO(0)
LOCK +^AFSLODOC:15
IF '$TEST
SET AFSLDUPF=1
WRITE !,"FILE IN USE AT THIS TIME. TRY LATER."
HANG 3
QUIT
+5 SET AFSLDUP=0
SET AFSLEMSG=""
SET AFSLOFLG=0
SET AFSLCFLG=0
+6 SET AFSLFY=$EXTRACT(X,43,44)
SET AFSLDOC=$EXTRACT(X,17,26)
SET AFSLCAN=$EXTRACT(X,27,33)
SET AFSLOBJ=$EXTRACT(X,34,37)
SET AFSLDREF=$EXTRACT(X,14,16)
SET AFSLLCD=$EXTRACT(X,125,127)
SET AFSLOBDT=$EXTRACT(X,39,44)
+7 SET AFSLIMN=$EXTRACT(X,4,6)
SET AFSLCRDT=$EXTRACT(X,45,50)
SET AFSLLADT=$EXTRACT(X,51,56)
SET AFSLACRL=$EXTRACT(X,99,111)
SET AFSLDSBT=$EXTRACT(X,112,124)
+8 IF AFSLFY'?2N
SET AFSLEMSG=5
GOTO CHKEND
+9 IF AFSLDOC=" "
SET AFSLEMSG=6
GOTO CHKEND
+10 IF AFSLCAN'?1UN2N4UN
SET AFSLEMSG=12
GOTO CHKEND
+11 IF $EXTRACT(AFSLCAN,2,3)'=AFSLAPN
SET AFSLEMSG=12
GOTO CHKEND
+12 IF AFSLOBJ[" "
SET AFSLEMSG=8
GOTO CHKEND
+13 IF AFSLLCD=" "
SET AFSLLCD="000"
+14 IF AFSLLCD?1" "2N
SET AFSLLCD="0"_$EXTRACT(AFSLLCD,2,3)
+15 IF AFSLLCD?1" "1N
SET AFSLLCD="00"_$EXTRACT(AFSLLCD,3)
+16 IF AFSLLCD?1N1" "
SET AFSLLCD="00"_$EXTRACT(AFSLLCD,1)
+17 IF AFSLLCD?2N1" "
SET AFSLLCD="0"_$EXTRACT(AFSLLCD,1,2)
+18 IF AFSLLCD'?3E
SET AFSLEMSG=9
GOTO CHKEND
CHKSX ;
+1 IF AFSLOBDT'?6N
SET AFSLEMSG=10
GOTO CHKEND
+2 IF AFSLDREF'?3N
SET AFSLEMSG=11
GOTO CHKEND
+3 ;Begin Y2k fix HJT1/15/1999
+4 ; Var AFSLFY must be converted to a 4-digit date before looking up
+5 ; in glob ^AFSLODOC("B"..). The subscript is 4 digits (i.e. 1999)
+6 ;ACR*2.0T1*1
SET XSAVEX=X
+7 ;Y2000
SET X=AFSLFY
DO ^%DT
SET AFSLFY=Y\10000+1700
+8 ;ACR*2.0T1*1
SET X=XSAVEX
+9 ;End Y2k fix
+10 IF $DATA(^AFSLODOC("B",AFSLFY))
SET AFSLFYN=$ORDER(^AFSLODOC("B",AFSLFY,0))
+11 IF '$TEST
SET AFSLDUP=0
GOTO CHKEND
+12 IF $DATA(^AFSLODOC(AFSLFYN,1,"B",AFSLDOC))
SET AFSLDOCN=$ORDER(^AFSLODOC(AFSLFYN,1,"B",AFSLDOC,0))
+13 IF '$TEST
SET AFSLDUP=0
GOTO CHKEND
+14 IF $DATA(^AFSLODOC("C",AFSLCAN,AFSLFYN,AFSLDOCN))
SET AFSLCFLG=1
+15 IF '$TEST
SET AFSLDUP=0
GOTO CHKEND
+16 IF $DATA(^AFSLODOC("D",AFSLOBJ,AFSLFYN,AFSLDOCN))
SET AFSLOFLG=1
SET AFSLDUP=1
SET AFSLEMSG=1
CHKEND ;
+1 ;OBLIG.YR ERROR
IF AFSLEMSG=5
DO @(AFSLEMSG)
DO VARKIL
QUIT
+2 ;DOC# ERROR
IF AFSLEMSG=6
DO @(AFSLEMSG)
DO VARKIL
QUIT
+3 ;OBJ CLASS ERROR
IF AFSLEMSG=8
DO @(AFSLEMSG)
DO VARKIL
QUIT
+4 ;LOC CODE ERROR
IF AFSLEMSG=9
DO @(AFSLEMSG)
DO VARKIL
QUIT
+5 ;OBLIG.DT ERROR
IF AFSLEMSG=10
DO @(AFSLEMSG)
DO VARKIL
QUIT
+6 ;DOC REF ERROR
IF AFSLEMSG=11
DO @(AFSLEMSG)
DO VARKIL
QUIT
+7 ;CAN NUM ERROR
IF AFSLEMSG=12
DO @(AFSLEMSG)
DO VARKIL
QUIT
+8 ;IF NOT DUPLICATE, DO ROUT TO SAVE RCD
IF AFSLDUP'=1
DO ^AFSLLDO3
DO VARKIL
+9 IF AFSLDUP=1
DO @(AFSLEMSG)
DO VARKIL
+10 QUIT
EMSG ;ERROR MESSAGES
1 WRITE !!,"DUPLICATE ENTRY! DOC.# "_$EXTRACT(X,17,26)_" ALREADY EXISTS YOU CANNOT CREATE A DUPLICATE."
DO NOSAV
SET AFSLDUP=0
KILL AFSLEMSG
QUIT
3 WRITE !!,"CHS FI PAYMENT! DOC.# "_$PIECE(AFSLXZ,U,1)_" CANNOT BE ENTERED INTO THE 1166 DOCUMENTS FILE."
DO NOSAV
KILL AFSLEMSG
QUIT
5 WRITE !!,"OBLIGATION YR FORMAT ERROR ON RECORD# "_AFSLI
DO NOSAV
KILL AFSLEMSG
QUIT
6 WRITE !!,"DOCUMENT NO. FORMAT ERROR ON RECORD# "_AFSLI
DO NOSAV
KILL AFSLEMSG
QUIT
7 WRITE !!,"RECORD# ",AFSLI," DOC# ",$PIECE(AFSLXZ,U,1)," NOT SAVED (CLOSED & AGE>",AFSLPY," YRS."
DO NOSAV
KILL AFSLEMSG
QUIT
8 WRITE !!,"OBJECT CLASS FORMAT ERROR ON RECORD# "_AFSLI
DO NOSAV
KILL AFSLEMSG
QUIT
9 WRITE !!,"LOCATION CODE FORMAT ERROR ON RECORD# "_AFSLI
DO NOSAV
KILL AFSLEMSG
QUIT
10 WRITE !!,"OBLIGATION DT FORMAT ERROR ON RECORD# "_AFSLI
DO NOSAV
KILL AFSLEMSG
QUIT
11 WRITE !!,"DOC.REF. CODE FORMAT ERROR ON RECORD# "_AFSLI
DO NOSAV
KILL AFSLEMSG
QUIT
12 WRITE !!,"CAN NUMBER FORMAT ERROR ON RECORD# "_AFSLI
DO NOSAV
KILL AFSLEMSG
QUIT
VARKIL ;
+1 KILL DIE,DR,DA,AFSLEMSG,AFSLOFLG,AFSLCFLG,AFSLDOC
+2 KILL AFSLCAN,AFSLOBJ,AFSLFYN,AFSLDOCN,AFSLYY,AFSLDDAT,AFSLFNUM
+3 SET (AFSLXY,AFSLXY2,AFSLXZ)=""
+4 QUIT
NOSAV ;
+1 IF K=0
SET ^AFSLREJT(K)="1166 AFP REJECTED HAS RCDS^9002325.7^0^0"
+2 SET K=K+1
SET $PIECE(^AFSLREJT(0),U,3)=K
SET $PIECE(^AFSLREJT(0),U,4)=K
SET $PIECE(^AFSLREJT(K,0),U,1)=K
+3 IF AFSLEMSG=5
SET $PIECE(^AFSLREJT(K,0),U,2)=$EXTRACT(X,1,52)_"^"_AFSLEMSG_"^"_AFSLI
SET ^AFSLREJT("B",K,K)=""
QUIT
+4 SET $PIECE(^AFSLREJT(K,0),U,2)=$EXTRACT(X,14,16)_" "_$EXTRACT(X,17,26)_" "_$EXTRACT(X,27,33)_" "_$EXTRACT(X,34,37)_" "_$EXTRACT(X,39,44)_" "_$EXTRACT(X,60,73)_"^"_AFSLEMSG_"^"_AFSLI
+5 SET ^AFSLREJT("B",K,K)=""
+6 QUIT
