ACRFIRS2 ;IHS/OIRM/DSD/AEF - 1099 RECORD A,B,C,F,T LAYOUTS; [ 07/20/2006 3:48 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**1,6,8,20**;NOV 05, 2001
;
; This routine is called by ACRFIRS1 to format 1099 record data
; into a ^TMP global using the record layouts specified in
; Department of the Treasury Internal Revenue Service
; Publication 1220 Catalog Number 61275P.
; Variables are set by ACRFIRS1.
; Note: All Apha characters must be in upper case
; EXCEPT e-mail addresses that might be case sensitive
Q
;RECORDC, RECORDF, RECORDT SUBROUTINES MOVED TO ACRFIRS0;ACR*2.1*8.07
;
RECORDA(ACRAREA,ACRPMYR,ACRCNTA) ;EP
;----- CREATE RECORD TYPE A (PAYER)
;
;LAYOUT
;1 - 1 "A" 52 - 52 FOREIGN ENTITY INDICATOR
;2 - 5 YEAR 53 - 92 FIRST PAYER NAME LINE
;6 - 11 BLANK 93 -132 SECOND PAYER NAME LINE
;12 - 20 PAYER'S TIN# 133-133 TRANSFER AGENT INDICATOR
;21 - 24 PAYER NAME CONTROL 134-173 PAYER SHIPPING ADDRESS
;25 - 25 LAST FILING INDICATOR 174-213 PAYER CITY
;26 - 26 COMB FED/STATE FILER 214-215 PAYER STATE
;27 - 27 TYPE OF RETURN 216-224 PAYER ZIP CODE
;28 - 41 AMOUNT CODES ;ACR*2.1*8.01
;42 - 47 BLANK ;ARC*2.1*8.01 225-239 PAYER'S PHONE & EXT
;48 - 48 ORIGINAL FILE IND 240-499 BLANK ;ACR*2.1*6.01
;49 - 49 REPLACEMENT FILE IND 500-507 RECORD SEQUENCE # ;ACR*2.1*6.01
;50 - 50 CORRECTION FILE IND 508-748 BLANK ;ACR*2.1*6.01
;51 - 51 BLANK 749-750 BLANK OR CR/LF ;ACR*2.1*6.01
;
; INPUT:
; ACRAREA = PAYER NAME
; ACRPMYR = PAYMENT CALENDAR YEAR
;
; RETURNS:
; ACRCNTA = RECORD A COUNT
;
N DATA,I,X,Z
S DATA=$$UPPER^ACRFUTL(^ACR1099P(ACRAREA,0)) ; ACR*2.1*6.02
S $E(Z)="A"
S $E(Z,2,5)=ACRPMYR
S $E(Z,6,11)=$$PAD^ACRFUTL("","R",6,"")
S $E(Z,12,20)=$P(DATA,U,8)
S $E(Z,21,24)=$$PAD^ACRFUTL($P(DATA,U,9),"R",4,"")
S $E(Z,25)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,26)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,27)="A"
S $E(Z,28,41)=$$PAD^ACRFUTL($P(DATA,U,11),"R",14,"") ;ACR*2.1*8.01
S $E(Z,42,47)=$$PAD^ACRFUTL("","R",6,"") ;ACR*2.1*8.01
;S $E(Z,28,39)=$$PAD^ACRFUTL($P(DATA,U,11),"R",12,"") ;ACR*2.1*20.11 IM19398
;S $E(Z,40,47)=$$PAD^ACRFUTL("","R",8,"") ;ACR*2.1*20.11 IM19398
S $E(Z,48)=1
S $E(Z,49)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,50)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,51)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,52)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,53,92)=$$PAD^ACRFUTL($P(DATA,U,2),"R",40,"")
S $E(Z,93,132)=$$PAD^ACRFUTL($P(DATA,U,3),"R",40,"")
S $E(Z,133)=0
S $E(Z,134,173)=$$PAD^ACRFUTL($P(DATA,U,4),"R",40,"")
S $E(Z,174,213)=$$PAD^ACRFUTL($P(DATA,U,5),"R",40,"")
S $E(Z,214,215)=$P($G(^DIC(5,$P(DATA,U,6),0)),U,2)
S $E(Z,216,224)=$$PAD^ACRFUTL($TR($P(DATA,U,7),"-",""),"R",9,"")
S $E(Z,225,239)=$$PAD^ACRFUTL($P(DATA,U,12),"R",15,"")
S $E(Z,240,499)=$$PAD^ACRFUTL("","R",260,"") ;ACR*2.1*6.01
S $E(Z,500,507)=$$PAD^ACRFUTL(2,"L",8,0) ;"A"RECORD ALWAYS 2 ;ACR*2.1*6.01
S $E(Z,508,748)=$$PAD^ACRFUTL("","R",241,"") ;ACR*2.1*6.01
S $E(Z,749,750)=$$PAD^ACRFUTL("","R",2,"") ;ACR*2.1*6.01
S ACRCNTA=$G(ACRCNTA)+1
;
S ^TMP("ACRZ",$J,"RECORD","A",ACRAREA,1)=$E(Z,1,240)
S ^TMP("ACRZ",$J,"RECORD","A",ACRAREA,2)=$E(Z,241,480)
S ^TMP("ACRZ",$J,"RECORD","A",ACRAREA,3)=$E(Z,481,720)
S ^TMP("ACRZ",$J,"RECORD","A",ACRAREA,4)=$E(Z,721,750)
Q
RECORDB(ACRPMYR,ACRNAME,ACRTIN,ACRVEND0,ACRAMT,ACRAMTCD,ACRADD,ACRCITY,ACRSTAB,ACRZIP,ACRCNTB,ACRTOT,ACRCNTR,ACRFOR) ;EP ;ACR*2.1*6.01,ACR*2.1*8.05
;----- CREATE RECORD TYPE B (PAYEE)
; FOR 1099-MISC
;LAYOUT:
;1 - 1 "B" 247-247 FOREIGN COUNTRY INDICATOR
;2 - 5 PAYMENT YEAR 248-287 FIRST PAYEE NAME LINE
;6 - 6 CORRECTED RETURN IND 288-327 SECOND PAYEE NAME LINE
;7 - 10 NAME CONTROL 328-367 BLANK
;11 - 11 TYPE OF TIN 368-407 PAYEE MAILING ADDRESS
;12 - 20 PAYEE'S TIN 408-447 BLANK
;21 - 40 PAYER'S ACCOUNT NO 448-487 PAYEE CITY
;41 - 44 PAYER'S OFFICE CODE 488-489 PAYEE STATE
;45 - 54 BLANK 490-498 PAYEE ZIP CODE
;55 - 66 PAYMENT AMOUNT 1 499-499 BLANK ;ACR*2.1*6.01
;67 - 78 PAYMENT AMOUNT 2 500-507 RECORD SEQUENCE NUMBER ;ACR*2.1*6.01
;79 - 90 PAYMENT AMOUNT 3 508-543 BLANK ;ACR*2.1*6.01
;91 -102 PAYMENT AMOUNT 4 544-544 SECOND TIN NOTICE (OPTIONAL) ;ACR*2.1*6.01
;103-114 PAYMENT AMOUNT 5 545-546 BLANKS ;ACR*2.1*6.01
;115-126 PAYMENT AMOUNT 6 547-547 DIRECT SALES INDICATOR ;ACR*2.1*6.01
;127-138 PAYMENT AMOUNT 7 545-546 BLANKS
;139-150 PAYMENT AMOUNT 8 547-547 DIRECT SALES INDICATOR
;151-162 PAYMENT AMOUNT 9 548-662 BLANK
;163-174 PAYMENT AMOUNT A 663-722 SPECIAL DATA ENTRIES
;175-186 PAYMENT AMOUNT B ;ACR*2.1*8.02
; 723-734 STATE INCOME TAX WITHHELD
;187-198 PAYMENT AMOUNT C 735-746 LOCAL INCOME TAX WITHHELD
;199-210 PAYMENT AMOUNT D (BLANK FOR 1099) ;ACR*2.1*8.02
; 747-748 COMBINED FEDERAL/STATE CODE
;211-222 PAYMENT AMOUNT E (BLANK FOR 1099) ;ACR*2.1*8.02
; 749-750 BLANK
;223-246 RESERVED (BLANK) ;ACR*2.1*8.02
;
; INPUT:
; ACRPMYR = PAYMENT CALENDAR YEAR
; ACRNAME = PAYEE NAME
; ACRTIN = PAYEE TAX ID NUMBER
; ACRVEND0 = VENDOR IEN
; ACRAMT = PAYMENT AMOUNT
; ACRAMTCD = PAYMENT AMOUNT CODE
; ACRADD = PAYEE ADDRESS
; ACRCITY = PAYEE CITY
; ACRSTAB = PAYEE STATE
; ACRZIP = PAYEE ZIP
; ACRCNTR = RECORD SEQUENCE NUMBER ; ACR*2.1*6.01
;
; RETURNS:
; ACRCNTB = RECORD B COUNT
; ACRCNTR = RECORD SEQUENCE COUNT ; ACR*2.1*6.01
; ACRTOT( = ARRAY CONTAINING PAYMENT AMOUNT CODE TOTALS
;
N I,X,Z,ACRTMP
S ACRCNTR=ACRCNTR+1 ;ACR*2.1*6.01
S $E(Z)="B"
S $E(Z,2,5)=ACRPMYR
S $E(Z,6)=$$PAD^ACRFUTL("","R",1,"") ;corrected return indicator
S $E(Z,7,10)=$$PAD^ACRFUTL($$NCTL^ACRFIRS1(ACRNAME),"R",4,"")
S $E(Z,11)=$E(ACRTIN)
S $E(Z,12,20)=$E(ACRTIN,2,10)
S ACRTMP=$$UPPER^ACRFUTL($G(^AUTTVNDR(ACRVEND0,19))) ;ACR*2.1*6.01
S $E(Z,21,40)=$$PAD^ACRFUTL($P(ACRTMP,U,3),"R",20,"") ;ACR*2.1*6.01
S $E(Z,41,44)=$$PAD^ACRFUTL("","R",4,"")
S $E(Z,45,54)=$$PAD^ACRFUTL("","R",10,"")
S $E(Z,55,198)=$$PAD^ACRFUTL(0,"L",144,0)
S ACRAMT=$$PAD^ACRFUTL(+ACRAMT,"L",12,0)
I ACRAMTCD[1 D
. S ACRTOT(1)=$G(ACRTOT(1))+ACRAMT
. S $E(Z,55,66)=ACRAMT
I ACRAMTCD[2 D
. S ACRTOT(2)=$G(ACRTOT(2))+ACRAMT
. S $E(Z,67,78)=ACRAMT
I ACRAMTCD[3 D
. S ACRTOT(3)=$G(ACRTOT(3))+ACRAMT
. S $E(Z,79,90)=ACRAMT
I ACRAMTCD[4 D
. S ACRTOT(4)=$G(ACRTOT(4))+ACRAMT
. S $E(Z,91,102)=ACRAMT
I ACRAMTCD[5 D
. S ACRTOT(5)=$G(ACRTOT(5))+ACRAMT
. S $E(Z,103,114)=ACRAMT
I ACRAMTCD[6 D
. S ACRTOT(6)=$G(ACRTOT(6))+ACRAMT
. S $E(Z,115,126)=ACRAMT
I ACRAMTCD[7 D
. S ACRTOT(7)=$G(ACRTOT(7))+ACRAMT
. S $E(Z,127,138)=ACRAMT
I ACRAMTCD[8 D
. S ACRTOT(8)=$G(ACRTOT(8))+ACRAMT
. S $E(Z,139,150)=ACRAMT
I ACRAMTCD[9 D
. S ACRTOT(9)=$G(ACRTOT(9))+ACRAMT
. S $E(Z,151,162)=ACRAMT
I ACRAMTCD["A" D
. S ACRTOT("A")=$G(ACRTOT("A"))+ACRAMT
. S $E(Z,163,174)=ACRAMT
I ACRAMTCD["B" D
. S ACRTOT("B")=$G(ACRTOT("B"))+ACRAMT
. S $E(Z,175,186)=ACRAMT
I ACRAMTCD["C" D
. S ACRTOT("C")=$G(ACRTOT("C"))+ACRAMT
. S $E(Z,187,198)=ACRAMT
S $E(Z,199,210)=$$PAD^ACRFUTL("","R",12,"") ;ACR*2.1*8.02
S $E(Z,211,222)=$$PAD^ACRFUTL("","R",12,"") ;ACR*2.1*8.02
S $E(Z,223,246)=$$PAD^ACRFUTL("","R",24,"") ;ACR*2.1*8.02
S $E(Z,247)=$$PAD^ACRFUTL(ACRFOR,"R",1,"") ;ACR*2.1*8.05
S $E(Z,248,287)=$$PAD^ACRFUTL(ACRNAME,"R",40,"")
S $E(Z,288,327)=$$PAD^ACRFUTL("","R",40,"")
S $E(Z,328,367)=$$PAD^ACRFUTL("","R",40,"")
S $E(Z,368,407)=$$PAD^ACRFUTL(ACRADD,"R",40,"")
S $E(Z,408,447)=$$PAD^ACRFUTL("","R",40,"")
S $E(Z,448,487)=$$PAD^ACRFUTL(ACRCITY,"R",40,"")
S $E(Z,488,489)=ACRSTAB
S $E(Z,490,498)=$$PAD^ACRFUTL($TR(ACRZIP,"-",""),"R",9,"")
S $E(Z,499)="" ;ACR*2.1*6.01
S $E(Z,500,507)=$$PAD^ACRFUTL(ACRCNTR,"L",8,0) ;ACR*2.1*6.01
S $E(Z,508,543)=$$PAD^ACRFUTL("","R",36,"") ;ACR*2.1*6.01
S $E(Z,544)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,545,546)=$$PAD^ACRFUTL("","R",2,"")
S $E(Z,547)=$$PAD^ACRFUTL("","R",1,"")
S $E(Z,548,662)=$$PAD^ACRFUTL("","R",115,"")
S $E(Z,663,722)=$$PAD^ACRFUTL("","R",60,"")
S $E(Z,723,734)=$$PAD^ACRFUTL(0,"L",12,0)
S $E(Z,735,746)=$$PAD^ACRFUTL(0,"L",12,0)
S $E(Z,747,748)=$$PAD^ACRFUTL("","R",2,"")
S $E(Z,749,750)=$$PAD^ACRFUTL("","R",2,"")
S ACRCNTB=$G(ACRCNTB)+1
;
S ^TMP("ACRZ",$J,"RECORD","B",ACRAREA,ACRVEND0,1)=$E(Z,1,240)
S ^TMP("ACRZ",$J,"RECORD","B",ACRAREA,ACRVEND0,2)=$E(Z,241,480)
S ^TMP("ACRZ",$J,"RECORD","B",ACRAREA,ACRVEND0,3)=$E(Z,481,720)
S ^TMP("ACRZ",$J,"RECORD","B",ACRAREA,ACRVEND0,4)=$E(Z,721,750)
Q
ACRFIRS2 ;IHS/OIRM/DSD/AEF - 1099 RECORD A,B,C,F,T LAYOUTS; [ 07/20/2006 3:48 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**1,6,8,20**;NOV 05, 2001
+2 ;
+3 ; This routine is called by ACRFIRS1 to format 1099 record data
+4 ; into a ^TMP global using the record layouts specified in
+5 ; Department of the Treasury Internal Revenue Service
+6 ; Publication 1220 Catalog Number 61275P.
+7 ; Variables are set by ACRFIRS1.
+8 ; Note: All Apha characters must be in upper case
+9 ; EXCEPT e-mail addresses that might be case sensitive
+10 QUIT
+11 ;RECORDC, RECORDF, RECORDT SUBROUTINES MOVED TO ACRFIRS0;ACR*2.1*8.07
+12 ;
RECORDA(ACRAREA,ACRPMYR,ACRCNTA) ;EP
+1 ;----- CREATE RECORD TYPE A (PAYER)
+2 ;
+3 ;LAYOUT
+4 ;1 - 1 "A" 52 - 52 FOREIGN ENTITY INDICATOR
+5 ;2 - 5 YEAR 53 - 92 FIRST PAYER NAME LINE
+6 ;6 - 11 BLANK 93 -132 SECOND PAYER NAME LINE
+7 ;12 - 20 PAYER'S TIN# 133-133 TRANSFER AGENT INDICATOR
+8 ;21 - 24 PAYER NAME CONTROL 134-173 PAYER SHIPPING ADDRESS
+9 ;25 - 25 LAST FILING INDICATOR 174-213 PAYER CITY
+10 ;26 - 26 COMB FED/STATE FILER 214-215 PAYER STATE
+11 ;27 - 27 TYPE OF RETURN 216-224 PAYER ZIP CODE
+12 ;28 - 41 AMOUNT CODES ;ACR*2.1*8.01
+13 ;42 - 47 BLANK ;ARC*2.1*8.01 225-239 PAYER'S PHONE & EXT
+14 ;48 - 48 ORIGINAL FILE IND 240-499 BLANK ;ACR*2.1*6.01
+15 ;49 - 49 REPLACEMENT FILE IND 500-507 RECORD SEQUENCE # ;ACR*2.1*6.01
+16 ;50 - 50 CORRECTION FILE IND 508-748 BLANK ;ACR*2.1*6.01
+17 ;51 - 51 BLANK 749-750 BLANK OR CR/LF ;ACR*2.1*6.01
+18 ;
+19 ; INPUT:
+20 ; ACRAREA = PAYER NAME
+21 ; ACRPMYR = PAYMENT CALENDAR YEAR
+22 ;
+23 ; RETURNS:
+24 ; ACRCNTA = RECORD A COUNT
+25 ;
+26 NEW DATA,I,X,Z
+27 ; ACR*2.1*6.02
SET DATA=$$UPPER^ACRFUTL(^ACR1099P(ACRAREA,0))
+28 SET $EXTRACT(Z)="A"
+29 SET $EXTRACT(Z,2,5)=ACRPMYR
+30 SET $EXTRACT(Z,6,11)=$$PAD^ACRFUTL("","R",6,"")
+31 SET $EXTRACT(Z,12,20)=$PIECE(DATA,U,8)
+32 SET $EXTRACT(Z,21,24)=$$PAD^ACRFUTL($PIECE(DATA,U,9),"R",4,"")
+33 SET $EXTRACT(Z,25)=$$PAD^ACRFUTL("","R",1,"")
+34 SET $EXTRACT(Z,26)=$$PAD^ACRFUTL("","R",1,"")
+35 SET $EXTRACT(Z,27)="A"
+36 ;ACR*2.1*8.01
SET $EXTRACT(Z,28,41)=$$PAD^ACRFUTL($PIECE(DATA,U,11),"R",14,"")
+37 ;ACR*2.1*8.01
SET $EXTRACT(Z,42,47)=$$PAD^ACRFUTL("","R",6,"")
+38 ;S $E(Z,28,39)=$$PAD^ACRFUTL($P(DATA,U,11),"R",12,"") ;ACR*2.1*20.11 IM19398
+39 ;S $E(Z,40,47)=$$PAD^ACRFUTL("","R",8,"") ;ACR*2.1*20.11 IM19398
+40 SET $EXTRACT(Z,48)=1
+41 SET $EXTRACT(Z,49)=$$PAD^ACRFUTL("","R",1,"")
+42 SET $EXTRACT(Z,50)=$$PAD^ACRFUTL("","R",1,"")
+43 SET $EXTRACT(Z,51)=$$PAD^ACRFUTL("","R",1,"")
+44 SET $EXTRACT(Z,52)=$$PAD^ACRFUTL("","R",1,"")
+45 SET $EXTRACT(Z,53,92)=$$PAD^ACRFUTL($PIECE(DATA,U,2),"R",40,"")
+46 SET $EXTRACT(Z,93,132)=$$PAD^ACRFUTL($PIECE(DATA,U,3),"R",40,"")
+47 SET $EXTRACT(Z,133)=0
+48 SET $EXTRACT(Z,134,173)=$$PAD^ACRFUTL($PIECE(DATA,U,4),"R",40,"")
+49 SET $EXTRACT(Z,174,213)=$$PAD^ACRFUTL($PIECE(DATA,U,5),"R",40,"")
+50 SET $EXTRACT(Z,214,215)=$PIECE($GET(^DIC(5,$PIECE(DATA,U,6),0)),U,2)
+51 SET $EXTRACT(Z,216,224)=$$PAD^ACRFUTL($TRANSLATE($PIECE(DATA,U,7),"-",""),"R",9,"")
+52 SET $EXTRACT(Z,225,239)=$$PAD^ACRFUTL($PIECE(DATA,U,12),"R",15,"")
+53 ;ACR*2.1*6.01
SET $EXTRACT(Z,240,499)=$$PAD^ACRFUTL("","R",260,"")
+54 ;"A"RECORD ALWAYS 2 ;ACR*2.1*6.01
SET $EXTRACT(Z,500,507)=$$PAD^ACRFUTL(2,"L",8,0)
+55 ;ACR*2.1*6.01
SET $EXTRACT(Z,508,748)=$$PAD^ACRFUTL("","R",241,"")
+56 ;ACR*2.1*6.01
SET $EXTRACT(Z,749,750)=$$PAD^ACRFUTL("","R",2,"")
+57 SET ACRCNTA=$GET(ACRCNTA)+1
+58 ;
+59 SET ^TMP("ACRZ",$JOB,"RECORD","A",ACRAREA,1)=$EXTRACT(Z,1,240)
+60 SET ^TMP("ACRZ",$JOB,"RECORD","A",ACRAREA,2)=$EXTRACT(Z,241,480)
+61 SET ^TMP("ACRZ",$JOB,"RECORD","A",ACRAREA,3)=$EXTRACT(Z,481,720)
+62 SET ^TMP("ACRZ",$JOB,"RECORD","A",ACRAREA,4)=$EXTRACT(Z,721,750)
+63 QUIT
RECORDB(ACRPMYR,ACRNAME,ACRTIN,ACRVEND0,ACRAMT,ACRAMTCD,ACRADD,ACRCITY,ACRSTAB,ACRZIP,ACRCNTB,ACRTOT,ACRCNTR,ACRFOR) ;EP ;ACR*2.1*6.01,ACR*2.1*8.05
+1 ;----- CREATE RECORD TYPE B (PAYEE)
+2 ; FOR 1099-MISC
+3 ;LAYOUT:
+4 ;1 - 1 "B" 247-247 FOREIGN COUNTRY INDICATOR
+5 ;2 - 5 PAYMENT YEAR 248-287 FIRST PAYEE NAME LINE
+6 ;6 - 6 CORRECTED RETURN IND 288-327 SECOND PAYEE NAME LINE
+7 ;7 - 10 NAME CONTROL 328-367 BLANK
+8 ;11 - 11 TYPE OF TIN 368-407 PAYEE MAILING ADDRESS
+9 ;12 - 20 PAYEE'S TIN 408-447 BLANK
+10 ;21 - 40 PAYER'S ACCOUNT NO 448-487 PAYEE CITY
+11 ;41 - 44 PAYER'S OFFICE CODE 488-489 PAYEE STATE
+12 ;45 - 54 BLANK 490-498 PAYEE ZIP CODE
+13 ;55 - 66 PAYMENT AMOUNT 1 499-499 BLANK ;ACR*2.1*6.01
+14 ;67 - 78 PAYMENT AMOUNT 2 500-507 RECORD SEQUENCE NUMBER ;ACR*2.1*6.01
+15 ;79 - 90 PAYMENT AMOUNT 3 508-543 BLANK ;ACR*2.1*6.01
+16 ;91 -102 PAYMENT AMOUNT 4 544-544 SECOND TIN NOTICE (OPTIONAL) ;ACR*2.1*6.01
+17 ;103-114 PAYMENT AMOUNT 5 545-546 BLANKS ;ACR*2.1*6.01
+18 ;115-126 PAYMENT AMOUNT 6 547-547 DIRECT SALES INDICATOR ;ACR*2.1*6.01
+19 ;127-138 PAYMENT AMOUNT 7 545-546 BLANKS
+20 ;139-150 PAYMENT AMOUNT 8 547-547 DIRECT SALES INDICATOR
+21 ;151-162 PAYMENT AMOUNT 9 548-662 BLANK
+22 ;163-174 PAYMENT AMOUNT A 663-722 SPECIAL DATA ENTRIES
+23 ;175-186 PAYMENT AMOUNT B ;ACR*2.1*8.02
+24 ; 723-734 STATE INCOME TAX WITHHELD
+25 ;187-198 PAYMENT AMOUNT C 735-746 LOCAL INCOME TAX WITHHELD
+26 ;199-210 PAYMENT AMOUNT D (BLANK FOR 1099) ;ACR*2.1*8.02
+27 ; 747-748 COMBINED FEDERAL/STATE CODE
+28 ;211-222 PAYMENT AMOUNT E (BLANK FOR 1099) ;ACR*2.1*8.02
+29 ; 749-750 BLANK
+30 ;223-246 RESERVED (BLANK) ;ACR*2.1*8.02
+31 ;
+32 ; INPUT:
+33 ; ACRPMYR = PAYMENT CALENDAR YEAR
+34 ; ACRNAME = PAYEE NAME
+35 ; ACRTIN = PAYEE TAX ID NUMBER
+36 ; ACRVEND0 = VENDOR IEN
+37 ; ACRAMT = PAYMENT AMOUNT
+38 ; ACRAMTCD = PAYMENT AMOUNT CODE
+39 ; ACRADD = PAYEE ADDRESS
+40 ; ACRCITY = PAYEE CITY
+41 ; ACRSTAB = PAYEE STATE
+42 ; ACRZIP = PAYEE ZIP
+43 ; ACRCNTR = RECORD SEQUENCE NUMBER ; ACR*2.1*6.01
+44 ;
+45 ; RETURNS:
+46 ; ACRCNTB = RECORD B COUNT
+47 ; ACRCNTR = RECORD SEQUENCE COUNT ; ACR*2.1*6.01
+48 ; ACRTOT( = ARRAY CONTAINING PAYMENT AMOUNT CODE TOTALS
+49 ;
+50 NEW I,X,Z,ACRTMP
+51 ;ACR*2.1*6.01
SET ACRCNTR=ACRCNTR+1
+52 SET $EXTRACT(Z)="B"
+53 SET $EXTRACT(Z,2,5)=ACRPMYR
+54 ;corrected return indicator
SET $EXTRACT(Z,6)=$$PAD^ACRFUTL("","R",1,"")
+55 SET $EXTRACT(Z,7,10)=$$PAD^ACRFUTL($$NCTL^ACRFIRS1(ACRNAME),"R",4,"")
+56 SET $EXTRACT(Z,11)=$EXTRACT(ACRTIN)
+57 SET $EXTRACT(Z,12,20)=$EXTRACT(ACRTIN,2,10)
+58 ;ACR*2.1*6.01
SET ACRTMP=$$UPPER^ACRFUTL($GET(^AUTTVNDR(ACRVEND0,19)))
+59 ;ACR*2.1*6.01
SET $EXTRACT(Z,21,40)=$$PAD^ACRFUTL($PIECE(ACRTMP,U,3),"R",20,"")
+60 SET $EXTRACT(Z,41,44)=$$PAD^ACRFUTL("","R",4,"")
+61 SET $EXTRACT(Z,45,54)=$$PAD^ACRFUTL("","R",10,"")
+62 SET $EXTRACT(Z,55,198)=$$PAD^ACRFUTL(0,"L",144,0)
+63 SET ACRAMT=$$PAD^ACRFUTL(+ACRAMT,"L",12,0)
+64 IF ACRAMTCD[1
Begin DoDot:1
+65 SET ACRTOT(1)=$GET(ACRTOT(1))+ACRAMT
+66 SET $EXTRACT(Z,55,66)=ACRAMT
End DoDot:1
+67 IF ACRAMTCD[2
Begin DoDot:1
+68 SET ACRTOT(2)=$GET(ACRTOT(2))+ACRAMT
+69 SET $EXTRACT(Z,67,78)=ACRAMT
End DoDot:1
+70 IF ACRAMTCD[3
Begin DoDot:1
+71 SET ACRTOT(3)=$GET(ACRTOT(3))+ACRAMT
+72 SET $EXTRACT(Z,79,90)=ACRAMT
End DoDot:1
+73 IF ACRAMTCD[4
Begin DoDot:1
+74 SET ACRTOT(4)=$GET(ACRTOT(4))+ACRAMT
+75 SET $EXTRACT(Z,91,102)=ACRAMT
End DoDot:1
+76 IF ACRAMTCD[5
Begin DoDot:1
+77 SET ACRTOT(5)=$GET(ACRTOT(5))+ACRAMT
+78 SET $EXTRACT(Z,103,114)=ACRAMT
End DoDot:1
+79 IF ACRAMTCD[6
Begin DoDot:1
+80 SET ACRTOT(6)=$GET(ACRTOT(6))+ACRAMT
+81 SET $EXTRACT(Z,115,126)=ACRAMT
End DoDot:1
+82 IF ACRAMTCD[7
Begin DoDot:1
+83 SET ACRTOT(7)=$GET(ACRTOT(7))+ACRAMT
+84 SET $EXTRACT(Z,127,138)=ACRAMT
End DoDot:1
+85 IF ACRAMTCD[8
Begin DoDot:1
+86 SET ACRTOT(8)=$GET(ACRTOT(8))+ACRAMT
+87 SET $EXTRACT(Z,139,150)=ACRAMT
End DoDot:1
+88 IF ACRAMTCD[9
Begin DoDot:1
+89 SET ACRTOT(9)=$GET(ACRTOT(9))+ACRAMT
+90 SET $EXTRACT(Z,151,162)=ACRAMT
End DoDot:1
+91 IF ACRAMTCD["A"
Begin DoDot:1
+92 SET ACRTOT("A")=$GET(ACRTOT("A"))+ACRAMT
+93 SET $EXTRACT(Z,163,174)=ACRAMT
End DoDot:1
+94 IF ACRAMTCD["B"
Begin DoDot:1
+95 SET ACRTOT("B")=$GET(ACRTOT("B"))+ACRAMT
+96 SET $EXTRACT(Z,175,186)=ACRAMT
End DoDot:1
+97 IF ACRAMTCD["C"
Begin DoDot:1
+98 SET ACRTOT("C")=$GET(ACRTOT("C"))+ACRAMT
+99 SET $EXTRACT(Z,187,198)=ACRAMT
End DoDot:1
+100 ;ACR*2.1*8.02
SET $EXTRACT(Z,199,210)=$$PAD^ACRFUTL("","R",12,"")
+101 ;ACR*2.1*8.02
SET $EXTRACT(Z,211,222)=$$PAD^ACRFUTL("","R",12,"")
+102 ;ACR*2.1*8.02
SET $EXTRACT(Z,223,246)=$$PAD^ACRFUTL("","R",24,"")
+103 ;ACR*2.1*8.05
SET $EXTRACT(Z,247)=$$PAD^ACRFUTL(ACRFOR,"R",1,"")
+104 SET $EXTRACT(Z,248,287)=$$PAD^ACRFUTL(ACRNAME,"R",40,"")
+105 SET $EXTRACT(Z,288,327)=$$PAD^ACRFUTL("","R",40,"")
+106 SET $EXTRACT(Z,328,367)=$$PAD^ACRFUTL("","R",40,"")
+107 SET $EXTRACT(Z,368,407)=$$PAD^ACRFUTL(ACRADD,"R",40,"")
+108 SET $EXTRACT(Z,408,447)=$$PAD^ACRFUTL("","R",40,"")
+109 SET $EXTRACT(Z,448,487)=$$PAD^ACRFUTL(ACRCITY,"R",40,"")
+110 SET $EXTRACT(Z,488,489)=ACRSTAB
+111 SET $EXTRACT(Z,490,498)=$$PAD^ACRFUTL($TRANSLATE(ACRZIP,"-",""),"R",9,"")
+112 ;ACR*2.1*6.01
SET $EXTRACT(Z,499)=""
+113 ;ACR*2.1*6.01
SET $EXTRACT(Z,500,507)=$$PAD^ACRFUTL(ACRCNTR,"L",8,0)
+114 ;ACR*2.1*6.01
SET $EXTRACT(Z,508,543)=$$PAD^ACRFUTL("","R",36,"")
+115 SET $EXTRACT(Z,544)=$$PAD^ACRFUTL("","R",1,"")
+116 SET $EXTRACT(Z,545,546)=$$PAD^ACRFUTL("","R",2,"")
+117 SET $EXTRACT(Z,547)=$$PAD^ACRFUTL("","R",1,"")
+118 SET $EXTRACT(Z,548,662)=$$PAD^ACRFUTL("","R",115,"")
+119 SET $EXTRACT(Z,663,722)=$$PAD^ACRFUTL("","R",60,"")
+120 SET $EXTRACT(Z,723,734)=$$PAD^ACRFUTL(0,"L",12,0)
+121 SET $EXTRACT(Z,735,746)=$$PAD^ACRFUTL(0,"L",12,0)
+122 SET $EXTRACT(Z,747,748)=$$PAD^ACRFUTL("","R",2,"")
+123 SET $EXTRACT(Z,749,750)=$$PAD^ACRFUTL("","R",2,"")
+124 SET ACRCNTB=$GET(ACRCNTB)+1
+125 ;
+126 SET ^TMP("ACRZ",$JOB,"RECORD","B",ACRAREA,ACRVEND0,1)=$EXTRACT(Z,1,240)
+127 SET ^TMP("ACRZ",$JOB,"RECORD","B",ACRAREA,ACRVEND0,2)=$EXTRACT(Z,241,480)
+128 SET ^TMP("ACRZ",$JOB,"RECORD","B",ACRAREA,ACRVEND0,3)=$EXTRACT(Z,481,720)
+129 SET ^TMP("ACRZ",$JOB,"RECORD","B",ACRAREA,ACRVEND0,4)=$EXTRACT(Z,721,750)
+130 QUIT
