AFSLTF1 ;IHS/OIRM/DSD/JDM,HJT - EXPORT PAYMENT RCDS TO FILE(ECS)-MODULE #2; [ 10/27/2004 4:21 PM ]
;;3.0t1;1166 APPROVALS FOR PAYMENT;**13**;
;;MODIFIED FOR CACHE' COMPLIANCE ACR*2.1*9
;Modified for Y2k compliance IHS/DSD/HJT 1/24/1999
;Generate unix file for convey of pmts to Treasury - part 2
U IO(0)
S (AFSL1,AFSLEMSG,AFSLFLG1,AFSL1A,AFSL2,AFSL3,AFSL4,AFSL5)=0
S (AFSLSCH1,AFSLFYN,AFSLSEQ,AFSLSEQ1,AFSLCNT,AFSLAMT,AFSLIN)=0
S AFSLPG=1
S AFSLFY=AFSLTFY,AFSLNXPN=0
PRC ;
; Var AFSLFY should be a 4-digit year here. IHS/DSD/HJT 1/23/1999
I '$O(^AFSLAFP("B",AFSLFY,AFSLFYN)) D ASKYR
S AFSLFYN="",AFSLFYN=$O(^AFSLAFP("B",AFSLFY,AFSLFYN))
S (AFSLEIN,AFSLEIN1)=""
S (AFSLCBC,AFSLFLG,AFSLCBA,AFSLCNT)=0,AFSLCNT1=1
;
TREAS ;GET & CHECK SCHED#
I AFSLFYN="" G PRC
S AFSLBN=AFSLTNUM,X=AFSLTNUM G TREASX
S AFSLBN=$P(^AFSLAFP(AFSLFYN,2),U,1)+1
S DIR(0)="F^6:6"
S DIR("B")=AFSLBN
S DIR("A")="TREASURY SCHEDULE NUMBER (6 CHARACTERS):"
S DIR("?")="Enter a six characters"
S DIR("??")="AFSL TREASURY"
U IO(0) D ^DIR S AFSLBN=Y
;
TREASX ;
S AFSLSCDX="0000"_X
S DIE="^AFSLAFP(",DA=AFSLFYN,DR="2////"_AFSLBN D ^DIE
S AFSLSH11="0000"_AFSLBN
;
GROUPING ;
I AFSLXTYP="A"!(AFSLXTYP="C") S X="Y" G GROUPX
I AFSLXTYP="B" S X="N" G GROUPX
K DIR
S DIR(0)="S^Y:GROUP PAYMENTS FOR PAYEE (CHECKS & ACH-TYPE A);N:NO, DONT GROUP (1 ENCLOSURE FOR EACH PMT ENTERED)"
S DIR("A")="PAYMENT GROUPING OPTION",DIR("B")="N"
D ^DIR
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) U IO(0) W !!,"NO '^' ALLOWED AT THIS TIME" H 2 G GROUPING
;
GROUPX ;
S AFSLEXTP=X
I AFSLEXTP="Y"!(AFSLEXTP="y") S AFSLEXTP="A"
I AFSLEXTP="N"!(AFSLEXTP="n") S AFSLEXTP="B"
XHDR ;CREATE '&' AND 'A' CARDS
D HDR^AFSLTF2
XDTL ;LOOP THRU 'ME' XREF & CREATE DETAIL RCDS
;
;Kill Temp work globals
K ^AFSLPTMP,^AFSLXTMP ;EXEMPTION ************** H.A.S. DOWNLOAD G
;
; Set ^AFSLPTMP( Nodes
D XREF
;
I AFSLEXTP="A" D
.D ^AFSLTPRC
.S (AFSLCKNX,AFSLCNTX,AFSLPAX,AFSLPTX,AFSLPCX)=0
.D WRLS^AFSLTPRC ; Set ^AFSLXTMP( NODES
;
I AFSLEXTP="B" D
.D ^AFSLTPAC
.S (AFSLCKNX,AFSLCNTX,AFSLPAX,AFSLPTX,AFSLPCX)=0
.D WRLS^AFSLTPRC ; Set ^AFSLXTMP( NODES
;
XTRL ;CREATE TRAILER RCDS
D EXDAT
S AFSLFLG=1
I AFSLEMSG=0,AFSLFLG=1 S AFSLECSP=1 D TRL^AFSLTF2 Q
S AFSLEFLG=1
Q
XREF ;SET ^AFSLPTMP( NODES
S AFSLMNX=0
LOOPME ;Loop thru 'ME' Xref using all payments in all export batches
;
S AFSLMNX=$O(^AFSLAFP("ME",AFSLFYN,AFSLMNX))
Q:AFSLMNX=""
;
U IO(0) W !,"PROCESSING BATCH:",AFSLTRSC
S AFSLBYND=AFSLFYN D PRCX
I '$D(AFSLBCNT) S AFSLBCNT=0
S AFSLBCNT=AFSLBCNT+1 S AFSLBATC(AFSLBCNT)=AFSLBND
G LOOPME
;
PRCX ;SET TEMP EXPORT GBL ^AFSLPTMP(
Q:AFSLMNX=""
S AFSLBND=AFSLMNX,AFSLBTCX=$P(^AFSLAFP(AFSLBYND,1,AFSLMNX,0),U,1)
G RNDXP
S AFSLBND=$O(^AFSLAFP("L",AFSLMNX,AFSLBYND,0))
S AFSLBND=$O(^AFSLAFP(AFSLBYND,1,AFSLMNX,0))
;
RNDXP ;REINDEX XREF 'P' FOR THE BATCH
F XX=1:1:9999 D
.Q:'$O(^AFSLAFP(AFSLBYND,1,AFSLBND,1,XX))
.S DIK="^AFSLAFP("_AFSLBYND_",1,"_AFSLBND_",1,",DIK(1)="33"
.S DA=XX,DA(2)=AFSLBYND,DA(1)=AFSLBND
.D EN^DIK
S AFSLONX="0"
S AFSLSCH1=AFSLBND,AFSLFYN=AFSLBYND D CHK
;
LOOPO ;
Q:'$L($O(^AFSLAFP("P",AFSLONX)))
S AFSLONX=$O(^AFSLAFP("P",AFSLONX))
S AFSLPND=0 D LOOPP
G LOOPO
;
LOOPP ;
; This subroutine sets up temporary globals inorder to write the
; payment details to a Unix file (DE - call #58).
;
I '$O(^AFSLAFP("P",AFSLONX,AFSLBYND,AFSLBND,AFSLPND)) Q
S AFSLPND=$O(^AFSLAFP("P",AFSLONX,AFSLBYND,AFSLBND,AFSLPND))
I '$D(^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,0)) S AFSLPND0="",AFSLPND1="",AFSLPND2="" G SKPNDS
I '$D(^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,1)) S AFSLPND1="",AFSLPND2="" G SKPNDS
I '$D(^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,2)) S AFSLPND2="" G SKPNDS
S AFSLPND0=^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,0)
S AFSLPND1=^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,1)
S AFSLPND2=^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,2)
;
SKPNDS ;
I '$D(AFSLPND0) S AFSLPND0=""
I '$D(AFSLPND1) S AFSLPND1=""
I '$D(AFSLPND2) S AFSLPND2=""
S AFSLNXPN=AFSLNXPN+1
S ^AFSLPTMP(AFSLNXPN,0)=AFSLPND0
S ^AFSLPTMP(AFSLNXPN,1)=AFSLPND1
S ^AFSLPTMP(AFSLNXPN,2)=AFSLPND2
G LOOPP
Q
CHK ;checks for certification date,open/close,export date
I $D(^AFSLAFP(AFSLFYN,1,AFSLSCH1,0)) S AFSLSCH3=^(0)
E Q
I $D(^AFSLAFP(AFSLFYN,1,AFSLSCH1,2)) S AFSLSCH2=^(2)
E Q
I '$D(^AFSLAFP("ME",AFSLFYN,$P(^AFSLAFP(AFSLFYN,1,AFSLSCH1,0),U,1))) Q
I $P(AFSLSCH3,U,5)]"",$P(AFSLSCH2,U,1)']"",$P(AFSLSCH2,U,3)["C",$P(AFSLSCH2,U,2)'>DT-7 S AFSLFLG=1,AFSLFLG1=1,AFSLSCH=$P(AFSLSCH3,U,1),AFSLSCH1(AFSLSCH1)=AFSLSCH1,AFSLSCHZ=AFSLSCH1
S AFSLOO="0000000000"
Q
TNUM ;
S X=AFSLBN
S DIE="^AFSLAFP("_AFSLFYN_",1,"
S DA(1)=AFSLFYN
S DA=AFSLSCH1
S DR="10////"_AFSLSH11
D ^DIE
Q
PDT ;
S DIE="^AFSLAFP("_AFSLFYN_",1,"_AFSLSCH1_",1,",DA(2)=AFSLFYN
S DA(1)=AFSLSCH1,DA=AFSLEIN1,DR="19////"_AFSLPDT
D ^DIE
S AFSLDNUM=$P(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,16)
;S AFSLDFYN=$P(^(1),U,15),AFSLPDNM=$P(^(1),U,7) ;ACR*2.1*13.02 IM13574
S AFSLDFYN=$P(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,15) ;ACR*2.1*13.02 IM13574 IM13574
S AFSLPDNM=$P(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,7) ;ACR*2.1*13.02 IM13574 IM13574
S DIE="^AFSLODOC("_AFSLDFYN_",1,"_AFSLDNUM_",1,"
S DA(2)=AFSLDFYN
S DA(1)=AFSLDNUM
S DA=AFSLPDNM
S DR="1////"_AFSLPDT
D ^DIE
Q
EXDAT ;set export date for schedule
S AFSLBTN=0
STEXDT Q:'$O(AFSLBATC(AFSLBTN))
S AFSLBTN=$O(AFSLBATC(AFSLBTN))
S AFSLBATN=AFSLBATC(AFSLBTN)
S DIE="^AFSLAFP("_AFSLFYN_",1,",DA(1)=AFSLFYN
S DA=AFSLBATN,DR="5///TODAY"
D ^DIE L -^AFSLAFP ; UNLK PMTS FILE
G STEXDT
Q
S AFSLBTN=0
ASKYR ;
K DIR
S DIR("A")="FISCAL YEAR NOT SET-UP IN PAYMENT FILE. RE-ENTER"
;Begin Y2k fix IHS/DSD/HJT 1/23/1999
; Asking for 2 digit year to lookup in file. Ch anged to 4 digit.
S DIR(0)="F^4:4" ;Y2000
D ^DIR
I $D(DIRUT) S X="^"
I X'?4N W *7 G ASKYR ;Y2000
;End Y2k fix
S AFSLFY=X
Q
AFSLTF1 ;IHS/OIRM/DSD/JDM,HJT - EXPORT PAYMENT RCDS TO FILE(ECS)-MODULE #2; [ 10/27/2004 4:21 PM ]
+1 ;;3.0t1;1166 APPROVALS FOR PAYMENT;**13**;
+2 ;;MODIFIED FOR CACHE' COMPLIANCE ACR*2.1*9
+3 ;Modified for Y2k compliance IHS/DSD/HJT 1/24/1999
+4 ;Generate unix file for convey of pmts to Treasury - part 2
+5 USE IO(0)
+6 SET (AFSL1,AFSLEMSG,AFSLFLG1,AFSL1A,AFSL2,AFSL3,AFSL4,AFSL5)=0
+7 SET (AFSLSCH1,AFSLFYN,AFSLSEQ,AFSLSEQ1,AFSLCNT,AFSLAMT,AFSLIN)=0
+8 SET AFSLPG=1
+9 SET AFSLFY=AFSLTFY
SET AFSLNXPN=0
PRC ;
+1 ; Var AFSLFY should be a 4-digit year here. IHS/DSD/HJT 1/23/1999
+2 IF '$ORDER(^AFSLAFP("B",AFSLFY,AFSLFYN))
DO ASKYR
+3 SET AFSLFYN=""
SET AFSLFYN=$ORDER(^AFSLAFP("B",AFSLFY,AFSLFYN))
+4 SET (AFSLEIN,AFSLEIN1)=""
+5 SET (AFSLCBC,AFSLFLG,AFSLCBA,AFSLCNT)=0
SET AFSLCNT1=1
+6 ;
TREAS ;GET & CHECK SCHED#
+1 IF AFSLFYN=""
GOTO PRC
+2 SET AFSLBN=AFSLTNUM
SET X=AFSLTNUM
GOTO TREASX
+3 SET AFSLBN=$PIECE(^AFSLAFP(AFSLFYN,2),U,1)+1
+4 SET DIR(0)="F^6:6"
+5 SET DIR("B")=AFSLBN
+6 SET DIR("A")="TREASURY SCHEDULE NUMBER (6 CHARACTERS):"
+7 SET DIR("?")="Enter a six characters"
+8 SET DIR("??")="AFSL TREASURY"
+9 USE IO(0)
DO ^DIR
SET AFSLBN=Y
+10 ;
TREASX ;
+1 SET AFSLSCDX="0000"_X
+2 SET DIE="^AFSLAFP("
SET DA=AFSLFYN
SET DR="2////"_AFSLBN
DO ^DIE
+3 SET AFSLSH11="0000"_AFSLBN
+4 ;
GROUPING ;
+1 IF AFSLXTYP="A"!(AFSLXTYP="C")
SET X="Y"
GOTO GROUPX
+2 IF AFSLXTYP="B"
SET X="N"
GOTO GROUPX
+3 KILL DIR
+4 SET DIR(0)="S^Y:GROUP PAYMENTS FOR PAYEE (CHECKS & ACH-TYPE A);N:NO, DONT GROUP (1 ENCLOSURE FOR EACH PMT ENTERED)"
+5 SET DIR("A")="PAYMENT GROUPING OPTION"
SET DIR("B")="N"
+6 DO ^DIR
+7 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
USE IO(0)
WRITE !!,"NO '^' ALLOWED AT THIS TIME"
HANG 2
GOTO GROUPING
+8 ;
GROUPX ;
+1 SET AFSLEXTP=X
+2 IF AFSLEXTP="Y"!(AFSLEXTP="y")
SET AFSLEXTP="A"
+3 IF AFSLEXTP="N"!(AFSLEXTP="n")
SET AFSLEXTP="B"
XHDR ;CREATE '&' AND 'A' CARDS
+1 DO HDR^AFSLTF2
XDTL ;LOOP THRU 'ME' XREF & CREATE DETAIL RCDS
+1 ;
+2 ;Kill Temp work globals
+3 ;EXEMPTION ************** H.A.S. DOWNLOAD G
KILL ^AFSLPTMP,^AFSLXTMP
+4 ;
+5 ; Set ^AFSLPTMP( Nodes
+6 DO XREF
+7 ;
+8 IF AFSLEXTP="A"
Begin DoDot:1
+9 DO ^AFSLTPRC
+10 SET (AFSLCKNX,AFSLCNTX,AFSLPAX,AFSLPTX,AFSLPCX)=0
+11 ; Set ^AFSLXTMP( NODES
DO WRLS^AFSLTPRC
End DoDot:1
+12 ;
+13 IF AFSLEXTP="B"
Begin DoDot:1
+14 DO ^AFSLTPAC
+15 SET (AFSLCKNX,AFSLCNTX,AFSLPAX,AFSLPTX,AFSLPCX)=0
+16 ; Set ^AFSLXTMP( NODES
DO WRLS^AFSLTPRC
End DoDot:1
+17 ;
XTRL ;CREATE TRAILER RCDS
+1 DO EXDAT
+2 SET AFSLFLG=1
+3 IF AFSLEMSG=0
IF AFSLFLG=1
SET AFSLECSP=1
DO TRL^AFSLTF2
QUIT
+4 SET AFSLEFLG=1
+5 QUIT
XREF ;SET ^AFSLPTMP( NODES
+1 SET AFSLMNX=0
LOOPME ;Loop thru 'ME' Xref using all payments in all export batches
+1 ;
+2 SET AFSLMNX=$ORDER(^AFSLAFP("ME",AFSLFYN,AFSLMNX))
+3 IF AFSLMNX=""
QUIT
+4 ;
+5 USE IO(0)
WRITE !,"PROCESSING BATCH:",AFSLTRSC
+6 SET AFSLBYND=AFSLFYN
DO PRCX
+7 IF '$DATA(AFSLBCNT)
SET AFSLBCNT=0
+8 SET AFSLBCNT=AFSLBCNT+1
SET AFSLBATC(AFSLBCNT)=AFSLBND
+9 GOTO LOOPME
+10 ;
PRCX ;SET TEMP EXPORT GBL ^AFSLPTMP(
+1 IF AFSLMNX=""
QUIT
+2 SET AFSLBND=AFSLMNX
SET AFSLBTCX=$PIECE(^AFSLAFP(AFSLBYND,1,AFSLMNX,0),U,1)
+3 GOTO RNDXP
+4 SET AFSLBND=$ORDER(^AFSLAFP("L",AFSLMNX,AFSLBYND,0))
+5 SET AFSLBND=$ORDER(^AFSLAFP(AFSLBYND,1,AFSLMNX,0))
+6 ;
RNDXP ;REINDEX XREF 'P' FOR THE BATCH
+1 FOR XX=1:1:9999
Begin DoDot:1
+2 IF '$ORDER(^AFSLAFP(AFSLBYND,1,AFSLBND,1,XX))
QUIT
+3 SET DIK="^AFSLAFP("_AFSLBYND_",1,"_AFSLBND_",1,"
SET DIK(1)="33"
+4 SET DA=XX
SET DA(2)=AFSLBYND
SET DA(1)=AFSLBND
+5 DO EN^DIK
End DoDot:1
+6 SET AFSLONX="0"
+7 SET AFSLSCH1=AFSLBND
SET AFSLFYN=AFSLBYND
DO CHK
+8 ;
LOOPO ;
+1 IF '$LENGTH($ORDER(^AFSLAFP("P",AFSLONX)))
QUIT
+2 SET AFSLONX=$ORDER(^AFSLAFP("P",AFSLONX))
+3 SET AFSLPND=0
DO LOOPP
+4 GOTO LOOPO
+5 ;
LOOPP ;
+1 ; This subroutine sets up temporary globals inorder to write the
+2 ; payment details to a Unix file (DE - call #58).
+3 ;
+4 IF '$ORDER(^AFSLAFP("P",AFSLONX,AFSLBYND,AFSLBND,AFSLPND))
QUIT
+5 SET AFSLPND=$ORDER(^AFSLAFP("P",AFSLONX,AFSLBYND,AFSLBND,AFSLPND))
+6 IF '$DATA(^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,0))
SET AFSLPND0=""
SET AFSLPND1=""
SET AFSLPND2=""
GOTO SKPNDS
+7 IF '$DATA(^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,1))
SET AFSLPND1=""
SET AFSLPND2=""
GOTO SKPNDS
+8 IF '$DATA(^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,2))
SET AFSLPND2=""
GOTO SKPNDS
+9 SET AFSLPND0=^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,0)
+10 SET AFSLPND1=^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,1)
+11 SET AFSLPND2=^AFSLAFP(AFSLBYND,1,AFSLBND,1,AFSLPND,2)
+12 ;
SKPNDS ;
+1 IF '$DATA(AFSLPND0)
SET AFSLPND0=""
+2 IF '$DATA(AFSLPND1)
SET AFSLPND1=""
+3 IF '$DATA(AFSLPND2)
SET AFSLPND2=""
+4 SET AFSLNXPN=AFSLNXPN+1
+5 SET ^AFSLPTMP(AFSLNXPN,0)=AFSLPND0
+6 SET ^AFSLPTMP(AFSLNXPN,1)=AFSLPND1
+7 SET ^AFSLPTMP(AFSLNXPN,2)=AFSLPND2
+8 GOTO LOOPP
+9 QUIT
CHK ;checks for certification date,open/close,export date
+1 IF $DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,0))
SET AFSLSCH3=^(0)
+2 IF '$TEST
QUIT
+3 IF $DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,2))
SET AFSLSCH2=^(2)
+4 IF '$TEST
QUIT
+5 IF '$DATA(^AFSLAFP("ME",AFSLFYN,$PIECE(^AFSLAFP(AFSLFYN,1,AFSLSCH1,0),U,1)))
QUIT
+6 IF $PIECE(AFSLSCH3,U,5)]""
IF $PIECE(AFSLSCH2,U,1)']""
IF $PIECE(AFSLSCH2,U,3)["C"
IF $PIECE(AFSLSCH2,U,2)'>DT-7
SET AFSLFLG=1
SET AFSLFLG1=1
SET AFSLSCH=$PIECE(AFSLSCH3,U,1)
SET AFSLSCH1(AFSLSCH1)=AFSLSCH1
SET AFSLSCHZ=AFSLSCH1
+7 SET AFSLOO="0000000000"
+8 QUIT
TNUM ;
+1 SET X=AFSLBN
+2 SET DIE="^AFSLAFP("_AFSLFYN_",1,"
+3 SET DA(1)=AFSLFYN
+4 SET DA=AFSLSCH1
+5 SET DR="10////"_AFSLSH11
+6 DO ^DIE
+7 QUIT
PDT ;
+1 SET DIE="^AFSLAFP("_AFSLFYN_",1,"_AFSLSCH1_",1,"
SET DA(2)=AFSLFYN
+2 SET DA(1)=AFSLSCH1
SET DA=AFSLEIN1
SET DR="19////"_AFSLPDT
+3 DO ^DIE
+4 SET AFSLDNUM=$PIECE(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,16)
+5 ;S AFSLDFYN=$P(^(1),U,15),AFSLPDNM=$P(^(1),U,7) ;ACR*2.1*13.02 IM13574
+6 ;ACR*2.1*13.02 IM13574 IM13574
SET AFSLDFYN=$PIECE(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,15)
+7 ;ACR*2.1*13.02 IM13574 IM13574
SET AFSLPDNM=$PIECE(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,7)
+8 SET DIE="^AFSLODOC("_AFSLDFYN_",1,"_AFSLDNUM_",1,"
+9 SET DA(2)=AFSLDFYN
+10 SET DA(1)=AFSLDNUM
+11 SET DA=AFSLPDNM
+12 SET DR="1////"_AFSLPDT
+13 DO ^DIE
+14 QUIT
EXDAT ;set export date for schedule
+1 SET AFSLBTN=0
STEXDT IF '$ORDER(AFSLBATC(AFSLBTN))
QUIT
+1 SET AFSLBTN=$ORDER(AFSLBATC(AFSLBTN))
+2 SET AFSLBATN=AFSLBATC(AFSLBTN)
+3 SET DIE="^AFSLAFP("_AFSLFYN_",1,"
SET DA(1)=AFSLFYN
+4 SET DA=AFSLBATN
SET DR="5///TODAY"
+5 ; UNLK PMTS FILE
DO ^DIE
LOCK -^AFSLAFP
+6 GOTO STEXDT
+7 QUIT
+8 SET AFSLBTN=0
ASKYR ;
+1 KILL DIR
+2 SET DIR("A")="FISCAL YEAR NOT SET-UP IN PAYMENT FILE. RE-ENTER"
+3 ;Begin Y2k fix IHS/DSD/HJT 1/23/1999
+4 ; Asking for 2 digit year to lookup in file. Ch anged to 4 digit.
+5 ;Y2000
SET DIR(0)="F^4:4"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
SET X="^"
+8 ;Y2000
IF X'?4N
WRITE *7
GOTO ASKYR
+9 ;End Y2k fix
+10 SET AFSLFY=X
+11 QUIT
