AFSLTT1 ;IHS/OIRM/DSD/HJT - EXPORT PAYMENT RCDS TO FILE-MODULE #2; [ 09/27/2005 1:32 PM ]
;;3.0t1;1166 APPROVALS FOR PAYMENT;**19**;AUG 31, 2005
;Reviewed for Y2k Compliance. See comment at tag PDT
;Generate unix file for convey of pmts to Treasury - part 2
U IO(0)
D ^XBCLS U IO(0) W "Processing..."
S (AFSL1,AFSLEMSG,AFSLFLG1,AFSL1A,AFSL2,AFSL3,AFSL4,AFSL5,AFSLSCH1,AFSLFYN,AFSLSEQ,AFSLSEQ1,AFSLCNT,AFSLAMT,AFSLIN)=0 S AFSLPG=1
S AFSLFY=AFSLTFY
PRC ;loop thru payment type x-ref's
S AFSLFYN="",AFSLFYN=$O(^AFSLAFP("B",AFSLFY,AFSLFYN))
S (AFSLEIN,AFSLEIN1)="",(AFSLCBC,AFSLFLG,AFSLCBA,AFSLCNT)=0,AFSLCNT1=1
TREAS 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:"
S DIR("?")="Enter six characters"
S DIR("??")="AFSL TREASURY"
D ^DIR S AFSLBN=Y
S AFSLSCDX="0000"_X
I $D(DUOUT)!$D(DTOUT)!$D(DIROUT) U IO(0) W !!,"NO ""^"" ALLOWED" H 2 G TREAS
S DIE="^AFSLAFP(",DA=AFSLFYN,DR="2///"_AFSLBN D ^DIE
S AFSLSH11="0000"_$P(^AFSLAFP(AFSLFYN,2),U,1)
D HDR^AFSLTT2
F AFSLX="E","G","H" D XREF
D EXDAT
I AFSLEMSG=0,AFSLFLG=1 D TRL^AFSLTT2,FRD^AFSLTT3 Q
;E S AFSLEFLG=1
S AFSLEFLG=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
SEIN1 ;
I '$D(^AFSLAFP("M",AFSLBN,AFSLFYN,AFSLSCH1)) D TNUM
S AFSLEIN1="" F L=0:0 S AFSLEIN1=$O(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN,AFSLSCH1,AFSLEIN1)) Q:(AFSLEIN1="")!(AFSLEMSG=1) D DCHK^AFSLTT2 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 THE 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),AFSLVEIX=$P(^(1),U,22)
S X=$P(AFSLTT,U,11)
I $D(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1)) S AFSLTT=AFSLTT_$P(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,21)
;ABOVE AFSLVEIX... ADDED TO LOOKUP VENDOR
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 ; line item payment data
S AFSLTT1A=$S(AFSLX="E":$P(AFSLTT,U,10),1:$P(AFSLTT,U,24))
I '$D(AFSLVEIX) S AFSLVEIX=""
I $L(AFSLVEIX)=10!($L(AFSLVEIX)=12) S AFSLPID=$E(AFSLVEIX,1,10),AFSLPSFX="" S:$L(AFSLVEIX)=12 AFSLPSFX=$E(AFSLVEIX,11,12) D ^AFSLVILU S:Y>0 AFSLTT1A=$P(Y,U,1) ; ADDED TO LOOKUP VENDOR EIN
S AFSLTT2=$S(AFSLX="E":$P(^AUTTVNDR(AFSLTT1A,11),U,13),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 AFSLX["E" S AFSLCBAV=-$P(AFSLTT,U,11),AFSLCBAV=$P(^AUTTVNDR(AFSLTT1A,0),U,10)-AFSLCBAV S DIE=9999999.11,DA=AFSLTT1A,DR="1107///^S X=AFSLCBAV" D ^DIE
;D:AFSLCBC=12 GSET
D GSET
Q
GSET ; 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)),AFSLTT4=$E(AFSLTT4,1,35) ;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 AFSLTT4=$E(AFSLTT4,1,35) ;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^AFSLTT2 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
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
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 ;
;The variable AFSLPDT should be in a fileman format by the time it
; is set into these files here. It was set in AFSLRTT1, AFSLRTTX,
; AFSLEXM1 & AFSLSAV2. No change made here. Should be Y2k compliant.
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
AFSLTT1 ;IHS/OIRM/DSD/HJT - EXPORT PAYMENT RCDS TO FILE-MODULE #2; [ 09/27/2005 1:32 PM ]
+1 ;;3.0t1;1166 APPROVALS FOR PAYMENT;**19**;AUG 31, 2005
+2 ;Reviewed for Y2k Compliance. See comment at tag PDT
+3 ;Generate unix file for convey of pmts to Treasury - part 2
+4 USE IO(0)
+5 DO ^XBCLS
USE IO(0)
WRITE "Processing..."
+6 SET (AFSL1,AFSLEMSG,AFSLFLG1,AFSL1A,AFSL2,AFSL3,AFSL4,AFSL5,AFSLSCH1,AFSLFYN,AFSLSEQ,AFSLSEQ1,AFSLCNT,AFSLAMT,AFSLIN)=0
SET AFSLPG=1
+7 SET AFSLFY=AFSLTFY
PRC ;loop thru payment type x-ref's
+1 SET AFSLFYN=""
SET AFSLFYN=$ORDER(^AFSLAFP("B",AFSLFY,AFSLFYN))
+2 SET (AFSLEIN,AFSLEIN1)=""
SET (AFSLCBC,AFSLFLG,AFSLCBA,AFSLCNT)=0
SET AFSLCNT1=1
TREAS SET AFSLBN=$PIECE(^AFSLAFP(AFSLFYN,2),U,1)+1
+1 SET DIR(0)="F^6:6"
+2 SET DIR("B")=AFSLBN
+3 SET DIR("A")="TREASURY SCHEDULE NUMBER:"
+4 SET DIR("?")="Enter six characters"
+5 SET DIR("??")="AFSL TREASURY"
+6 DO ^DIR
SET AFSLBN=Y
+7 SET AFSLSCDX="0000"_X
+8 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
USE IO(0)
WRITE !!,"NO ""^"" ALLOWED"
HANG 2
GOTO TREAS
+9 SET DIE="^AFSLAFP("
SET DA=AFSLFYN
SET DR="2///"_AFSLBN
DO ^DIE
+10 SET AFSLSH11="0000"_$PIECE(^AFSLAFP(AFSLFYN,2),U,1)
+11 DO HDR^AFSLTT2
+12 FOR AFSLX="E","G","H"
DO XREF
+13 DO EXDAT
+14 IF AFSLEMSG=0
IF AFSLFLG=1
DO TRL^AFSLTT2
DO FRD^AFSLTT3
QUIT
+15 ;E S AFSLEFLG=1
+16 SET AFSLEFLG=1
+17 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
SEIN1 ;
+1 IF '$DATA(^AFSLAFP("M",AFSLBN,AFSLFYN,AFSLSCH1))
DO TNUM
+2 SET AFSLEIN1=""
FOR L=0:0
SET AFSLEIN1=$ORDER(^AFSLAFP(AFSLX,AFSLEIN,AFSLFYN,AFSLSCH1,AFSLEIN1))
IF (AFSLEIN1="")!(AFSLEMSG=1)
QUIT
DO DCHK^AFSLTT2
IF AFSLEMSG=1
QUIT
DO SEIN2
+3 QUIT
EXDAT ;set export date for schedule
+1 ;UNLOCK THE 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 ;
+1 IF ('$DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,0)))!($PIECE(^(0),U,27)["D")
QUIT
SET AFSLTT=^(0)
+2 IF $DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1))
SET AFSLTT5=^(1)
SET AFSLVEIX=$PIECE(^(1),U,22)
+3 SET X=$PIECE(AFSLTT,U,11)
+4 IF $DATA(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1))
SET AFSLTT=AFSLTT_$PIECE(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,21)
+5 ;ABOVE AFSLVEIX... ADDED TO LOOKUP VENDOR
+6 SET X2="2"
SET X3=10
+7 DO COMMA^%DTC
+8 SET AFSLTT9=$EXTRACT(X,1,9)
+9 SET AFSLTT9=$JUSTIFY(AFSLTT9,10)
+10 DO PDT
+11 SET AFSLCBC=AFSLCBC+1
SET AFSLCBA=AFSLCBA+$PIECE(AFSLTT,U,11)
+12 DO GSET1
+13 QUIT
GSET1 ; line item payment data
+1 SET AFSLTT1A=$SELECT(AFSLX="E":$PIECE(AFSLTT,U,10),1:$PIECE(AFSLTT,U,24))
+2 IF '$DATA(AFSLVEIX)
SET AFSLVEIX=""
+3 ; ADDED TO LOOKUP VENDOR EIN
IF $LENGTH(AFSLVEIX)=10!($LENGTH(AFSLVEIX)=12)
SET AFSLPID=$EXTRACT(AFSLVEIX,1,10)
SET AFSLPSFX=""
IF $LENGTH(AFSLVEIX)=12
SET AFSLPSFX=$EXTRACT(AFSLVEIX,11,12)
DO ^AFSLVILU
IF Y>0
SET AFSLTT1A=$PIECE(Y,U,1)
+4 SET AFSLTT2=$SELECT(AFSLX="E":$PIECE(^AUTTVNDR(AFSLTT1A,11),U,13),1:$PIECE(^VA(200,AFSLTT1A,1),U,9))
+5 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
+6 SET AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)=AFSLTT(AFSLTT2,AFSLCNT1,3,AFSLCBC,0)_$JUSTIFY("",AFSLLG)
+7 IF AFSLX["E"
SET AFSLCBAV=-$PIECE(AFSLTT,U,11)
SET AFSLCBAV=$PIECE(^AUTTVNDR(AFSLTT1A,0),U,10)-AFSLCBAV
SET DIE=9999999.11
SET DA=AFSLTT1A
SET DR="1107///^S X=AFSLCBAV"
DO ^DIE
+8 ;D:AFSLCBC=12 GSET
+9 DO GSET
+10 QUIT
GSET ; 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)),AFSLTT4=$E(AFSLTT4,1,35) ;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 ;ACR*2.1*19.02 IM16848
SET AFSLTT4=$EXTRACT(AFSLTT4,1,35)
+9 SET AFSLTT(AFSLTT2,AFSLCNT1,0)=AFSLTT(AFSLTT2,AFSLCNT1,0)_AFSLTT4
+10 IF AFSLX["E"
DO VADR^AFSLTT4
+11 IF AFSLX'["E"
DO EADR^AFSLTT4
+12 SET AFSLTT(AFSLTT2,AFSLCNT1,2)=AFSLTT(AFSLTT2,AFSLCNT1,2)_$JUSTIFY("",67)_$SELECT(AFSLCBC<10:"0"_AFSLCBC,1:AFSLCBC)
+13 SET AFSLCNT=AFSLCNT+1
SET AFSLAMT=AFSLAMT+AFSLCBA
SET AFSLCBC=0
SET AFSLCBA=0
+14 DO PRC^AFSLTT2
KILL AFSLTT
SET AFSLCNT1=AFSLCNT1+1
+15 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
+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 ;The variable AFSLPDT should be in a fileman format by the time it
+2 ; is set into these files here. It was set in AFSLRTT1, AFSLRTTX,
+3 ; AFSLEXM1 & AFSLSAV2. No change made here. Should be Y2k compliant.
+4 SET DIE="^AFSLAFP("_AFSLFYN_",1,"_AFSLSCH1_",1,"
SET DA(2)=AFSLFYN
+5 SET DA(1)=AFSLSCH1
SET DA=AFSLEIN1
SET DR="19////"_AFSLPDT
+6 DO ^DIE
+7 SET AFSLDNUM=$PIECE(^AFSLAFP(AFSLFYN,1,AFSLSCH1,1,AFSLEIN1,1),U,16)
SET AFSLDFYN=$PIECE(^(1),U,15)
SET AFSLPDNM=$PIECE(^(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
