- AFSLRTT1 ;IHS/OIRM/OKCRDC/JDM - PROGRAM TO RE-EXPORT TREASURY TAPE #2; [ 09/27/2005 5:01 PM ]
- ;;3.0t1;1166 APPROVALS FOR PAYMENT;**19**;AUG 31, 2005
- ;Modified for Y2k compliance 12/24/98HJT
- ;Re-export U.S. treasury tape - part 2
- 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
- ;Begin Y2k fix
- ;Create a 4-digit year for lookup in ^AFSLAFP 12/24/98HJT
- S AFSLFY=$E(Y,1,3)+1700 ;Y2000
- ;S AFSLFY=$E(Y,2,3)
- ;End of Y2k fix
- 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
- AFSLRTT1 ;IHS/OIRM/OKCRDC/JDM - PROGRAM TO RE-EXPORT TREASURY TAPE #2; [ 09/27/2005 5:01 PM ]
- +1 ;;3.0t1;1166 APPROVALS FOR PAYMENT;**19**;AUG 31, 2005
- +2 ;Modified for Y2k compliance 12/24/98HJT
- +3 ;Re-export U.S. treasury tape - part 2
- +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 ;Begin Y2k fix
- +11 ;Create a 4-digit year for lookup in ^AFSLAFP 12/24/98HJT
- +12 ;Y2000
- SET AFSLFY=$EXTRACT(Y,1,3)+1700
- +13 ;S AFSLFY=$E(Y,2,3)
- +14 ;End of Y2k fix
- 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
