- 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
