ACRFIRS6 ;IHS/OIRM/DSD/AEF - PRINT 1099s [ 07/24/2002 3:17 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**1,3**;NOV 05, 2001
;
EN ;EP -- PRINT ALL VENDOR 1099S
;
N ACRLOC,ACRYR,ZTSAVE
;
D HOME^%ZIS
D ^XBKVAR
;
D LOC(.ACRLOC)
Q:'$G(ACRLOC)
;
D YR(.ACRYR)
Q:'$G(ACRYR)
;
S ZTSAVE("ACRLOC")=""
S ZTSAVE("ACRYR")=""
D QUE^ACRFUTL("DQ^ACRFIRS6",.ZTSAVE,"PRINT 1099s")
;
D ^%ZISC
Q
DQ ;EP -- QUEUED JOB STARTS HERE
;
; INCOMING VARIABLES:
; ACRLOC = PAYER IEN
; ACRYR = CALENDAR YEAR
;
; OTHER VARIABLES USED:
; ACRTAMT = ARRAY CONTAINING AMOUNT TOTALS BY TYPE CODE
; ACRTCNT = ARRAY CONTAINING VENDOR COUNT BY TYPE CODE
;
N ACRTAMT,ACRTCNT
;
D ^XBKVAR
;
D LOOP(ACRLOC,ACRYR,.ACRTAMT,.ACRTCNT)
;
D TOTALS(.ACRTAMT,.ACRTCNT)
;
K ACRLOC,ACRYR
;
D ^%ZISC
Q
LOOP(ACRLOC,ACRYR,ACRTAMT,ACRTCNT) ;
;----- LOOP THROUGH ARMS VENDOR FILE AND PRINT 1099s
;
; INPUT:
; ACRLOC = PAYER IEN
; ACRYR = CALENDAR YEAR
;
; RETURNS:
; ACRTAMT = ARRAY CONTAINING PAYMENT AMOUNTS BY TYPE CODE
; ACRTCNT = ARRAY CONTAINING VENDOR COUNTS BY TYPE CODE
;
N ACRCNT,ACRNAME,ACRVEN
;
K ^TMP("ACR1099",$J)
;
D ALPHA(ACRYR)
Q:'$D(^TMP("ACR1099",$J))
;
S ACRCNT=0
S ACRNAME=""
F S ACRNAME=$O(^TMP("ACR1099",$J,ACRNAME)) Q:ACRNAME']"" D
. S ACRVEN=0 F S ACRVEN=$O(^TMP("ACR1099",$J,ACRNAME,ACRVEN)) Q:'ACRVEN D
. . Q:$$AMT(ACRVEN,ACRYR)<600
. . S ACRCNT=ACRCNT+1
. . I ACRCNT>1,ACRCNT#2 W @IOF
. . D PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,.ACRTAMT,.ACRTCNT)
. . D UPDATE(ACRVEN,ACRYR)
;
K ^TMP("ACR1099",$J)
Q
ALPHA(ACRYR) ;
;----- BUILD ALPHABETIC ARRAY OF VENDORS IN ^TMP("ACR1099",$J)
;
; INPUT:
; ACRYR = CALENDAR YEAR
;
N ACRNAME,ACRVEN
S ACRVEN=0
F S ACRVEN=$O(^ACR1099V("C",ACRYR,ACRVEN)) Q:'ACRVEN D
. S ACRNAME=$P(^AUTTVNDR(ACRVEN,0),U)
. S ^TMP("ACR1099",$J,ACRNAME,ACRVEN)=0
Q
PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,ACRTAMT,ACRTCNT) ;
;----- PRINT VENDOR 1099
;
; INPUT:
; ACRVEN = VENDOR IEN
; ACRLOC = PAYER IEN
; ACRYR = CALENDAR YEAR
;
; RETURNS:
; ACRTAMT = ARRAY CONTAINING AMOUNT TOTALS BY TYPE CODE
; ACRTCNT = ARRAY CONTAINING COUNT TOTALS BY TYPE CODE
;
; VARIABLES SET AND USED BY THIS SUBROUTINE:
; ACRAMT = ARRAY CONTAINING PAYMENT AMOUNTS BY TYPE CODE
; ACRCOR = CORRECTED RETURN INDICATOR
; ACRIRS = PAYER IRS NAME
; ACRPADD = ARRAY CONTAINING PAYER ADDRESS
; ACRPSN = PAYER STATE NUMBER
; ACRPTIN = PAYER TAX ID NUMBER
; ACRTYP = PAYMENT TYPE CODE
; ACRVADD = ARRAY CONTAINING VENDOR ADDRESS
; ACRVTIN = VENDOR TAX ID NUMBER
;
;
;----- SET VARIABLES
;
N ACRAMT,ACRCOR,ACRIRS,ACRPADD,ACRPSN,ACRPTIN,ACRTYP,ACRVADD,ACRVTIN,DATA
I '$D(^ACR1099V(ACRVEN,1,ACRYR)) D Q ;ACR*2.1*3.30
. W !,"NO DATA FOUND" ;ACR*2.1*3.30
;
F I=1:1:8,"A","B","C" S ACRAMT(I)=""
S ACRCOR=""
I $P($G(^ACR1099V(ACRVEN,1,ACRYR,0)),U,6)="Y" S ACRCOR="X"
S DATA=^ACR1099V(ACRVEN,0)
S ACRTYP=$P(DATA,U,2)
S ACRIRS=$P(DATA,U,3)
S ACRAMT(ACRTYP)=$$AMT(ACRVEN,ACRYR)
D PADD(ACRLOC,.ACRPADD)
D VADD(ACRVEN,ACRIRS,.ACRVADD)
S ACRPTIN=$P(^ACR1099P(ACRLOC,0),U,8)
S ACRVTIN=$E($P(^AUTTVNDR(ACRVEN,11),U),2,10)
S ACRPSN=$P($G(^ACR1099P(ACRLOC,1)),U)
;
;----- PRINT INDIVIDUAL LINES
;
;LINE2 BLANK
;W !
;
;LINE3 CORRECTED RETURN INDICATOR
;W !
W ?30,ACRCOR
;
;LINE4 BLANK
W !
;
;LINE5 PAYER'S NAME
W !
W ?5,ACRPADD(1)
;
;LINE6 PAYER'S ADDRESS LINE 1 / RENTS AMOUNT
W !
W ?5,ACRPADD(2)
W ?39,$J(ACRAMT(1),12,2)
;
;LINE7 PAYER'S ADDRESS LINE 2
W !
W ?5,ACRPADD(3)
;
;LINE8 PAYER'S CITY,STATE,ZIP
W !
W ?5,ACRPADD(4)
;
;LINE9 ROYALTIES AMOUNT
W !
W ?39,$J(ACRAMT(2),12,2)
;
;LINE10 BLANK
W !
;
;LINE11 OTHER INCOME AMOUNT / FEDERAL INCOME TAX WHLD AMOUNT
W !
W ?39,$J(ACRAMT(3),12,2)
W ?53,$J(ACRAMT(4),12,2)
;
;LINE12 BLANK
W !
;
;LINE13 BLANK
W !
;
;LINE14 BLANK
W !
;
;LINE15 PAYER TIN / PAYEE TIN / FISHING BOAT AMOUNT / MEDICAL AMOUNT
W !
W ?5,ACRPTIN
W ?25,ACRVTIN
W ?39,$J(ACRAMT(5),12,2)
W ?53,$J(ACRAMT(6),12,2)
;
;LINE16 BLANK
W !
;
;LINE17 PAYEE'S NAME
W !
W ?5,ACRVADD(1)
;
;LINE18 BLANK
W !
;
;LINE19 NONEMPLOYEE COMP AMOUNT / SUBSTITUTE PMT AMOUNT
W !
W ?39,$J(ACRAMT(7),12,2)
W ?53,$J(ACRAMT(8),12,2)
;
;LINE20 BLANK
W !
;
;LINE21 PAYEE ADDRESS LINE 1
W !
W ?5,ACRVADD(2)
;
;LINE22 PAYEE ADDRESS LINE 2 / CROP INSURANCE AMOUNT
W !
W ?5,ACRVADD(3)
W ?53,$J(ACRAMT("A"),12,2)
;
;LINE23 BLANK
W !
;
;LINE24 PAYEE CITY,STATE,ZIP
W !
W ?5,ACRVADD(4)
;
;LINE25 BLANK
W !
;
;LINE26 BLANK
W !
;
;LINE27 GOLDEN PARACHUTE AMOUNT / PROCEEDS TO ATTORNEY AMOUNT
W !
W ?39,$J(ACRAMT("B"),12,2)
W ?53,$J(ACRAMT("C"),12,2)
;
;LINE28 BLANK
W !
;
;LINE29 STATE/PAYER'S STATE NO.
W !
W ?55,ACRPSN
;
;LINE30 BLANK
W !
;
I $G(ACRCNT)#2 F I=1:1:6 W !
;
;----- SET DOLLAR AMOUNT ARRAY
;
S ACRTAMT(ACRTYP)=$G(ACRTAMT(ACRTYP))+ACRAMT(ACRTYP)
S ACRTCNT(ACRTYP)=$G(ACRTCNT(ACRTYP))+1
Q
LOC(ACRLOC) ;
;----- ASK FINANCE LOCATION
;
; RETURNS:
; ACRLOC = PAYER IEN
;
N DIC,DTOUT,DUOUT,X,Y
S DIC="^ACR1099P("
S DIC(0)="AEMQ"
S DIC("A")="Select FINANCE LOCATION: "
D ^DIC
Q:$D(DTOUT)!($D(DUOUT))
Q:+Y'>0
S ACRLOC=+Y
Q
YR(ACRYR) ;
;----- ASK CALENDAR YEAR
;
; RETURNS:
; ACRYR = CALENDAR YEAR
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="N^0000:9999"
S DIR("A")="Select CALENDAR YEAR"
S DIR("B")=($E(DT,1,3)+1700)-1
D ^DIR
Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
Q:+Y'>0
S ACRYR=+Y
Q
VEN(ACRVEN) ;
;----- ASK VENDOR
;
; RETURNS:
; ACRVEN = VENDOR IEN
;
N DIC,DTOUT,DUOUT,X,Y
S DIC="^ACR1099V("
S DIC(0)="AEMQ"
S DIC("A")="Select VENDOR: "
D ^DIC
Q:$D(DTOUT)!($D(DUOUT))
Q:+Y'>0
S ACRVEN=+Y
Q
UPDATE(ACRVEN,ACRYR) ;
;----- UPDATE 1099 PRINT DATE FIELD IN ARMS 1099 VENDOR FILE
;
; INPUT:
; ACRVEN = VENDOR IEN
; ACRYR = CALENDAR YEAR
;
N DA,DIE,DR,X,Y
S DA(1)=ACRVEN
S DA=ACRYR
S DIE="^ACR1099V("_DA(1)_",1,"
S DR=".05////"_DT
D ^DIE
Q
ONE ;EP -- PRINT ONE VENDOR 1099
;
N ACRLOC,ACRVEN,ACRYR,ZTSAVE
;
D HOME^%ZIS
D ^XBKVAR
;
D LOC(.ACRLOC)
Q:'$G(ACRLOC)
;
D YR(.ACRYR)
Q:'$G(ACRYR)
;
D VEN(.ACRVEN)
Q:'$G(ACRVEN)
;
S ZTSAVE("ACRLOC")=""
S ZTSAVE("ACRYR")=""
S ZTSAVE("ACRVEN")=""
D QUE^ACRFUTL("DQ1^ACRFIRS6",.ZTSAVE,"PRINT ONE 1099")
;
D ^%ZISC
Q
DQ1 ;EP -- QUEUED JOB STARTS HERE
;
; INPUT:
; ACRLOC = PAYER IEN
; ACRVEN = VENDOR IEN
; ACRYR = CALENDAR YEAR
;
N ACRMTOT,ACRMAMT,ACRNTOT,ACRNAMT
;
W @IOF
;
D ^XBKVAR
;
D PRT(ACRVEN,ACRLOC,ACRYR,$G(ACRCNT),.ACRTAMT,.ACRTCNT)
;
D TOTALS(.ACRTAMT,.ACRTCNT)
;
D ^%ZISC
K ACRLOC,ACRVEN,ACRYR
Q
TEST ;EP -- PRINT TEST 1099s
;
N ACRLOC,ACRYR,ZTSAVE
;
D ^XBKVAR
;
D LOC(.ACRLOC)
Q:'$G(ACRLOC)
;
D YR(.ACRYR)
Q:'$G(ACRYR)
;
S ZTSAVE("ACRLOC")=""
S ZTSAVE("ACRYR")=""
D QUE^ACRFUTL("DQ2^ACRFIRS6",.ZTSAVE,"PRINT TEST 1099s")
;
D ^%ZISC
Q
DQ2 ;EP -- QUEUED JOB STARTS HERE
;
; INPUT:
; ACRLOC = PAYER IEN
; ACRYR = CALENDAR YEAR
;
N ACRTAMT,ACRTCNT,ACRVEN,ACRCNT
;
W @IOF
;
D ^XBKVAR
;
S (ACRVEN,ACRCNT)=0
F Q:ACRCNT>9 S ACRVEN=$O(^ACR1099V("C",ACRYR,ACRVEN)) Q:'ACRVEN D
. S ACRCNT=ACRCNT+1
. Q:ACRCNT>9
. I ACRCNT>1,ACRCNT#2 W @IOF
. D PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,.ACRTAMT,.ACRTCNT)
;
D TOTALS(.ACRTAMT,.ACRTCNT)
;
K ACRLOC,ACRYR
D ^%ZISC
Q
RANGE ;EP -- PRINT RANGE OF VENDOR 1099S
;
N ACRLOC,ACRVEN,ACRYR,ZTSAVE
;
D ^XBKVAR
;
K ^TMP("ACR1099",$J)
;
D LOC(.ACRLOC)
Q:'$G(ACRLOC)
;
D YR(.ACRYR)
Q:'$G(ACRYR)
;
D ALPHA(ACRYR)
I '$D(^TMP("ACR1099",$J)) D G RANGE
. W !,"No Vendor data found for ",ACRYR
;
D VEND(.ACRVEN)
Q:ACRVEN']""
;
S ZTSAVE("ACRLOC")=""
S ZTSAVE("ACRYR")=""
S ZTSAVE("ACRVEN")=""
D QUE^ACRFUTL("DQ3^ACRFIRS6",.ZTSAVE,"PRINT RANGE OF 1099S")
;
D ^%ZISC
Q
DQ3 ;EP -- QUEUED JOB STARTS HERE
;
; INPUT:
; ACRLOC = PAYER IEN
; ACRVEN = VENDOR RANGE
; ACRYR = CALENDAR YEAR
;
N ACRTAMT,ACRTCNT
;
D ^XBKVAR
;
D LOOP3(ACRLOC,ACRYR,ACRVEN,.ACRTAMT,.ACRTCNT)
;
K ACRLOC,ACRYR,ACRVEN
D ^%ZISC
Q
LOOP3(ACRLOC,ACRYR,ACRVEN,ACRTAMT,ACRTCNT) ;
;
; INPUT:
; ACRLOC = PAYER IEN
; ACRVEN = VENDOR RANGE
; ACRYR = CALENDAR YEAR
;
; RETURNS:
; ACRTAMT = ARRAY CONTAINING AMOUNTS BY PAYMENT TYPE CODE
; ACRTCNT = ARRAY CONTAINING VENDOR COUNTS BY PAYMENT TYPE CODE
;
N ACREND,ACRNAME,ACRCNT
;
D ALPHA(ACRYR)
Q:'$D(^TMP("ACR1099",$J))
;
S ACREND=$P(ACRVEN,U,2)
S ACRNAME=$P(ACRVEN,U)
S ACRNAME=$O(^TMP("ACR1099",$J,ACRNAME),-1)
;
S ACRCNT=0
F S ACRNAME=$O(^TMP("ACR1099",$J,ACRNAME)) Q:ACRNAME']"" Q:ACRNAME]ACREND D
. S ACRVEN=0
. F S ACRVEN=$O(^TMP("ACR1099",$J,ACRNAME,ACRVEN)) Q:'ACRVEN D
. . Q:$$AMT(ACRVEN,ACRYR)<600
. . S ACRCNT=ACRCNT+1
. . I ACRCNT>1,ACRCNT#2 W @IOF
. . D PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,.ACRTAMT,.ACRTCNT)
;
D TOTALS(.ACRTAMT,.ACRTCNT)
;
K ^TMP("ACR1099",$J)
Q
VEND(ACRVEN) ;
;----- GETS START AND END VENDORS IN RANGE SELECTION
;
V ; RETURNS:
; ACRVEN = CONTAINS BEGINNING AND ENDING VENDOR NAME RANGE
;
N DIR,X,Y
S ACRVEN=""
S DIR(0)="F"
S DIR("A")="Start with VENDOR"
S DIR("?")="Enter BEGINNING VENDOR in range"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S ACRVEN="" Q
Q:Y']""
S ACRVEN=Y
S DIR("A")="End with VENDOR"
S DIR("?")="Enter ENDING VENDOR in range"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S ACRVEN="" Q
I Y']"" S ACRVEN="" Q
I Y']ACRVEN D G V
. W !,"'",Y,"' does not follow '",ACRVEN,"'"
S ACRVEN=ACRVEN_"^"_Y
Q
TOTALS(ACRTAMT,ACRTCNT) ;
;----- PRINTS GRAND TOTALS
;
; INPUT:
; ACRTAMT = ARRAY CONTAINING AMOUNT TOTALS BY PAYMENT TYPE CODE
; ACRTCNT = ARRAY CONTAINING VENDOR COUNTS BY PAYMENT TYPE CODE
;
W @IOF
;
N ACRGAMT,ACRGCNT,ACRTYP,I
;
S ACRTYP(1)="RENTS"
S ACRTYP(2)="ROYALTIES"
S ACRTYP(3)="OTHER INCOME"
S ACRTYP(4)="FED INC TAX WHLD"
S ACRTYP(5)="FISHING BOAT PROC"
S ACRTYP(6)="MED & HLTH CARE"
S ACRTYP(7)="NONEMPLOYEE COMP"
S ACRTYP(8)="SUBSTITUTE PMTS"
S ACRTYP("A")="CROP INS PROC"
S ACRTYP("B")="EXC GOLD PARA"
S ACRTYP("C")="PROC TO ATTY"
;
F I=1:1:3 W !
;
S (ACRGCNT,ACRGAMT)=0
F I=1:1:8,"A","B","C" D
. ;Q:'$D(ACRTAMT(I))
. W ?5,"TOTAL FOR ",ACRTYP(I)," PMTS:"
. W ?40,$J(+$G(ACRTCNT(I)),4)
. W ?50,$J(+$G(ACRTAMT(I)),12,2)
. S ACRGCNT=$G(ACRGCNT)+$G(ACRTCNT(I))
. S ACRGAMT=$G(ACRGAMT)+$G(ACRTAMT(I))
. W !!
;
W ?40,"----"
W ?50,"------------"
W !
W ?40,$J(ACRGCNT,4)
W ?50,$J(ACRGAMT,12,2)
Q
AMT(ACRVEN,ACRYR) ;
;----- EXTRINSIC FUNCTION TO RETURN DOLLAR AMOUNT
;
N X
S X=$G(^ACR1099V(ACRVEN,1,ACRYR,0))
S Y=$P(X,U,2)
I $P(X,U,6)="Y" S Y=$P(X,U,8)
Q Y
PADD(ACRLOC,ACRPADD) ;
;----- RETURN PAYER'S ADDRESS ARRAY
;
N I,DATA,X
K ACRPADD
F I=1:1:4 S ACRPADD(I)=""
S I=0
S DATA=$G(^ACR1099P(ACRLOC,0))
I $P(DATA,U,2)]"" D
. S I=I+1
. S ACRPADD(I)=$P(DATA,U,2)
I $P(DATA,U,3)]"" D
. S I=I+1
. S ACRPADD(I)=$P(DATA,U,3)
I $P(DATA,U,4)]"" D
. S I=I+1
. S ACRPADD(I)=$P(DATA,U,4)
S X=$P(DATA,U,5)_", "_$P(^DIC(5,$P(DATA,U,6),0),U,2)_" "_$P(DATA,U,7)
S I=I+1
S ACRPADD(I)=X
Q
VADD(ACRVEN,ACRIRS,ACRVADD) ;
;----- RETURN VENDOR'S ADDRESS ARRAY
;
N I,DATA,X
K ACRVADD
F I=1:1:4 S ACRVADD(I)=""
S ACRVADD(1)=$P(^AUTTVNDR(ACRVEN,0),U)
I ACRIRS]"" S ACRVADD(1)=ACRIRS
S I=1
S DATA=$G(^AUTTVNDR(ACRVEN,13))
I $P(DATA,U)]"" D
. S I=I+1
. S ACRVADD(I)=$P(DATA,U)
I $P(DATA,U,10)]"" D
. S I=I+1
. S ACRVADD(I)=$P(DATA,U,10)
S X=$P(DATA,U,2)_", "_$P(^DIC(5,$P(DATA,U,3),0),U,2)_" "_$P(DATA,U,4)
S ACRVADD(4)=X
Q
ACRFIRS6 ;IHS/OIRM/DSD/AEF - PRINT 1099s [ 07/24/2002 3:17 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**1,3**;NOV 05, 2001
+2 ;
EN ;EP -- PRINT ALL VENDOR 1099S
+1 ;
+2 NEW ACRLOC,ACRYR,ZTSAVE
+3 ;
+4 DO HOME^%ZIS
+5 DO ^XBKVAR
+6 ;
+7 DO LOC(.ACRLOC)
+8 IF '$GET(ACRLOC)
QUIT
+9 ;
+10 DO YR(.ACRYR)
+11 IF '$GET(ACRYR)
QUIT
+12 ;
+13 SET ZTSAVE("ACRLOC")=""
+14 SET ZTSAVE("ACRYR")=""
+15 DO QUE^ACRFUTL("DQ^ACRFIRS6",.ZTSAVE,"PRINT 1099s")
+16 ;
+17 DO ^%ZISC
+18 QUIT
DQ ;EP -- QUEUED JOB STARTS HERE
+1 ;
+2 ; INCOMING VARIABLES:
+3 ; ACRLOC = PAYER IEN
+4 ; ACRYR = CALENDAR YEAR
+5 ;
+6 ; OTHER VARIABLES USED:
+7 ; ACRTAMT = ARRAY CONTAINING AMOUNT TOTALS BY TYPE CODE
+8 ; ACRTCNT = ARRAY CONTAINING VENDOR COUNT BY TYPE CODE
+9 ;
+10 NEW ACRTAMT,ACRTCNT
+11 ;
+12 DO ^XBKVAR
+13 ;
+14 DO LOOP(ACRLOC,ACRYR,.ACRTAMT,.ACRTCNT)
+15 ;
+16 DO TOTALS(.ACRTAMT,.ACRTCNT)
+17 ;
+18 KILL ACRLOC,ACRYR
+19 ;
+20 DO ^%ZISC
+21 QUIT
LOOP(ACRLOC,ACRYR,ACRTAMT,ACRTCNT) ;
+1 ;----- LOOP THROUGH ARMS VENDOR FILE AND PRINT 1099s
+2 ;
+3 ; INPUT:
+4 ; ACRLOC = PAYER IEN
+5 ; ACRYR = CALENDAR YEAR
+6 ;
+7 ; RETURNS:
+8 ; ACRTAMT = ARRAY CONTAINING PAYMENT AMOUNTS BY TYPE CODE
+9 ; ACRTCNT = ARRAY CONTAINING VENDOR COUNTS BY TYPE CODE
+10 ;
+11 NEW ACRCNT,ACRNAME,ACRVEN
+12 ;
+13 KILL ^TMP("ACR1099",$JOB)
+14 ;
+15 DO ALPHA(ACRYR)
+16 IF '$DATA(^TMP("ACR1099",$JOB))
QUIT
+17 ;
+18 SET ACRCNT=0
+19 SET ACRNAME=""
+20 FOR
SET ACRNAME=$ORDER(^TMP("ACR1099",$JOB,ACRNAME))
IF ACRNAME']""
QUIT
Begin DoDot:1
+21 SET ACRVEN=0
FOR
SET ACRVEN=$ORDER(^TMP("ACR1099",$JOB,ACRNAME,ACRVEN))
IF 'ACRVEN
QUIT
Begin DoDot:2
+22 IF $$AMT(ACRVEN,ACRYR)<600
QUIT
+23 SET ACRCNT=ACRCNT+1
+24 IF ACRCNT>1
IF ACRCNT#2
WRITE @IOF
+25 DO PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,.ACRTAMT,.ACRTCNT)
+26 DO UPDATE(ACRVEN,ACRYR)
End DoDot:2
End DoDot:1
+27 ;
+28 KILL ^TMP("ACR1099",$JOB)
+29 QUIT
ALPHA(ACRYR) ;
+1 ;----- BUILD ALPHABETIC ARRAY OF VENDORS IN ^TMP("ACR1099",$J)
+2 ;
+3 ; INPUT:
+4 ; ACRYR = CALENDAR YEAR
+5 ;
+6 NEW ACRNAME,ACRVEN
+7 SET ACRVEN=0
+8 FOR
SET ACRVEN=$ORDER(^ACR1099V("C",ACRYR,ACRVEN))
IF 'ACRVEN
QUIT
Begin DoDot:1
+9 SET ACRNAME=$PIECE(^AUTTVNDR(ACRVEN,0),U)
+10 SET ^TMP("ACR1099",$JOB,ACRNAME,ACRVEN)=0
End DoDot:1
+11 QUIT
PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,ACRTAMT,ACRTCNT) ;
+1 ;----- PRINT VENDOR 1099
+2 ;
+3 ; INPUT:
+4 ; ACRVEN = VENDOR IEN
+5 ; ACRLOC = PAYER IEN
+6 ; ACRYR = CALENDAR YEAR
+7 ;
+8 ; RETURNS:
+9 ; ACRTAMT = ARRAY CONTAINING AMOUNT TOTALS BY TYPE CODE
+10 ; ACRTCNT = ARRAY CONTAINING COUNT TOTALS BY TYPE CODE
+11 ;
+12 ; VARIABLES SET AND USED BY THIS SUBROUTINE:
+13 ; ACRAMT = ARRAY CONTAINING PAYMENT AMOUNTS BY TYPE CODE
+14 ; ACRCOR = CORRECTED RETURN INDICATOR
+15 ; ACRIRS = PAYER IRS NAME
+16 ; ACRPADD = ARRAY CONTAINING PAYER ADDRESS
+17 ; ACRPSN = PAYER STATE NUMBER
+18 ; ACRPTIN = PAYER TAX ID NUMBER
+19 ; ACRTYP = PAYMENT TYPE CODE
+20 ; ACRVADD = ARRAY CONTAINING VENDOR ADDRESS
+21 ; ACRVTIN = VENDOR TAX ID NUMBER
+22 ;
+23 ;
+24 ;----- SET VARIABLES
+25 ;
+26 NEW ACRAMT,ACRCOR,ACRIRS,ACRPADD,ACRPSN,ACRPTIN,ACRTYP,ACRVADD,ACRVTIN,DATA
+27 ;ACR*2.1*3.30
IF '$DATA(^ACR1099V(ACRVEN,1,ACRYR))
Begin DoDot:1
+28 ;ACR*2.1*3.30
WRITE !,"NO DATA FOUND"
End DoDot:1
QUIT
+29 ;
+30 FOR I=1:1:8,"A","B","C"
SET ACRAMT(I)=""
+31 SET ACRCOR=""
+32 IF $PIECE($GET(^ACR1099V(ACRVEN,1,ACRYR,0)),U,6)="Y"
SET ACRCOR="X"
+33 SET DATA=^ACR1099V(ACRVEN,0)
+34 SET ACRTYP=$PIECE(DATA,U,2)
+35 SET ACRIRS=$PIECE(DATA,U,3)
+36 SET ACRAMT(ACRTYP)=$$AMT(ACRVEN,ACRYR)
+37 DO PADD(ACRLOC,.ACRPADD)
+38 DO VADD(ACRVEN,ACRIRS,.ACRVADD)
+39 SET ACRPTIN=$PIECE(^ACR1099P(ACRLOC,0),U,8)
+40 SET ACRVTIN=$EXTRACT($PIECE(^AUTTVNDR(ACRVEN,11),U),2,10)
+41 SET ACRPSN=$PIECE($GET(^ACR1099P(ACRLOC,1)),U)
+42 ;
+43 ;----- PRINT INDIVIDUAL LINES
+44 ;
+45 ;LINE2 BLANK
+46 ;W !
+47 ;
+48 ;LINE3 CORRECTED RETURN INDICATOR
+49 ;W !
+50 WRITE ?30,ACRCOR
+51 ;
+52 ;LINE4 BLANK
+53 WRITE !
+54 ;
+55 ;LINE5 PAYER'S NAME
+56 WRITE !
+57 WRITE ?5,ACRPADD(1)
+58 ;
+59 ;LINE6 PAYER'S ADDRESS LINE 1 / RENTS AMOUNT
+60 WRITE !
+61 WRITE ?5,ACRPADD(2)
+62 WRITE ?39,$JUSTIFY(ACRAMT(1),12,2)
+63 ;
+64 ;LINE7 PAYER'S ADDRESS LINE 2
+65 WRITE !
+66 WRITE ?5,ACRPADD(3)
+67 ;
+68 ;LINE8 PAYER'S CITY,STATE,ZIP
+69 WRITE !
+70 WRITE ?5,ACRPADD(4)
+71 ;
+72 ;LINE9 ROYALTIES AMOUNT
+73 WRITE !
+74 WRITE ?39,$JUSTIFY(ACRAMT(2),12,2)
+75 ;
+76 ;LINE10 BLANK
+77 WRITE !
+78 ;
+79 ;LINE11 OTHER INCOME AMOUNT / FEDERAL INCOME TAX WHLD AMOUNT
+80 WRITE !
+81 WRITE ?39,$JUSTIFY(ACRAMT(3),12,2)
+82 WRITE ?53,$JUSTIFY(ACRAMT(4),12,2)
+83 ;
+84 ;LINE12 BLANK
+85 WRITE !
+86 ;
+87 ;LINE13 BLANK
+88 WRITE !
+89 ;
+90 ;LINE14 BLANK
+91 WRITE !
+92 ;
+93 ;LINE15 PAYER TIN / PAYEE TIN / FISHING BOAT AMOUNT / MEDICAL AMOUNT
+94 WRITE !
+95 WRITE ?5,ACRPTIN
+96 WRITE ?25,ACRVTIN
+97 WRITE ?39,$JUSTIFY(ACRAMT(5),12,2)
+98 WRITE ?53,$JUSTIFY(ACRAMT(6),12,2)
+99 ;
+100 ;LINE16 BLANK
+101 WRITE !
+102 ;
+103 ;LINE17 PAYEE'S NAME
+104 WRITE !
+105 WRITE ?5,ACRVADD(1)
+106 ;
+107 ;LINE18 BLANK
+108 WRITE !
+109 ;
+110 ;LINE19 NONEMPLOYEE COMP AMOUNT / SUBSTITUTE PMT AMOUNT
+111 WRITE !
+112 WRITE ?39,$JUSTIFY(ACRAMT(7),12,2)
+113 WRITE ?53,$JUSTIFY(ACRAMT(8),12,2)
+114 ;
+115 ;LINE20 BLANK
+116 WRITE !
+117 ;
+118 ;LINE21 PAYEE ADDRESS LINE 1
+119 WRITE !
+120 WRITE ?5,ACRVADD(2)
+121 ;
+122 ;LINE22 PAYEE ADDRESS LINE 2 / CROP INSURANCE AMOUNT
+123 WRITE !
+124 WRITE ?5,ACRVADD(3)
+125 WRITE ?53,$JUSTIFY(ACRAMT("A"),12,2)
+126 ;
+127 ;LINE23 BLANK
+128 WRITE !
+129 ;
+130 ;LINE24 PAYEE CITY,STATE,ZIP
+131 WRITE !
+132 WRITE ?5,ACRVADD(4)
+133 ;
+134 ;LINE25 BLANK
+135 WRITE !
+136 ;
+137 ;LINE26 BLANK
+138 WRITE !
+139 ;
+140 ;LINE27 GOLDEN PARACHUTE AMOUNT / PROCEEDS TO ATTORNEY AMOUNT
+141 WRITE !
+142 WRITE ?39,$JUSTIFY(ACRAMT("B"),12,2)
+143 WRITE ?53,$JUSTIFY(ACRAMT("C"),12,2)
+144 ;
+145 ;LINE28 BLANK
+146 WRITE !
+147 ;
+148 ;LINE29 STATE/PAYER'S STATE NO.
+149 WRITE !
+150 WRITE ?55,ACRPSN
+151 ;
+152 ;LINE30 BLANK
+153 WRITE !
+154 ;
+155 IF $GET(ACRCNT)#2
FOR I=1:1:6
WRITE !
+156 ;
+157 ;----- SET DOLLAR AMOUNT ARRAY
+158 ;
+159 SET ACRTAMT(ACRTYP)=$GET(ACRTAMT(ACRTYP))+ACRAMT(ACRTYP)
+160 SET ACRTCNT(ACRTYP)=$GET(ACRTCNT(ACRTYP))+1
+161 QUIT
LOC(ACRLOC) ;
+1 ;----- ASK FINANCE LOCATION
+2 ;
+3 ; RETURNS:
+4 ; ACRLOC = PAYER IEN
+5 ;
+6 NEW DIC,DTOUT,DUOUT,X,Y
+7 SET DIC="^ACR1099P("
+8 SET DIC(0)="AEMQ"
+9 SET DIC("A")="Select FINANCE LOCATION: "
+10 DO ^DIC
+11 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 IF +Y'>0
QUIT
+13 SET ACRLOC=+Y
+14 QUIT
YR(ACRYR) ;
+1 ;----- ASK CALENDAR YEAR
+2 ;
+3 ; RETURNS:
+4 ; ACRYR = CALENDAR YEAR
+5 ;
+6 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+7 SET DIR(0)="N^0000:9999"
+8 SET DIR("A")="Select CALENDAR YEAR"
+9 SET DIR("B")=($EXTRACT(DT,1,3)+1700)-1
+10 DO ^DIR
+11 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
QUIT
+12 IF +Y'>0
QUIT
+13 SET ACRYR=+Y
+14 QUIT
VEN(ACRVEN) ;
+1 ;----- ASK VENDOR
+2 ;
+3 ; RETURNS:
+4 ; ACRVEN = VENDOR IEN
+5 ;
+6 NEW DIC,DTOUT,DUOUT,X,Y
+7 SET DIC="^ACR1099V("
+8 SET DIC(0)="AEMQ"
+9 SET DIC("A")="Select VENDOR: "
+10 DO ^DIC
+11 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 IF +Y'>0
QUIT
+13 SET ACRVEN=+Y
+14 QUIT
UPDATE(ACRVEN,ACRYR) ;
+1 ;----- UPDATE 1099 PRINT DATE FIELD IN ARMS 1099 VENDOR FILE
+2 ;
+3 ; INPUT:
+4 ; ACRVEN = VENDOR IEN
+5 ; ACRYR = CALENDAR YEAR
+6 ;
+7 NEW DA,DIE,DR,X,Y
+8 SET DA(1)=ACRVEN
+9 SET DA=ACRYR
+10 SET DIE="^ACR1099V("_DA(1)_",1,"
+11 SET DR=".05////"_DT
+12 DO ^DIE
+13 QUIT
ONE ;EP -- PRINT ONE VENDOR 1099
+1 ;
+2 NEW ACRLOC,ACRVEN,ACRYR,ZTSAVE
+3 ;
+4 DO HOME^%ZIS
+5 DO ^XBKVAR
+6 ;
+7 DO LOC(.ACRLOC)
+8 IF '$GET(ACRLOC)
QUIT
+9 ;
+10 DO YR(.ACRYR)
+11 IF '$GET(ACRYR)
QUIT
+12 ;
+13 DO VEN(.ACRVEN)
+14 IF '$GET(ACRVEN)
QUIT
+15 ;
+16 SET ZTSAVE("ACRLOC")=""
+17 SET ZTSAVE("ACRYR")=""
+18 SET ZTSAVE("ACRVEN")=""
+19 DO QUE^ACRFUTL("DQ1^ACRFIRS6",.ZTSAVE,"PRINT ONE 1099")
+20 ;
+21 DO ^%ZISC
+22 QUIT
DQ1 ;EP -- QUEUED JOB STARTS HERE
+1 ;
+2 ; INPUT:
+3 ; ACRLOC = PAYER IEN
+4 ; ACRVEN = VENDOR IEN
+5 ; ACRYR = CALENDAR YEAR
+6 ;
+7 NEW ACRMTOT,ACRMAMT,ACRNTOT,ACRNAMT
+8 ;
+9 WRITE @IOF
+10 ;
+11 DO ^XBKVAR
+12 ;
+13 DO PRT(ACRVEN,ACRLOC,ACRYR,$GET(ACRCNT),.ACRTAMT,.ACRTCNT)
+14 ;
+15 DO TOTALS(.ACRTAMT,.ACRTCNT)
+16 ;
+17 DO ^%ZISC
+18 KILL ACRLOC,ACRVEN,ACRYR
+19 QUIT
TEST ;EP -- PRINT TEST 1099s
+1 ;
+2 NEW ACRLOC,ACRYR,ZTSAVE
+3 ;
+4 DO ^XBKVAR
+5 ;
+6 DO LOC(.ACRLOC)
+7 IF '$GET(ACRLOC)
QUIT
+8 ;
+9 DO YR(.ACRYR)
+10 IF '$GET(ACRYR)
QUIT
+11 ;
+12 SET ZTSAVE("ACRLOC")=""
+13 SET ZTSAVE("ACRYR")=""
+14 DO QUE^ACRFUTL("DQ2^ACRFIRS6",.ZTSAVE,"PRINT TEST 1099s")
+15 ;
+16 DO ^%ZISC
+17 QUIT
DQ2 ;EP -- QUEUED JOB STARTS HERE
+1 ;
+2 ; INPUT:
+3 ; ACRLOC = PAYER IEN
+4 ; ACRYR = CALENDAR YEAR
+5 ;
+6 NEW ACRTAMT,ACRTCNT,ACRVEN,ACRCNT
+7 ;
+8 WRITE @IOF
+9 ;
+10 DO ^XBKVAR
+11 ;
+12 SET (ACRVEN,ACRCNT)=0
+13 FOR
IF ACRCNT>9
QUIT
SET ACRVEN=$ORDER(^ACR1099V("C",ACRYR,ACRVEN))
IF 'ACRVEN
QUIT
Begin DoDot:1
+14 SET ACRCNT=ACRCNT+1
+15 IF ACRCNT>9
QUIT
+16 IF ACRCNT>1
IF ACRCNT#2
WRITE @IOF
+17 DO PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,.ACRTAMT,.ACRTCNT)
End DoDot:1
+18 ;
+19 DO TOTALS(.ACRTAMT,.ACRTCNT)
+20 ;
+21 KILL ACRLOC,ACRYR
+22 DO ^%ZISC
+23 QUIT
RANGE ;EP -- PRINT RANGE OF VENDOR 1099S
+1 ;
+2 NEW ACRLOC,ACRVEN,ACRYR,ZTSAVE
+3 ;
+4 DO ^XBKVAR
+5 ;
+6 KILL ^TMP("ACR1099",$JOB)
+7 ;
+8 DO LOC(.ACRLOC)
+9 IF '$GET(ACRLOC)
QUIT
+10 ;
+11 DO YR(.ACRYR)
+12 IF '$GET(ACRYR)
QUIT
+13 ;
+14 DO ALPHA(ACRYR)
+15 IF '$DATA(^TMP("ACR1099",$JOB))
Begin DoDot:1
+16 WRITE !,"No Vendor data found for ",ACRYR
End DoDot:1
GOTO RANGE
+17 ;
+18 DO VEND(.ACRVEN)
+19 IF ACRVEN']""
QUIT
+20 ;
+21 SET ZTSAVE("ACRLOC")=""
+22 SET ZTSAVE("ACRYR")=""
+23 SET ZTSAVE("ACRVEN")=""
+24 DO QUE^ACRFUTL("DQ3^ACRFIRS6",.ZTSAVE,"PRINT RANGE OF 1099S")
+25 ;
+26 DO ^%ZISC
+27 QUIT
DQ3 ;EP -- QUEUED JOB STARTS HERE
+1 ;
+2 ; INPUT:
+3 ; ACRLOC = PAYER IEN
+4 ; ACRVEN = VENDOR RANGE
+5 ; ACRYR = CALENDAR YEAR
+6 ;
+7 NEW ACRTAMT,ACRTCNT
+8 ;
+9 DO ^XBKVAR
+10 ;
+11 DO LOOP3(ACRLOC,ACRYR,ACRVEN,.ACRTAMT,.ACRTCNT)
+12 ;
+13 KILL ACRLOC,ACRYR,ACRVEN
+14 DO ^%ZISC
+15 QUIT
LOOP3(ACRLOC,ACRYR,ACRVEN,ACRTAMT,ACRTCNT) ;
+1 ;
+2 ; INPUT:
+3 ; ACRLOC = PAYER IEN
+4 ; ACRVEN = VENDOR RANGE
+5 ; ACRYR = CALENDAR YEAR
+6 ;
+7 ; RETURNS:
+8 ; ACRTAMT = ARRAY CONTAINING AMOUNTS BY PAYMENT TYPE CODE
+9 ; ACRTCNT = ARRAY CONTAINING VENDOR COUNTS BY PAYMENT TYPE CODE
+10 ;
+11 NEW ACREND,ACRNAME,ACRCNT
+12 ;
+13 DO ALPHA(ACRYR)
+14 IF '$DATA(^TMP("ACR1099",$JOB))
QUIT
+15 ;
+16 SET ACREND=$PIECE(ACRVEN,U,2)
+17 SET ACRNAME=$PIECE(ACRVEN,U)
+18 SET ACRNAME=$ORDER(^TMP("ACR1099",$JOB,ACRNAME),-1)
+19 ;
+20 SET ACRCNT=0
+21 FOR
SET ACRNAME=$ORDER(^TMP("ACR1099",$JOB,ACRNAME))
IF ACRNAME']""
QUIT
IF ACRNAME]ACREND
QUIT
Begin DoDot:1
+22 SET ACRVEN=0
+23 FOR
SET ACRVEN=$ORDER(^TMP("ACR1099",$JOB,ACRNAME,ACRVEN))
IF 'ACRVEN
QUIT
Begin DoDot:2
+24 IF $$AMT(ACRVEN,ACRYR)<600
QUIT
+25 SET ACRCNT=ACRCNT+1
+26 IF ACRCNT>1
IF ACRCNT#2
WRITE @IOF
+27 DO PRT(ACRVEN,ACRLOC,ACRYR,ACRCNT,.ACRTAMT,.ACRTCNT)
End DoDot:2
End DoDot:1
+28 ;
+29 DO TOTALS(.ACRTAMT,.ACRTCNT)
+30 ;
+31 KILL ^TMP("ACR1099",$JOB)
+32 QUIT
VEND(ACRVEN) ;
+1 ;----- GETS START AND END VENDORS IN RANGE SELECTION
+2 ;
V ; RETURNS:
+1 ; ACRVEN = CONTAINS BEGINNING AND ENDING VENDOR NAME RANGE
+2 ;
+3 NEW DIR,X,Y
+4 SET ACRVEN=""
+5 SET DIR(0)="F"
+6 SET DIR("A")="Start with VENDOR"
+7 SET DIR("?")="Enter BEGINNING VENDOR in range"
+8 DO ^DIR
+9 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET ACRVEN=""
QUIT
+10 IF Y']""
QUIT
+11 SET ACRVEN=Y
+12 SET DIR("A")="End with VENDOR"
+13 SET DIR("?")="Enter ENDING VENDOR in range"
+14 DO ^DIR
+15 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET ACRVEN=""
QUIT
+16 IF Y']""
SET ACRVEN=""
QUIT
+17 IF Y']ACRVEN
Begin DoDot:1
+18 WRITE !,"'",Y,"' does not follow '",ACRVEN,"'"
End DoDot:1
GOTO V
+19 SET ACRVEN=ACRVEN_"^"_Y
+20 QUIT
TOTALS(ACRTAMT,ACRTCNT) ;
+1 ;----- PRINTS GRAND TOTALS
+2 ;
+3 ; INPUT:
+4 ; ACRTAMT = ARRAY CONTAINING AMOUNT TOTALS BY PAYMENT TYPE CODE
+5 ; ACRTCNT = ARRAY CONTAINING VENDOR COUNTS BY PAYMENT TYPE CODE
+6 ;
+7 WRITE @IOF
+8 ;
+9 NEW ACRGAMT,ACRGCNT,ACRTYP,I
+10 ;
+11 SET ACRTYP(1)="RENTS"
+12 SET ACRTYP(2)="ROYALTIES"
+13 SET ACRTYP(3)="OTHER INCOME"
+14 SET ACRTYP(4)="FED INC TAX WHLD"
+15 SET ACRTYP(5)="FISHING BOAT PROC"
+16 SET ACRTYP(6)="MED & HLTH CARE"
+17 SET ACRTYP(7)="NONEMPLOYEE COMP"
+18 SET ACRTYP(8)="SUBSTITUTE PMTS"
+19 SET ACRTYP("A")="CROP INS PROC"
+20 SET ACRTYP("B")="EXC GOLD PARA"
+21 SET ACRTYP("C")="PROC TO ATTY"
+22 ;
+23 FOR I=1:1:3
WRITE !
+24 ;
+25 SET (ACRGCNT,ACRGAMT)=0
+26 FOR I=1:1:8,"A","B","C"
Begin DoDot:1
+27 ;Q:'$D(ACRTAMT(I))
+28 WRITE ?5,"TOTAL FOR ",ACRTYP(I)," PMTS:"
+29 WRITE ?40,$JUSTIFY(+$GET(ACRTCNT(I)),4)
+30 WRITE ?50,$JUSTIFY(+$GET(ACRTAMT(I)),12,2)
+31 SET ACRGCNT=$GET(ACRGCNT)+$GET(ACRTCNT(I))
+32 SET ACRGAMT=$GET(ACRGAMT)+$GET(ACRTAMT(I))
+33 WRITE !!
End DoDot:1
+34 ;
+35 WRITE ?40,"----"
+36 WRITE ?50,"------------"
+37 WRITE !
+38 WRITE ?40,$JUSTIFY(ACRGCNT,4)
+39 WRITE ?50,$JUSTIFY(ACRGAMT,12,2)
+40 QUIT
AMT(ACRVEN,ACRYR) ;
+1 ;----- EXTRINSIC FUNCTION TO RETURN DOLLAR AMOUNT
+2 ;
+3 NEW X
+4 SET X=$GET(^ACR1099V(ACRVEN,1,ACRYR,0))
+5 SET Y=$PIECE(X,U,2)
+6 IF $PIECE(X,U,6)="Y"
SET Y=$PIECE(X,U,8)
+7 QUIT Y
PADD(ACRLOC,ACRPADD) ;
+1 ;----- RETURN PAYER'S ADDRESS ARRAY
+2 ;
+3 NEW I,DATA,X
+4 KILL ACRPADD
+5 FOR I=1:1:4
SET ACRPADD(I)=""
+6 SET I=0
+7 SET DATA=$GET(^ACR1099P(ACRLOC,0))
+8 IF $PIECE(DATA,U,2)]""
Begin DoDot:1
+9 SET I=I+1
+10 SET ACRPADD(I)=$PIECE(DATA,U,2)
End DoDot:1
+11 IF $PIECE(DATA,U,3)]""
Begin DoDot:1
+12 SET I=I+1
+13 SET ACRPADD(I)=$PIECE(DATA,U,3)
End DoDot:1
+14 IF $PIECE(DATA,U,4)]""
Begin DoDot:1
+15 SET I=I+1
+16 SET ACRPADD(I)=$PIECE(DATA,U,4)
End DoDot:1
+17 SET X=$PIECE(DATA,U,5)_", "_$PIECE(^DIC(5,$PIECE(DATA,U,6),0),U,2)_" "_$PIECE(DATA,U,7)
+18 SET I=I+1
+19 SET ACRPADD(I)=X
+20 QUIT
VADD(ACRVEN,ACRIRS,ACRVADD) ;
+1 ;----- RETURN VENDOR'S ADDRESS ARRAY
+2 ;
+3 NEW I,DATA,X
+4 KILL ACRVADD
+5 FOR I=1:1:4
SET ACRVADD(I)=""
+6 SET ACRVADD(1)=$PIECE(^AUTTVNDR(ACRVEN,0),U)
+7 IF ACRIRS]""
SET ACRVADD(1)=ACRIRS
+8 SET I=1
+9 SET DATA=$GET(^AUTTVNDR(ACRVEN,13))
+10 IF $PIECE(DATA,U)]""
Begin DoDot:1
+11 SET I=I+1
+12 SET ACRVADD(I)=$PIECE(DATA,U)
End DoDot:1
+13 IF $PIECE(DATA,U,10)]""
Begin DoDot:1
+14 SET I=I+1
+15 SET ACRVADD(I)=$PIECE(DATA,U,10)
End DoDot:1
+16 SET X=$PIECE(DATA,U,2)_", "_$PIECE(^DIC(5,$PIECE(DATA,U,3),0),U,2)_" "_$PIECE(DATA,U,4)
+17 SET ACRVADD(4)=X
+18 QUIT
