AFSLRTTX ;IHS/OIRM/OKCRDC/JDM - PROGRAM TO RE-EXPORT TREASURY TAPE #2; [ 09/27/2005 5:29 PM ]
;;1.0V1;1166 APPROVALS FOR PAYMENT;**3,19**;MAY 06, 1994
;Re-export U.S. treasury tape - part 2
;ACR*2.1*19.05 IM16848 - RENAME LINE TAG ON FIRST LINE
S (AFSL1,AFSLEMSG,AFSLFLG1,AFSL1A,AFSL2,AFSL3,AFSL4,AFSL5,AFSLSCH1,AFSLFYN,AFSLSEQ,AFSLSEQ1,AFSLCNT,AFSLAMT,AFSLVFU)=0
ASK ;fy and payment type prompts
U IO(0)
D ^XBCLS
S DY=15,DX=16 X XY
K DIR
S DIR(0)="D"
S DIR("A")="ENTER THE EXPORT DATE YOU WISH TO RE-EXPORT"
S DIR("?")="^S DIC=""^AFSLAFP("",DIC(0)=""FEQ"",D=""B"",DZ=""??"" D DQ^DICQ"
D ^DIR
I $D(DUOUT)!$D(DTOUT)!$D(DIROUT) S AFSLEFLG=1 Q
;Beginning Y2K fix block
;S AFSLFY=$E(Y,2,3)
S AFSLFY=$E(Y,1,3)+1700 ;Y2000;AEF;ACR*2.0T1*3
;End Y2K fix block
EDAT ;
K DIR("?")
S DIR(0)="DA",DIR("A")="Enter the Effective Date :" D ^DIR I $D(DUOUT) D ^XBCLS W !!,"NO ""^"" ALLOWED" G EDAT
I $D(DTOUT)!$D(DUOUT) G ASK
I $D(DIROUT) S AFSLEFLG=1 Q
S AFSLPDT=$P(Y,".",1)
DEV K IOP
U IO(0) S %ZIS("A")="PRINTER TO PRINT TAPE CONTENTS REPORT: ",%ZIS="" D ^%ZIS S AFSLDEV=IO,AFSLDSL=IOSL
I POP S AFSLEFLG=1 Q
PRC ;loop thru payment type x-ref's
L +^AFSLAFP:10 I '$T W !,"ANOTHER IS ENTERING DATA. YOU CANNOT PROCESS A TREASURY TAPE AT THIS TIME. TRY LATER." S AFSLEFLG=1 Q
S AFSLFYN="",AFSLFYN=$O(^AFSLAFP("B",AFSLFY,AFSLFYN))
S (AFSLEIN,AFSLEIN1)="",(AFSLCBC,AFSLFLG,AFSLCBA,AFSLCNT,AFSLIN)=0 S (AFSLCNT1,AFSLPG)=1
TREAS ;
S DIE="^AFSLAFP(",DIE("NO^")="",DA=AFSLFYN,DR="2//" D ^DIE
S AFSLSH11="0000"_$P(^AFSLAFP(AFSLFYN,2),U,1)
D HDR^AFSLRTT2
F AFSLX="E","G","H" D XREF
D EXDAT
I AFSLEMSG=0,AFSLFLG=1 D TRL^AFSLRTT2,FRD^AFSLRTT3 Q
;E S AFSLEMSG=1
S AFSLEMSG=1
Q
XREF ;
F J=0:0 S AFSLEIN=$O(^AFSLAFP(AFSLX,AFSLEIN)) Q:(AFSLEIN="")!(AFSLEMSG=1) I $D(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN)) D SEIN0
Q
SEIN0 ;
S AFSLSCH1="" F I=1:1 S AFSLSCH1=$O(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN,AFSLSCH1)) D:AFSLSCH1="" GSET Q:(AFSLSCH1="")!(AFSLEMSG=1) D CHK D:AFSLFLG1 SEIN1 S AFSLFLG1=0
Q
I '$D(^AFSLAFP("M",AFSLBN,AFSLFYN,AFSLSCH1)) D TNUM
SEIN1 S AFSLEIN1="" F L=0:0 S AFSLEIN1=$O(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN,AFSLSCH1,AFSLEIN1)) Q:(AFSLEIN1="")!(AFSLEMSG=1) D DCHK^AFSLRTT2 Q:AFSLEMSG=1 D SEIN2
Q
EXDAT ;set export date for schedule
S AFSLSC12="" F V=0:0 S AFSLSC12=$O(AFSLSCH1(AFSLSC12)) Q:AFSLSC12="" S DIE="^AFSLAFP(AFSLFYN,1,",DA(1)=AFSLFYN,DA=AFSLSC12,DR="5///TODAY" D ^DIE L -^AFSLAFP ;UNLOCK 1166 PAYMENTS FILE
Q
SEIN2 Q:('$D(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,0)))!($P(^(0),U,27)["D") S AFSLTT=^(0)
S:$D(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1)) AFSLTT5=^(1)
S:$D(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1)) AFSLTT=AFSLTT_$P(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,21)
S X=$P(AFSLTT,U,11)
S X2="2",X3=10
D COMMA^%DTC
S AFSLTT9=$E(X,1,9)
S AFSLTT9=$J(AFSLTT9,10)
D PDT
S AFSLCBC=AFSLCBC+1,AFSLCBA=AFSLCBA+$P(AFSLTT,U,11)
D GSET1
Q
GSET1 ;module to generate line item payment data
S AFSLTT1A=$S(AFSLX="E":$P(AFSLTT,U,10),1:$P(AFSLTT,U,24))
S AFSLTT2=$S(AFSLX="E":$P(^AUTTVNDR(AFSLTT1A,11),U,1),1:$P(^VA(200,AFSLTT1A,1),U,9))
S AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)=$P(AFSLTT,U,20)_" "_"$"_AFSLTT9_" "_$P(AFSLTT,U,14) S AFSLLG=$L(AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)),AFSLLG=55-AFSLLG
S AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)=AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)_$J("",AFSLLG)
;I AFSLVFU=1,AFSLX["E" S AFSLCBAV=-$P(AFSLTT,U,11) S AFSLCBAV=$P(^AUTTVNDR(AFSLTT1A,11),U,7)-AFSLCBAV S DIE=9999999.11,DA=AFSLTT1A,DR="1107///^S X=AFSLCBAV" D ^DIE
D:AFSLCBC=12 GSET
Q
GSET ;module to generate record total data
Q:AFSLCBC=0
S AFSLCBA=AFSLCBA*100,AFSLCBA=$E(AFSLOO,1,8-$L(AFSLCBA))_AFSLCBA,AFSLCBA=$J(AFSLCBA,8)
S AFSLTT(AFSLTT2,AFSLCNT1,0)=AFSLSH11_"2"
S AFSLTT(AFSLTT2,AFSLCNT1,0)=AFSLTT(AFSLTT2,AFSLCNT1,0)_AFSLTT2_$J("",12-$L(AFSLTT2))_"0"_AFSLCBA_"IHS"_$J("",7)_"B"
;S AFSLTT4=$S(AFSLX="E":$P(^AUTTVNDR(AFSLTT1A,0),U,1),1:$P(^VA(200,AFSLTT1A,0),U,1)),AFSLTT4=AFSLTT4_$J("",35-$L(AFSLTT4)) ;ACR*2.1*19.02 IM16848
S AFSLTT4=$S(AFSLX="E":$P(^AUTTVNDR(AFSLTT1A,0),U,1),1:$$NAME2^ACRFUTL1(AFSLTT1A)) ;ACR*2.1*19.02 IM16848
S AFSLTT4=AFSLTT4_$J("",35-$L(AFSLTT4)) ;ACR*2.1*19.02 IM16848
S AFSLTT(AFSLTT2,AFSLCNT1,0)=AFSLTT(AFSLTT2,AFSLCNT1,0)_AFSLTT4
I AFSLX["E" D VADR^AFSLTT4
I AFSLX'["E" D EADR^AFSLTT4
S AFSLTT(AFSLTT2,AFSLCNT1,2)=AFSLTT(AFSLTT2,AFSLCNT1,2)_$J("",67)_$S(AFSLCBC<10:"0"_AFSLCBC,1:AFSLCBC)
S AFSLCNT=AFSLCNT+1,AFSLAMT=AFSLAMT+AFSLCBA,AFSLCBC=0,AFSLCBA=0
D PRC^AFSLRTT2 K AFSLTT S AFSLCNT1=AFSLCNT1+1
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
S AFSLFLG=1,AFSLFLG1=1,AFSLSCH=$P(AFSLSCH3,U,1),AFSLSCH1(AFSLSCH1)=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),AFSLDFYN=$P(^(1),U,15),AFSLPDNM=$P(^(1),U,7)
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
AFSLRTTX ;IHS/OIRM/OKCRDC/JDM - PROGRAM TO RE-EXPORT TREASURY TAPE #2; [ 09/27/2005 5:29 PM ]
+1 ;;1.0V1;1166 APPROVALS FOR PAYMENT;**3,19**;MAY 06, 1994
+2 ;Re-export U.S. treasury tape - part 2
+3 ;ACR*2.1*19.05 IM16848 - RENAME LINE TAG ON FIRST LINE
+4 SET (AFSL1,AFSLEMSG,AFSLFLG1,AFSL1A,AFSL2,AFSL3,AFSL4,AFSL5,AFSLSCH1,AFSLFYN,AFSLSEQ,AFSLSEQ1,AFSLCNT,AFSLAMT,AFSLVFU)=0
ASK ;fy and payment type prompts
+1 USE IO(0)
+2 DO ^XBCLS
+3 SET DY=15
SET DX=16
XECUTE XY
+4 KILL DIR
+5 SET DIR(0)="D"
+6 SET DIR("A")="ENTER THE EXPORT DATE YOU WISH TO RE-EXPORT"
+7 SET DIR("?")="^S DIC=""^AFSLAFP("",DIC(0)=""FEQ"",D=""B"",DZ=""??"" D DQ^DICQ"
+8 DO ^DIR
+9 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
SET AFSLEFLG=1
QUIT
+10 ;Beginning Y2K fix block
+11 ;S AFSLFY=$E(Y,2,3)
+12 ;Y2000;AEF;ACR*2.0T1*3
SET AFSLFY=$EXTRACT(Y,1,3)+1700
+13 ;End Y2K fix block
EDAT ;
+1 KILL DIR("?")
+2 SET DIR(0)="DA"
SET DIR("A")="Enter the Effective Date :"
DO ^DIR
IF $DATA(DUOUT)
DO ^XBCLS
WRITE !!,"NO ""^"" ALLOWED"
GOTO EDAT
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO ASK
+4 IF $DATA(DIROUT)
SET AFSLEFLG=1
QUIT
+5 SET AFSLPDT=$PIECE(Y,".",1)
DEV KILL IOP
+1 USE IO(0)
SET %ZIS("A")="PRINTER TO PRINT TAPE CONTENTS REPORT: "
SET %ZIS=""
DO ^%ZIS
SET AFSLDEV=IO
SET AFSLDSL=IOSL
+2 IF POP
SET AFSLEFLG=1
QUIT
PRC ;loop thru payment type x-ref's
+1 LOCK +^AFSLAFP:10
IF '$TEST
WRITE !,"ANOTHER IS ENTERING DATA. YOU CANNOT PROCESS A TREASURY TAPE AT THIS TIME. TRY LATER."
SET AFSLEFLG=1
QUIT
+2 SET AFSLFYN=""
SET AFSLFYN=$ORDER(^AFSLAFP("B",AFSLFY,AFSLFYN))
+3 SET (AFSLEIN,AFSLEIN1)=""
SET (AFSLCBC,AFSLFLG,AFSLCBA,AFSLCNT,AFSLIN)=0
SET (AFSLCNT1,AFSLPG)=1
TREAS ;
+1 SET DIE="^AFSLAFP("
SET DIE("NO^")=""
SET DA=AFSLFYN
SET DR="2//"
DO ^DIE
+2 SET AFSLSH11="0000"_$PIECE(^AFSLAFP(AFSLFYN,2),U,1)
+3 DO HDR^AFSLRTT2
+4 FOR AFSLX="E","G","H"
DO XREF
+5 DO EXDAT
+6 IF AFSLEMSG=0
IF AFSLFLG=1
DO TRL^AFSLRTT2
DO FRD^AFSLRTT3
QUIT
+7 ;E S AFSLEMSG=1
+8 SET AFSLEMSG=1
+9 QUIT
XREF ;
+1 FOR J=0:0
SET AFSLEIN=$ORDER(^AFSLAFP(AFSLX,AFSLEIN))
IF (AFSLEIN="")!(AFSLEMSG=1)
QUIT
IF $DATA(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN))
DO SEIN0
+2 QUIT
SEIN0 ;
+1 SET AFSLSCH1=""
FOR I=1:1
SET AFSLSCH1=$ORDER(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN,AFSLSCH1))
IF AFSLSCH1=""
DO GSET
IF (AFSLSCH1="")!(AFSLEMSG=1)
QUIT
DO CHK
IF AFSLFLG1
DO SEIN1
SET AFSLFLG1=0
+2 QUIT
+3 IF '$DATA(^AFSLAFP("M",AFSLBN,AFSLFYN,AFSLSCH1))
DO TNUM
SEIN1 SET AFSLEIN1=""
FOR L=0:0
SET AFSLEIN1=$ORDER(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN,AFSLSCH1,AFSLEIN1))
IF (AFSLEIN1="")!(AFSLEMSG=1)
QUIT
DO DCHK^AFSLRTT2
IF AFSLEMSG=1
QUIT
DO SEIN2
+1 QUIT
EXDAT ;set export date for schedule
+1 ;UNLOCK 1166 PAYMENTS FILE
SET AFSLSC12=""
FOR V=0:0
SET AFSLSC12=$ORDER(AFSLSCH1(AFSLSC12))
IF AFSLSC12=""
QUIT
SET DIE="^AFSLAFP(AFSLFYN,1,"
SET DA(1)=AFSLFYN
SET DA=AFSLSC12
SET DR="5///TODAY"
DO ^DIE
LOCK -^AFSLAFP
+2 QUIT
SEIN2 IF ('$DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,0)))!($PIECE(^(0),U,27)["D")
QUIT
SET AFSLTT=^(0)
+1 IF $DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1))
SET AFSLTT5=^(1)
+2 IF $DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1))
SET AFSLTT=AFSLTT_$PIECE(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,21)
+3 SET X=$PIECE(AFSLTT,U,11)
+4 SET X2="2"
SET X3=10
+5 DO COMMA^%DTC
+6 SET AFSLTT9=$EXTRACT(X,1,9)
+7 SET AFSLTT9=$JUSTIFY(AFSLTT9,10)
+8 DO PDT
+9 SET AFSLCBC=AFSLCBC+1
SET AFSLCBA=AFSLCBA+$PIECE(AFSLTT,U,11)
+10 DO GSET1
+11 QUIT
GSET1 ;module to generate line item payment data
+1 SET AFSLTT1A=$SELECT(AFSLX="E":$PIECE(AFSLTT,U,10),1:$PIECE(AFSLTT,U,24))
+2 SET AFSLTT2=$SELECT(AFSLX="E":$PIECE(^AUTTVNDR(AFSLTT1A,11),U,1),1:$PIECE(^VA(200,AFSLTT1A,1),U,9))
+3 SET AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)=$PIECE(AFSLTT,U,20)_" "_"$"_AFSLTT9_" "_$PIECE(AFSLTT,U,14)
SET AFSLLG=$LENGTH(AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0))
SET AFSLLG=55-AFSLLG
+4 SET AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)=AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)_$JUSTIFY("",AFSLLG)
+5 ;I AFSLVFU=1,AFSLX["E" S AFSLCBAV=-$P(AFSLTT,U,11) S AFSLCBAV=$P(^AUTTVNDR(AFSLTT1A,11),U,7)-AFSLCBAV S DIE=9999999.11,DA=AFSLTT1A,DR="1107///^S X=AFSLCBAV" D ^DIE
+6 IF AFSLCBC=12
DO GSET
+7 QUIT
GSET ;module to generate record total data
+1 IF AFSLCBC=0
QUIT
+2 SET AFSLCBA=AFSLCBA*100
SET AFSLCBA=$EXTRACT(AFSLOO,1,8-$LENGTH(AFSLCBA))_AFSLCBA
SET AFSLCBA=$JUSTIFY(AFSLCBA,8)
+3 SET AFSLTT(AFSLTT2,AFSLCNT1,0)=AFSLSH11_"2"
+4 SET AFSLTT(AFSLTT2,AFSLCNT1,0)=AFSLTT(AFSLTT2,AFSLCNT1,0)_AFSLTT2_$JUSTIFY("",12-$LENGTH(AFSLTT2))_"0"_AFSLCBA_"IHS"_$JUSTIFY("",7)_"B"
+5 ;S AFSLTT4=$S(AFSLX="E":$P(^AUTTVNDR(AFSLTT1A,0),U,1),1:$P(^VA(200,AFSLTT1A,0),U,1)),AFSLTT4=AFSLTT4_$J("",35-$L(AFSLTT4)) ;ACR*2.1*19.02 IM16848
+6 ;ACR*2.1*19.02 IM16848
SET AFSLTT4=$SELECT(AFSLX="E":$PIECE(^AUTTVNDR(AFSLTT1A,0),U,1),1:$$NAME2^ACRFUTL1(AFSLTT1A))
+7 ;ACR*2.1*19.02 IM16848
SET AFSLTT4=AFSLTT4_$JUSTIFY("",35-$LENGTH(AFSLTT4))
+8 SET AFSLTT(AFSLTT2,AFSLCNT1,0)=AFSLTT(AFSLTT2,AFSLCNT1,0)_AFSLTT4
+9 IF AFSLX["E"
DO VADR^AFSLTT4
+10 IF AFSLX'["E"
DO EADR^AFSLTT4
+11 SET AFSLTT(AFSLTT2,AFSLCNT1,2)=AFSLTT(AFSLTT2,AFSLCNT1,2)_$JUSTIFY("",67)_$SELECT(AFSLCBC<10:"0"_AFSLCBC,1:AFSLCBC)
+12 SET AFSLCNT=AFSLCNT+1
SET AFSLAMT=AFSLAMT+AFSLCBA
SET AFSLCBC=0
SET AFSLCBA=0
+13 DO PRC^AFSLRTT2
KILL AFSLTT
SET AFSLCNT1=AFSLCNT1+1
+14 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 SET AFSLFLG=1
SET AFSLFLG1=1
SET AFSLSCH=$PIECE(AFSLSCH3,U,1)
SET AFSLSCH1(AFSLSCH1)=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)
SET AFSLDFYN=$PIECE(^(1),U,15)
SET AFSLPDNM=$PIECE(^(1),U,7)
+5 SET DIE="^AFSLODOC("_AFSLDFYN_",1,"_AFSLDNUM_",1,"
+6 SET DA(2)=AFSLDFYN
+7 SET DA(1)=AFSLDNUM
+8 SET DA=AFSLPDNM
+9 SET DR="1////"_AFSLPDT
+10 DO ^DIE
+11 QUIT
