ACRFVLK3.m

ACRFVLK3 ;IHS/OIRM/DSD/EFG - VENDOR FILE LOOKUP 3 ; [ 04/23/2007  10:56 AM ]

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

 ;

 ;    New routine ACR*2.1*21.04 IM22466

 ;    Subroutines were moved here from ACRFVLK2 and heavily rewritten

 ;    due to routine size restrictions.

 ;    Heavily modified to remedy <SUBSCRIPT>IV+44^ACRFVLK2 error ACR*2.1*22.11c IM24263

 Q  ;MUST ENTER AT LINE LABEL

 ;

SUBH(ACT,ERR,VAR,HD1) ;

 ;

 S ERR=$E(ACT,2)                    ;0 = NO ERR MSG 1 = ERROR MSG

 S VAR=$E(ACT,3,4)                  ;E=EIN, D=DUNS, Z=ZIP (0=MISSING,1=HAS)

 S ACT=$E(ACT,1)                    ;0 = INACTIVE   1 = ACTIVE

 S:ERR="" ERR=0

 S:VAR="" VAR=0

 S:ACT="" ACT=0

 S HD1=$S(ACT=0:"INACTIVE",1:"ACTIVE")_" VENDORS "

 Q

V(ACT) ;EP - GATHER VENDORS AND SORTS BY NAME, DUNS, EIN, OR ZIP

 ; --------ENTERS WITH ACT STRING (ACTIVE, ERROR, SORT NAME)

 N TITLE

 N HD2,HD1,TAIL,ACRVAR

 D SUBH(.ACT,.ERR,.VAR,.HD1)

 S HD2="SORTED BY NAME "

 S ACRVAR=$S(VAR="E0":"NO EIN",VAR="D0":"NO DUNS",VAR="Z0":"ZIP",1:"")

 S:ACRVAR]"" HD1=HD1_"WITH "_ACRVAR

 S TAIL=$S(ERR=1:"WITH MISSING DATA",1:"")

 S HD2=HD2_TAIL

 S TITLE="NAME^DUNS^EIN+SUFFIX^MAILING ZIP^EFT TYPE-ACCT#-EFT ROUT#"

 I TAIL["MISSING" S TITLE=TITLE_U_"ERRORS"

 D HEAD^ACRFVLK2(HD1,HD2)

 D SUBHEAD^ACRFVLK2(TITLE,1)

 D LOOP(ACT,ERR,VAR)

 Q

 ;

ADEZ(ACT) ;EP - GATHER ACTIVE VENDORS WITH DUNS, EIN, OR ZIP

 N TITLE,NUM

 D SUBH(.ACT,.ERR,.VAR,.HD1)

 S ACRVAR=$S(VAR="E1":"EIN NO.",VAR="D1":"DUNS",VAR="Z1":"ZIP",1:"")

 S HD2="SORTED BY "_ACRVAR

 S:ACRVAR]"" HD1=HD1_"WITH "_ACRVAR

 I ACRVAR["EIN" D

 .S NUM=2

 .S TITLE=ACRVAR_"^VENDOR NAME^DUNS^MAILING ZIP^EFT TYPE-ACCT#-ROUT#"

 I ACRVAR["DUNS" D

 .S NUM=3

 .S TITLE=ACRVAR_"^VENDOR NAME^EIN+SUFFIX^MAILING ZIP^EFT TYPE-ACCT#-ROUT#"

 I ACRVAR["ZIP" D

 .S NUM=4

 .S TITLE=ACRVAR_"^VENDOR NAME^EIN+SUFFIX^DUNS^EFT TYPE-ACCT#-ROUT#"

 D HEAD^ACRFVLK2(HD1,HD2)

 D SUBHEAD^ACRFVLK2(TITLE,NUM)

 D LOOP(ACT,ERR,VAR)

 Q

 ;

LOOP(ACT,ERR,VAR) ; LOOP THROUGH VENDOR AND SET BY NAME

 ;   ---- ENTERS WITH WRITE SUBROUTINE CALL

 ;        ACTIVE FLAG -- 1 OR 0

 ;        ERROR FLAG  -- 1 OR 0

 ;        VAR STRING  -- E(IN), D(UNS), Z(IP) + 1 FOR HAS, 0 FOR MISSING

 ;

 N ACRVREC,NUM

 S ACRVREC=0,NUM=1

 S ACRERR=""

 F  S ACRVREC=$O(^AUTTVNDR(ACRVREC)) Q:'ACRVREC!($D(ACROUT))  D

 .I ERR D  Q:ACRERR=""                 ;ONLY WANT IF HAS ERRORS

 ..D CKVEND^ACRFUFMU(ACRVREC)          ;RETURNS WITH ACRERR STRING

 .D GETDATA

 .Q:ACT'=ACRACT                        ;ONLY WHAT IS WANTED

 .I VAR="D0" Q:ACRDUNS]""              ;WANT MISSING DUNS

 .I VAR="D1" Q:ACRDUNS=""              ;WANT DUNS

 .I VAR="E0" Q:ACREIN]""               ;WANT MISSING EIN

 .I VAR="E1" Q:ACREIN=""               ;WANT EIN

 .I VAR="Z0",$L($TR(ACRZIP,"-",""))=9 Q   ;WANT MISSING/BAD ZIP

 .I VAR="Z1" Q:ACRZIP=""               ;WANT ZIP

 .S VARN=ACRVNAM                       ;SET DEFAULT FOR NAME SORT

 .S STR=ACRVNAM_U_ACRDUNS_U_ACREX_U_ACRZIP_U_ACREFT

 .I VAR="D1" D                         ;SORT BY DUNS

 ..S VARN=ACRDUNS,NUM=2

 ..S STR=ACRDUNS_U_ACRVNAM_U_ACREX_U_ACRZIP_U_ACREFT

 .I VAR="E1" D                         ;SORT BY EIN

 ..S VARN=ACREX,NUM=2

 ..S STR=ACREX_U_ACRVNAM_U_ACRDUNS_U_ACRZIP_U_ACREFT

 .I VAR="Z1" D                         ;SORT BY ZIP

 ..S VARN=ACRZIP,NUM=2

 ..S STR=ACRZIP_ACRVNAM_U_ACRDUNS_U_ACREX_U_ACREFT

 .S:ERR STR=STR_U_ACRERR               ;ADD ERR STRING IF WANTED

 .S ^TMP("ACR",$J,VARN)=STR

 D WRT^ACRFVLK2(NUM)

 Q

GETDATA ;SET VENDOR VARIABLES

 K ACRV0,ACRV11,ACRV13,ACRV19,ACRZIP,ACROUT,ACRVNAM,ACRREC

 K ACRDUNS,ACREX,ACREFTT,ACREFT,ACRACT

 S ACRV0=$G(^AUTTVNDR(ACRVREC,0))

 S ACRV11=$G(^AUTTVNDR(ACRVREC,11))

 S ACRV13=$G(^AUTTVNDR(ACRVREC,13))

 S ACRV19=$G(^AUTTVNDR(ACRVREC,19))

 S ACRZIP=$P(ACRV13,U,4)

 S ACRVNAM=$P(ACRV0,U)

 S:ACRVNAM="" ACRVNAM="NO NAME "_ACRVREC

 S ACRDUNS=$P(ACRV0,U,7)

 S ACREIN=$P(ACRV11,U)                        ;EIN

 S ACREX=$P(ACRV11,U,13)                      ;EIN + SUFFIX

 S ACREFTT=$P(ACRV19,U)

 S ACREFT=ACREFTT_"-"_$P(ACRV19,U,3)_"-"_$P(ACRV19,U,2)

 S ACRACT=$S($$IDATE^ACRFUFMU(ACRVREC)]"":0,1:1)  ;IF VENDOR IS ACTIVE

 Q

ACRFVLK3  ;IHS/OIRM/DSD/EFG - VENDOR FILE LOOKUP 3 ; [ 04/23/2007  10:56 AM ]

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

 +2       ;

 +3       ;    New routine ACR*2.1*21.04 IM22466

 +4       ;    Subroutines were moved here from ACRFVLK2 and heavily rewritten

 +5       ;    due to routine size restrictions.

 +6       ;    Heavily modified to remedy <SUBSCRIPT>IV+44^ACRFVLK2 error ACR*2.1*22.11c IM24263

 +7       ;MUST ENTER AT LINE LABEL

           QUIT 

 +8       ;

SUBH(ACT,ERR,VAR,HD1) ;

 +1       ;

 +2       ;0 = NO ERR MSG 1 = ERROR MSG

           SET ERR=$EXTRACT(ACT,2)

 +3       ;E=EIN, D=DUNS, Z=ZIP (0=MISSING,1=HAS)

           SET VAR=$EXTRACT(ACT,3,4)

 +4       ;0 = INACTIVE   1 = ACTIVE

           SET ACT=$EXTRACT(ACT,1)

 +5        IF ERR=""

               SET ERR=0

 +6        IF VAR=""

               SET VAR=0

 +7        IF ACT=""

               SET ACT=0

 +8        SET HD1=$SELECT(ACT=0:"INACTIVE",1:"ACTIVE")_" VENDORS "

 +9        QUIT 

V(ACT)    ;EP - GATHER VENDORS AND SORTS BY NAME, DUNS, EIN, OR ZIP

 +1       ; --------ENTERS WITH ACT STRING (ACTIVE, ERROR, SORT NAME)

 +2        NEW TITLE

 +3        NEW HD2,HD1,TAIL,ACRVAR

 +4        DO SUBH(.ACT,.ERR,.VAR,.HD1)

 +5        SET HD2="SORTED BY NAME "

 +6        SET ACRVAR=$SELECT(VAR="E0":"NO EIN",VAR="D0":"NO DUNS",VAR="Z0":"ZIP",1:"")

 +7        IF ACRVAR]""

               SET HD1=HD1_"WITH "_ACRVAR

 +8        SET TAIL=$SELECT(ERR=1:"WITH MISSING DATA",1:"")

 +9        SET HD2=HD2_TAIL

 +10       SET TITLE="NAME^DUNS^EIN+SUFFIX^MAILING ZIP^EFT TYPE-ACCT#-EFT ROUT#"

 +11       IF TAIL["MISSING"

               SET TITLE=TITLE_U_"ERRORS"

 +12       DO HEAD^ACRFVLK2(HD1,HD2)

 +13       DO SUBHEAD^ACRFVLK2(TITLE,1)

 +14       DO LOOP(ACT,ERR,VAR)

 +15       QUIT 

 +16      ;

ADEZ(ACT) ;EP - GATHER ACTIVE VENDORS WITH DUNS, EIN, OR ZIP

 +1        NEW TITLE,NUM

 +2        DO SUBH(.ACT,.ERR,.VAR,.HD1)

 +3        SET ACRVAR=$SELECT(VAR="E1":"EIN NO.",VAR="D1":"DUNS",VAR="Z1":"ZIP",1:"")

 +4        SET HD2="SORTED BY "_ACRVAR

 +5        IF ACRVAR]""

               SET HD1=HD1_"WITH "_ACRVAR

 +6        IF ACRVAR["EIN"

               Begin DoDot:1

 +7                SET NUM=2

 +8                SET TITLE=ACRVAR_"^VENDOR NAME^DUNS^MAILING ZIP^EFT TYPE-ACCT#-ROUT#"

               End DoDot:1

 +9        IF ACRVAR["DUNS"

               Begin DoDot:1

 +10               SET NUM=3

 +11               SET TITLE=ACRVAR_"^VENDOR NAME^EIN+SUFFIX^MAILING ZIP^EFT TYPE-ACCT#-ROUT#"

               End DoDot:1

 +12       IF ACRVAR["ZIP"

               Begin DoDot:1

 +13               SET NUM=4

 +14               SET TITLE=ACRVAR_"^VENDOR NAME^EIN+SUFFIX^DUNS^EFT TYPE-ACCT#-ROUT#"

               End DoDot:1

 +15       DO HEAD^ACRFVLK2(HD1,HD2)

 +16       DO SUBHEAD^ACRFVLK2(TITLE,NUM)

 +17       DO LOOP(ACT,ERR,VAR)

 +18       QUIT 

 +19      ;

LOOP(ACT,ERR,VAR) ; LOOP THROUGH VENDOR AND SET BY NAME

 +1       ;   ---- ENTERS WITH WRITE SUBROUTINE CALL

 +2       ;        ACTIVE FLAG -- 1 OR 0

 +3       ;        ERROR FLAG  -- 1 OR 0

 +4       ;        VAR STRING  -- E(IN), D(UNS), Z(IP) + 1 FOR HAS, 0 FOR MISSING

 +5       ;

 +6        NEW ACRVREC,NUM

 +7        SET ACRVREC=0

           SET NUM=1

 +8        SET ACRERR=""

 +9        FOR 

               SET ACRVREC=$ORDER(^AUTTVNDR(ACRVREC))

               IF 'ACRVREC!($DATA(ACROUT))

                   QUIT 

               Begin DoDot:1

 +10      ;ONLY WANT IF HAS ERRORS

                   IF ERR

                       Begin DoDot:2

 +11      ;RETURNS WITH ACRERR STRING

                           DO CKVEND^ACRFUFMU(ACRVREC)

                       End DoDot:2

                       IF ACRERR=""

                           QUIT 

 +12               DO GETDATA

 +13      ;ONLY WHAT IS WANTED

                   IF ACT'=ACRACT

                       QUIT 

 +14      ;WANT MISSING DUNS

                   IF VAR="D0"

                       IF ACRDUNS]""

                           QUIT 

 +15      ;WANT DUNS

                   IF VAR="D1"

                       IF ACRDUNS=""

                           QUIT 

 +16      ;WANT MISSING EIN

                   IF VAR="E0"

                       IF ACREIN]""

                           QUIT 

 +17      ;WANT EIN

                   IF VAR="E1"

                       IF ACREIN=""

                           QUIT 

 +18      ;WANT MISSING/BAD ZIP

                   IF VAR="Z0"

                       IF $LENGTH($TRANSLATE(ACRZIP,"-",""))=9

                           QUIT 

 +19      ;WANT ZIP

                   IF VAR="Z1"

                       IF ACRZIP=""

                           QUIT 

 +20      ;SET DEFAULT FOR NAME SORT

                   SET VARN=ACRVNAM

 +21               SET STR=ACRVNAM_U_ACRDUNS_U_ACREX_U_ACRZIP_U_ACREFT

 +22      ;SORT BY DUNS

                   IF VAR="D1"

                       Begin DoDot:2

 +23                       SET VARN=ACRDUNS

                           SET NUM=2

 +24                       SET STR=ACRDUNS_U_ACRVNAM_U_ACREX_U_ACRZIP_U_ACREFT

                       End DoDot:2

 +25      ;SORT BY EIN

                   IF VAR="E1"

                       Begin DoDot:2

 +26                       SET VARN=ACREX

                           SET NUM=2

 +27                       SET STR=ACREX_U_ACRVNAM_U_ACRDUNS_U_ACRZIP_U_ACREFT

                       End DoDot:2

 +28      ;SORT BY ZIP

                   IF VAR="Z1"

                       Begin DoDot:2

 +29                       SET VARN=ACRZIP

                           SET NUM=2

 +30                       SET STR=ACRZIP_ACRVNAM_U_ACRDUNS_U_ACREX_U_ACREFT

                       End DoDot:2

 +31      ;ADD ERR STRING IF WANTED

                   IF ERR

                       SET STR=STR_U_ACRERR

 +32               SET ^TMP("ACR",$JOB,VARN)=STR

               End DoDot:1

 +33       DO WRT^ACRFVLK2(NUM)

 +34       QUIT 

GETDATA   ;SET VENDOR VARIABLES

 +1        KILL ACRV0,ACRV11,ACRV13,ACRV19,ACRZIP,ACROUT,ACRVNAM,ACRREC

 +2        KILL ACRDUNS,ACREX,ACREFTT,ACREFT,ACRACT

 +3        SET ACRV0=$GET(^AUTTVNDR(ACRVREC,0))

 +4        SET ACRV11=$GET(^AUTTVNDR(ACRVREC,11))

 +5        SET ACRV13=$GET(^AUTTVNDR(ACRVREC,13))

 +6        SET ACRV19=$GET(^AUTTVNDR(ACRVREC,19))

 +7        SET ACRZIP=$PIECE(ACRV13,U,4)

 +8        SET ACRVNAM=$PIECE(ACRV0,U)

 +9        IF ACRVNAM=""

               SET ACRVNAM="NO NAME "_ACRVREC

 +10       SET ACRDUNS=$PIECE(ACRV0,U,7)

 +11      ;EIN

           SET ACREIN=$PIECE(ACRV11,U)

 +12      ;EIN + SUFFIX

           SET ACREX=$PIECE(ACRV11,U,13)

 +13       SET ACREFTT=$PIECE(ACRV19,U)

 +14       SET ACREFT=ACREFTT_"-"_$PIECE(ACRV19,U,3)_"-"_$PIECE(ACRV19,U,2)

 +15      ;IF VENDOR IS ACTIVE

           SET ACRACT=$SELECT($$IDATE^ACRFUFMU(ACRVREC)]"":0,1:1)

 +16       QUIT