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
