ACRFVLK2.m

ACRFVLK2 ;IHS/OIRM/DSD/EFG - VENDOR FILE LOOKUP 2 ; [ 05/02/2007  10:56 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**20,21,22**;NOV 5, 2001

 ;

 ;    New routine ACR*2.1*20.14

 ;    Heavily rewritten for UFMS CORE Open Document vendor checks ACR*2.1*22.14 IM24159

 ;    Also to remedy error ACR*2.1*22.11c IM24263

 Q

PRINTMN ;EP - PRINT VENDORS MISSING REQ DATA BY NAME

 ;

 S STR="1100"                       ;ACTIVE,ERR MSG,NO DUNS,ETC

 S (ZTRTN,ACRRTN)="V^ACRFVLK3(1100)"

 S ZTDESC="ACTIVE VENDORS WITH MISSING/BAD REQUIRED DATA BY NAME"

 D HFS("V^ACRFVLK3(1100)",STR)

 Q

 ;

PRINTIV ;EP - PRINT INACTIVE VENDORS BY NAME

 ;

 S STR="0000"                       ;INACTIVE,NO ERR MSG,NO DUNS,ETC)

 S (ZTRTN,ACRRTN)="V^ACRFVLK3(""0000"")"

 S ZTDESC="PRINT INACTIVE VENDORS"

 D HFS("V^ACRFVLK3(""0000"")",STR)

 Q

 ;

PRINTMD ;EP - PRINT VENDORS MISSING OR BAD DUNS

 ;

 S STR="10D0"                       ;ACTIVE,NO ERR MSG, MISSING DUNS

 S (ZTRTN,ACRRTN)="V^ACRFVLK3(""10D0"")"

 S ZTDESC="VENDORS MISSING DUNS BY NAME"

 D HFS("V^ACRFVLK3(""10D0"")",STR)

 Q

PRINTME ;EP - PRINT VENDORS MISSING OR BAD EIN

 ;

 S STR="10E0"                       ;ACTIVE,NO ERR MSG, MISSING EIN

 S (ZTRTN,ACRRTN)="V^ACRFVLK3(""10E0"")"

 S ZTDESC="VENDORS MISSING EIN BY NAME"

 D HFS("V^ACRFVLK3(""10E0"")")

 Q

PRINTMZ ;EP - PRINT VENDORS WHOSE ZIP IS < 9

 ;

 S STR="10Z0"                      ;ACTIVE,NO ERR MSG, MISSING ZIP

 S (ZTRTN,ACRRTN)="V^ACRFVLK3(""10Z0"")"

 S ZTDESC="VENDORS MISSING ZIP+4 BY NAME"

 D HFS("V^ACRFVLK3(""10Z0"")",STR)

 Q

 ;

PRINTAD ;EP - PRINT ACTIVE VENDORS WITH DUNS

 ;

 S STR="10D1"                      ;ACTIVE,NO ERR MSG, HAS DUNS

 S (ZTRTN,ACRRTN)="ADEZ^ACRFVLK3(""10D1"")"

 S ZTDESC="ACTIVE VENDORS WITH DUNS"

 D HFS("ADEZ^ACRFVLK3(""10D1"")",STR)

 Q

PRINTAE ;EP - PRINT ACTIVE VENDORS WITH EIN

 S STR="10E1"                      ;ACTIVE,NO ERR MSG, HAS EIN

 S (ZTRTN,ACRRTN)="ADEZ^ACRFVLK3(""10E1"")"

 S ZTDESC="ACTIVE VENDORS WITH EIN"

 D HFS("ADEZ^ACRFVLK3(""10E1"")",STR)

 Q

PRINTAV ;EP - PRINT ACTIVE VENDORS

 ;

 S STR="1000"                       ;ACTIVE,NO ERR MSG,NO DUNS ETC

 S ZTSAVE("STR")=""

 S (ZTRTN,ACRRTN)="V^ACRFVLK3(1000)"

 S ZTDESC="PRINT ACTIVE VENDORS"

 D HFS("V^ACRFVLK3(1000)",STR)

 Q

 ;

HFS(SUB,STR) ;LOCAL UTILITY TO OPEN DEVICE OR FILE

 K ACRHFS,ACRDIR,ACRFILE               ;ACR*2.1*21.04 IM22466

 S ACR("HFS")=""                       ;ACR*2.1*21.04 IM22466

 S ZTSAVE("STR")=""

 D ^ACRFZIS

 K ACR("HFS")

 I $D(ACRHFS) D

 .S ACRDIR=ZISH1

 .S ACRFILE=ZISH2

 .D @SUB

 .D PROCHFS

 Q

 ;

HEAD(HD1,HD2) ;EP

 I $D(ACRHFS)&($D(%FILE)) D  I 1

 .U %FILE

 .D CSV(HD1)

 .D:HD2]"" CSV(HD2)

 .W !

 E  D

 .W !!?80-$L(HD1)/2,HD1

 .I HD2]"" W !?80-$L(HD2)/2,HD2,!

 Q

 ;

WRT(NUM) ;EP - WRITE ALL DATA

 N ACR,ACRP,I,ACRTMP

 S ACRP=""

 F  S ACRP=$O(^TMP("ACR",$J,ACRP)) Q:ACRP=""!($D(ACROUT))  D

 .S ACR=$G(^TMP("ACR",$J,ACRP))

 .I $D(ACRHFS)&($D(%FILE)) D  Q              ;ACR*2.1*21.04 IM22466

 ..U %FILE

 ..D CSV(ACR)

 .I NUM=1 D

 ..W !,ACRP,?34,$P(ACR,U,2),?50,$P(ACR,U,3),?65,$P(ACR,U,4)  ;ACR*2.1*21.04 IM22466

 .I NUM=2 D

 ..W !,ACRP,?15,$P(ACR,U,2),?50,$P(ACR,U,3),?65,$P(ACR,U,4)

 .I $P(ACR,U,5)'="--" W !?10,$P(ACR,U,5)     ;NO EFT, DON'T WRITE LINE

 .I $L(ACR,U)>5 W ! F I=6:1:$L(ACR,U) D      ;WRITE ERRORS

 ..S ACRTMP=$P(ACR,U,I)

 ..W:ACRTMP]"" ACRTMP

 ..W:I'=$L(ACR,U) ",  "

 .I '$D(ACRHFS),$Y>(IOSL-4) D PAUSE^ACRFWARN W @IOF Q  ;ACR*2.1*21.04 IM22466

 I '$D(ACRHFS) D PAUSE^ACRFWARN W @IOF                 ;ACR*2.1*21.04 IM22466

 K ^TMP("ACR",$J)                                      ;ACR*2.1*21.04 IM22466

 Q

 ;*************************************************

CSV(REC) ;MAKE FLAT FILE COMMA SEPARATED VALUE STRING

 W !

 F I=1:1:$L(REC,U) D

 .S TMP=$P(REC,U,I)

 .W $C(34)                             ;WRITE " DOUBLE QUOTE

 .I $E(TMP)="0",$L(TMP)'=1 W $C(39)    ;WRITE ' SINGLE QUOTE IN FRONT OF ZERO

 .W TMP_$C(34)_$C(44)                  ;WRITE " DOUBLE QUOTE AND COMMA

 Q

 ;

PROCHFS ;EP - PROCESS HFS FILE  ACR*2.1*21.04 IM22466

 D CLOSE^ACRFZISH("")

 D HOME^%ZIS W !!,"File "_ACRFILE_" has been put into "_ACRDIR

 D PAUSE^ACRFWARN W @IOF

 Q

SUBHEAD(STR,NUM) ;EP - HEADING1  ACR*2.1*21.04 IM22466

 I $D(ACRHFS)&($D(%FILE)) D  Q

 .U %FILE

 .D CSV(STR)

 I NUM=1 D                          ;SORTED BY NAME

 .W !,$P(STR,U),?34,$P(STR,U,2),?50,$P(STR,U,3),?65,$P(STR,U,4)

 I NUM=2 D                          ;SORTED BY DUNS,EIN OR ZIP

 .W !,$P(STR,U),?15,$P(STR,U,2),?50,$P(STR,U,3),?65,$P(STR,U,4)

 W !?10,$P(STR,U,5)

 W ! F I=6:1:$L(STR,U) W ",  ",$P(STR,U,I)

 W !,"-------------------------------------------------------------------------------"

 Q

ACRFVLK2  ;IHS/OIRM/DSD/EFG - VENDOR FILE LOOKUP 2 ; [ 05/02/2007  10:56 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;**20,21,22**;NOV 5, 2001

 +2       ;

 +3       ;    New routine ACR*2.1*20.14

 +4       ;    Heavily rewritten for UFMS CORE Open Document vendor checks ACR*2.1*22.14 IM24159

 +5       ;    Also to remedy error ACR*2.1*22.11c IM24263

 +6        QUIT 

PRINTMN   ;EP - PRINT VENDORS MISSING REQ DATA BY NAME

 +1       ;

 +2       ;ACTIVE,ERR MSG,NO DUNS,ETC

           SET STR="1100"

 +3        SET (ZTRTN,ACRRTN)="V^ACRFVLK3(1100)"

 +4        SET ZTDESC="ACTIVE VENDORS WITH MISSING/BAD REQUIRED DATA BY NAME"

 +5        DO HFS("V^ACRFVLK3(1100)",STR)

 +6        QUIT 

 +7       ;

PRINTIV   ;EP - PRINT INACTIVE VENDORS BY NAME

 +1       ;

 +2       ;INACTIVE,NO ERR MSG,NO DUNS,ETC)

           SET STR="0000"

 +3        SET (ZTRTN,ACRRTN)="V^ACRFVLK3(""0000"")"

 +4        SET ZTDESC="PRINT INACTIVE VENDORS"

 +5        DO HFS("V^ACRFVLK3(""0000"")",STR)

 +6        QUIT 

 +7       ;

PRINTMD   ;EP - PRINT VENDORS MISSING OR BAD DUNS

 +1       ;

 +2       ;ACTIVE,NO ERR MSG, MISSING DUNS

           SET STR="10D0"

 +3        SET (ZTRTN,ACRRTN)="V^ACRFVLK3(""10D0"")"

 +4        SET ZTDESC="VENDORS MISSING DUNS BY NAME"

 +5        DO HFS("V^ACRFVLK3(""10D0"")",STR)

 +6        QUIT 

PRINTME   ;EP - PRINT VENDORS MISSING OR BAD EIN

 +1       ;

 +2       ;ACTIVE,NO ERR MSG, MISSING EIN

           SET STR="10E0"

 +3        SET (ZTRTN,ACRRTN)="V^ACRFVLK3(""10E0"")"

 +4        SET ZTDESC="VENDORS MISSING EIN BY NAME"

 +5        DO HFS("V^ACRFVLK3(""10E0"")")

 +6        QUIT 

PRINTMZ   ;EP - PRINT VENDORS WHOSE ZIP IS < 9

 +1       ;

 +2       ;ACTIVE,NO ERR MSG, MISSING ZIP

           SET STR="10Z0"

 +3        SET (ZTRTN,ACRRTN)="V^ACRFVLK3(""10Z0"")"

 +4        SET ZTDESC="VENDORS MISSING ZIP+4 BY NAME"

 +5        DO HFS("V^ACRFVLK3(""10Z0"")",STR)

 +6        QUIT 

 +7       ;

PRINTAD   ;EP - PRINT ACTIVE VENDORS WITH DUNS

 +1       ;

 +2       ;ACTIVE,NO ERR MSG, HAS DUNS

           SET STR="10D1"

 +3        SET (ZTRTN,ACRRTN)="ADEZ^ACRFVLK3(""10D1"")"

 +4        SET ZTDESC="ACTIVE VENDORS WITH DUNS"

 +5        DO HFS("ADEZ^ACRFVLK3(""10D1"")",STR)

 +6        QUIT 

PRINTAE   ;EP - PRINT ACTIVE VENDORS WITH EIN

 +1       ;ACTIVE,NO ERR MSG, HAS EIN

           SET STR="10E1"

 +2        SET (ZTRTN,ACRRTN)="ADEZ^ACRFVLK3(""10E1"")"

 +3        SET ZTDESC="ACTIVE VENDORS WITH EIN"

 +4        DO HFS("ADEZ^ACRFVLK3(""10E1"")",STR)

 +5        QUIT 

PRINTAV   ;EP - PRINT ACTIVE VENDORS

 +1       ;

 +2       ;ACTIVE,NO ERR MSG,NO DUNS ETC

           SET STR="1000"

 +3        SET ZTSAVE("STR")=""

 +4        SET (ZTRTN,ACRRTN)="V^ACRFVLK3(1000)"

 +5        SET ZTDESC="PRINT ACTIVE VENDORS"

 +6        DO HFS("V^ACRFVLK3(1000)",STR)

 +7        QUIT 

 +8       ;

HFS(SUB,STR) ;LOCAL UTILITY TO OPEN DEVICE OR FILE

 +1       ;ACR*2.1*21.04 IM22466

           KILL ACRHFS,ACRDIR,ACRFILE

 +2       ;ACR*2.1*21.04 IM22466

           SET ACR("HFS")=""

 +3        SET ZTSAVE("STR")=""

 +4        DO ^ACRFZIS

 +5        KILL ACR("HFS")

 +6        IF $DATA(ACRHFS)

               Begin DoDot:1

 +7                SET ACRDIR=ZISH1

 +8                SET ACRFILE=ZISH2

 +9                DO @SUB

 +10               DO PROCHFS

               End DoDot:1

 +11       QUIT 

 +12      ;

HEAD(HD1,HD2) ;EP

 +1        IF $DATA(ACRHFS)&($DATA(%FILE))

               Begin DoDot:1

 +2                USE %FILE

 +3                DO CSV(HD1)

 +4                IF HD2]""

                       DO CSV(HD2)

 +5                WRITE !

               End DoDot:1

               IF 1

 +6       IF '$TEST

               Begin DoDot:1

 +7                WRITE !!?80-$LENGTH(HD1)/2,HD1

 +8                IF HD2]""

                       WRITE !?80-$LENGTH(HD2)/2,HD2,!

               End DoDot:1

 +9        QUIT 

 +10      ;

WRT(NUM)  ;EP - WRITE ALL DATA

 +1        NEW ACR,ACRP,I,ACRTMP

 +2        SET ACRP=""

 +3        FOR 

               SET ACRP=$ORDER(^TMP("ACR",$JOB,ACRP))

               IF ACRP=""!($DATA(ACROUT))

                   QUIT 

               Begin DoDot:1

 +4                SET ACR=$GET(^TMP("ACR",$JOB,ACRP))

 +5       ;ACR*2.1*21.04 IM22466

                   IF $DATA(ACRHFS)&($DATA(%FILE))

                       Begin DoDot:2

 +6                        USE %FILE

 +7                        DO CSV(ACR)

                       End DoDot:2

                       QUIT 

 +8                IF NUM=1

                       Begin DoDot:2

 +9       ;ACR*2.1*21.04 IM22466

                           WRITE !,ACRP,?34,$PIECE(ACR,U,2),?50,$PIECE(ACR,U,3),?65,$PIECE(ACR,U,4)

                       End DoDot:2

 +10               IF NUM=2

                       Begin DoDot:2

 +11                       WRITE !,ACRP,?15,$PIECE(ACR,U,2),?50,$PIECE(ACR,U,3),?65,$PIECE(ACR,U,4)

                       End DoDot:2

 +12      ;NO EFT, DON'T WRITE LINE

                   IF $PIECE(ACR,U,5)'="--"

                       WRITE !?10,$PIECE(ACR,U,5)

 +13      ;WRITE ERRORS

                   IF $LENGTH(ACR,U)>5

                       WRITE !

                       FOR I=6:1:$LENGTH(ACR,U)

                           Begin DoDot:2

 +14                           SET ACRTMP=$PIECE(ACR,U,I)

 +15                           IF ACRTMP]""

                                   WRITE ACRTMP

 +16                           IF I'=$LENGTH(ACR,U)

                                   WRITE ",  "

                           End DoDot:2

 +17      ;ACR*2.1*21.04 IM22466

                   IF '$DATA(ACRHFS)

                       IF $Y>(IOSL-4)

                           DO PAUSE^ACRFWARN

                           WRITE @IOF

                           QUIT 

               End DoDot:1

 +18      ;ACR*2.1*21.04 IM22466

           IF '$DATA(ACRHFS)

               DO PAUSE^ACRFWARN

               WRITE @IOF

 +19      ;ACR*2.1*21.04 IM22466

           KILL ^TMP("ACR",$JOB)

 +20       QUIT 

 +21      ;*************************************************

CSV(REC)  ;MAKE FLAT FILE COMMA SEPARATED VALUE STRING

 +1        WRITE !

 +2        FOR I=1:1:$LENGTH(REC,U)

               Begin DoDot:1

 +3                SET TMP=$PIECE(REC,U,I)

 +4       ;WRITE " DOUBLE QUOTE

                   WRITE $CHAR(34)

 +5       ;WRITE ' SINGLE QUOTE IN FRONT OF ZERO

                   IF $EXTRACT(TMP)="0"

                       IF $LENGTH(TMP)'=1

                           WRITE $CHAR(39)

 +6       ;WRITE " DOUBLE QUOTE AND COMMA

                   WRITE TMP_$CHAR(34)_$CHAR(44)

               End DoDot:1

 +7        QUIT 

 +8       ;

PROCHFS   ;EP - PROCESS HFS FILE  ACR*2.1*21.04 IM22466

 +1        DO CLOSE^ACRFZISH("")

 +2        DO HOME^%ZIS

           WRITE !!,"File "_ACRFILE_" has been put into "_ACRDIR

 +3        DO PAUSE^ACRFWARN

           WRITE @IOF

 +4        QUIT 

SUBHEAD(STR,NUM) ;EP - HEADING1  ACR*2.1*21.04 IM22466

 +1        IF $DATA(ACRHFS)&($DATA(%FILE))

               Begin DoDot:1

 +2                USE %FILE

 +3                DO CSV(STR)

               End DoDot:1

               QUIT 

 +4       ;SORTED BY NAME

           IF NUM=1

               Begin DoDot:1

 +5                WRITE !,$PIECE(STR,U),?34,$PIECE(STR,U,2),?50,$PIECE(STR,U,3),?65,$PIECE(STR,U,4)

               End DoDot:1

 +6       ;SORTED BY DUNS,EIN OR ZIP

           IF NUM=2

               Begin DoDot:1

 +7                WRITE !,$PIECE(STR,U),?15,$PIECE(STR,U,2),?50,$PIECE(STR,U,3),?65,$PIECE(STR,U,4)

               End DoDot:1

 +8        WRITE !?10,$PIECE(STR,U,5)

 +9        WRITE !

           FOR I=6:1:$LENGTH(STR,U)

               WRITE ",  ",$PIECE(STR,U,I)

 +10       WRITE !,"-------------------------------------------------------------------------------"

 +11       QUIT