ACRFIRSU ;IHS/OIRM/DSD/AEF/MRS - ARMS IRS 1099 FORM UTILITY [ 10/27/2004 4:18 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**8,13**;NOV 05, 2001
;NEW ROUTINE ACR*2.1*8
;
DESC ;----- ROUTINE DESCRIPTION
;;
;;This routine contains extrinsic functions and other subroutines
;;used by ARMS/IRS 1099 Interface Data Extract routines, primarily
;;ACRFIRSA (ACR*2.1*8.06)
;;$$END
Q
FILE(ACRFILE,ACRCNT,ACRDATES,ACREXTYP) ;EP
;----- ASK FILE NAME
;
; INPUT:
; ACRCNT = COUNT OF RECORDS IN THE EXTRACT
; ACRDATES = DATE RANGE OF EXTRACT
; ACREXTYP = EXTRACT TYPE, I.E., TRAVEL, TRAINING, PO
;
; OUTPUT:
; ACRFILE = EXTRACT FILENAME
;
N ACRBEG,ACREND,DIR,DIRUT,DTOUT,DUOUT,X,Y
;
S ACRFILE=""
S ACRBEG=$P(ACRDATES,U)
S ACREND=$P(ACRDATES,U,2)
S DIR(0)="F"
S DIR("A")="Select OUTPUT FILE NAME"
S DIR("?")="The name of the OUTPUT FILE you want to put the data into"
D ^DIR
Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
S ACRFILE=Y
Q
HFS(ZISH1,ZISH2,ZISH3,%FILE) ;EP ; REMOVED OBSOLETE CODE ACR*2.1*13.06 IM14144
;----- CREATE AND OPEN UNIX FILE
; ENTERS WITH: ZISH1= PATH
; ZISH2= FILENAME
; ZISH3= "R" OR "W"
; RETURNS: %FILE = DEVICE NUMBER (or UNDEFINED)
;
;N X,Y
;S Y=$$OPEN^%ZISH(ZISH1,ZISH2,ZISH3)
;I Y D Q
;. U IO(0) W !,"CANNOT OPEN FILE "_ZISH1_ZISH2
;S %FILE=IO
Q
WRITE(X) ;EP -- FORMAT "^" DELMITED DATA STRING INTO COMMA DELIMITED STRING
; USEFUL FOR EXCEL OR ACCESS SPREADSHEETS
;
; INPUT:
; X = DATA STRING IN "^" DELIMITED FIELD FORMAT,
; I.E., FIELD1^FIELD2^FIELD3^FIELD4
;
; OUTPUT:
; Y = DATA STRING IN QUOTED DATA/COMMA DELIMITED FORMAT,
; I.E., "A","B","C","D"
;
N I,Y,Z
S Y=""
F I=1:1:$L(X,U) D
. S Z=$P(X,U,I)
. S Y=Y_""""_Z_""""_","
S Y=$E(Y,1,$L(Y)-1)
Q Y
LOC(ACRLOC) ;EP;
;----- 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) ;EP;
;----- 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
STATE(X) ;EP -- RETURNS 2-CHARACTER ARMS STATE
;
; X = STATE IEN
;
N Y
S Y=""
I X S Y=$P($G(^DIC(5,X,0)),U,2)
Q Y
;
YTD(X,Y) ;EP
;----- EXTRINSIC FUNCTION TO RETURN YEAR TO DATE AMOUNT PAID
;
; X = VENDOR FILE IEN
; Y = CALENDAR YEAR WANTED
;
N W,Z
S Z=""
S W=$G(^ACR1099V(X,1,Y,0))
S Z=$P(W,U,2)
I $P(W,U,6)="Y" S Z=$P(W,U,8) ; CORRECTED AMOUNT
Q Z
;
ASKUP() ;EP;
;----- EXTRINSIC FUNCTION TO RETURN UPDATE OR TEST
;
N Y
;
S Y="T"
S DIR(0)="SO^1:Update Vendor File;2:Test Print Only"
S DIR("A")="Which one"
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT) Q 0
Q Y
UPDATE(ACRVEN,ACRYR) ;EP;
;----- 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
;Removed code--replaced by call to ARMSDIR^ACRFSYS(1) ;ACR*2.1*13.06 IM14144
ARMSDIR(X) ;EP; ; ACR*2.1*8.07
;----- EXTRINSIC FUNCTION TO RETURN ARMS DEFAULT DIRECTORY FROM
; FMS SYSTEMS DEFAULTS FILE
; X= SYSTEM NUMBER IN FMS SYSTEM DEFAULT FILE CURRENTLY ALWAYS 1
; UNTIL SYSTEM BECOMES FULLY MULTIREGIONAL
;
; If no entry, function returns old default
;
;N Y
;S Y=$P($G(^ACRSYS(X,402)),U,3)
;I Y="" S Y="/usr/spool/afsdata/"
;Q Y
ACRFIRSU ;IHS/OIRM/DSD/AEF/MRS - ARMS IRS 1099 FORM UTILITY [ 10/27/2004 4:18 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**8,13**;NOV 05, 2001
+2 ;NEW ROUTINE ACR*2.1*8
+3 ;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;This routine contains extrinsic functions and other subroutines
+3 ;;used by ARMS/IRS 1099 Interface Data Extract routines, primarily
+4 ;;ACRFIRSA (ACR*2.1*8.06)
+5 ;;$$END
+6 QUIT
FILE(ACRFILE,ACRCNT,ACRDATES,ACREXTYP) ;EP
+1 ;----- ASK FILE NAME
+2 ;
+3 ; INPUT:
+4 ; ACRCNT = COUNT OF RECORDS IN THE EXTRACT
+5 ; ACRDATES = DATE RANGE OF EXTRACT
+6 ; ACREXTYP = EXTRACT TYPE, I.E., TRAVEL, TRAINING, PO
+7 ;
+8 ; OUTPUT:
+9 ; ACRFILE = EXTRACT FILENAME
+10 ;
+11 NEW ACRBEG,ACREND,DIR,DIRUT,DTOUT,DUOUT,X,Y
+12 ;
+13 SET ACRFILE=""
+14 SET ACRBEG=$PIECE(ACRDATES,U)
+15 SET ACREND=$PIECE(ACRDATES,U,2)
+16 SET DIR(0)="F"
+17 SET DIR("A")="Select OUTPUT FILE NAME"
+18 SET DIR("?")="The name of the OUTPUT FILE you want to put the data into"
+19 DO ^DIR
+20 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
QUIT
+21 SET ACRFILE=Y
+22 QUIT
HFS(ZISH1,ZISH2,ZISH3,%FILE) ;EP ; REMOVED OBSOLETE CODE ACR*2.1*13.06 IM14144
+1 ;----- CREATE AND OPEN UNIX FILE
+2 ; ENTERS WITH: ZISH1= PATH
+3 ; ZISH2= FILENAME
+4 ; ZISH3= "R" OR "W"
+5 ; RETURNS: %FILE = DEVICE NUMBER (or UNDEFINED)
+6 ;
+7 ;N X,Y
+8 ;S Y=$$OPEN^%ZISH(ZISH1,ZISH2,ZISH3)
+9 ;I Y D Q
+10 ;. U IO(0) W !,"CANNOT OPEN FILE "_ZISH1_ZISH2
+11 ;S %FILE=IO
+12 QUIT
WRITE(X) ;EP -- FORMAT "^" DELMITED DATA STRING INTO COMMA DELIMITED STRING
+1 ; USEFUL FOR EXCEL OR ACCESS SPREADSHEETS
+2 ;
+3 ; INPUT:
+4 ; X = DATA STRING IN "^" DELIMITED FIELD FORMAT,
+5 ; I.E., FIELD1^FIELD2^FIELD3^FIELD4
+6 ;
+7 ; OUTPUT:
+8 ; Y = DATA STRING IN QUOTED DATA/COMMA DELIMITED FORMAT,
+9 ; I.E., "A","B","C","D"
+10 ;
+11 NEW I,Y,Z
+12 SET Y=""
+13 FOR I=1:1:$LENGTH(X,U)
Begin DoDot:1
+14 SET Z=$PIECE(X,U,I)
+15 SET Y=Y_""""_Z_""""_","
End DoDot:1
+16 SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
+17 QUIT Y
LOC(ACRLOC) ;EP;
+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) ;EP;
+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
STATE(X) ;EP -- RETURNS 2-CHARACTER ARMS STATE
+1 ;
+2 ; X = STATE IEN
+3 ;
+4 NEW Y
+5 SET Y=""
+6 IF X
SET Y=$PIECE($GET(^DIC(5,X,0)),U,2)
+7 QUIT Y
+8 ;
YTD(X,Y) ;EP
+1 ;----- EXTRINSIC FUNCTION TO RETURN YEAR TO DATE AMOUNT PAID
+2 ;
+3 ; X = VENDOR FILE IEN
+4 ; Y = CALENDAR YEAR WANTED
+5 ;
+6 NEW W,Z
+7 SET Z=""
+8 SET W=$GET(^ACR1099V(X,1,Y,0))
+9 SET Z=$PIECE(W,U,2)
+10 ; CORRECTED AMOUNT
IF $PIECE(W,U,6)="Y"
SET Z=$PIECE(W,U,8)
+11 QUIT Z
+12 ;
ASKUP() ;EP;
+1 ;----- EXTRINSIC FUNCTION TO RETURN UPDATE OR TEST
+2 ;
+3 NEW Y
+4 ;
+5 SET Y="T"
+6 SET DIR(0)="SO^1:Update Vendor File;2:Test Print Only"
+7 SET DIR("A")="Which one"
+8 DO DIR^ACRFDIC
+9 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT 0
+10 QUIT Y
UPDATE(ACRVEN,ACRYR) ;EP;
+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
+14 ;Removed code--replaced by call to ARMSDIR^ACRFSYS(1) ;ACR*2.1*13.06 IM14144
ARMSDIR(X) ;EP; ; ACR*2.1*8.07
+1 ;----- EXTRINSIC FUNCTION TO RETURN ARMS DEFAULT DIRECTORY FROM
+2 ; FMS SYSTEMS DEFAULTS FILE
+3 ; X= SYSTEM NUMBER IN FMS SYSTEM DEFAULT FILE CURRENTLY ALWAYS 1
+4 ; UNTIL SYSTEM BECOMES FULLY MULTIREGIONAL
+5 ;
+6 ; If no entry, function returns old default
+7 ;
+8 ;N Y
+9 ;S Y=$P($G(^ACRSYS(X,402)),U,3)
+10 ;I Y="" S Y="/usr/spool/afsdata/"
+11 ;Q Y
