Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AFSLTF1

AFSLTF1.m

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