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
