ACRFIRSU.m

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