AFSLDRV ;IHS/OIRM/DSD/JDM - PRINT DUPLICATE VENDORS BY EIN. [ 9/27/2005 12:53 PM ]
;;3.0t1;1166 APPROVALS FOR PAYMENT;**19**;AUG 31, 2005
;Prints list of duplicate vendors by EIN
;K ^AFSLCTMP ; SCRATCH WORK GLOBAL ;ACR*2.1*19.05 IM16848
N ACRTMP ;ACR*2.1*19.05 IM16848
S ACRTMP="^AFSLCTMP" ;ACR*2.1*19.05 IM16848
K @ACRTMP ;ACR*2.1*19.05 IM16848
;S AFSLUSR=$P(^VA(200,DUZ,0),U,1),AFSLFAC=$P(^AUTTLOC(DUZ(2),0),U,2) ;ACR*2.1*19.02 IM16848
S AFSLUSR=$$NAME2^ACRFUTL1(DUZ) ;ACR*2.1*19.02 IM16848
S AFSLFAC=$P(^AUTTLOC(DUZ(2),0),U,2) ;ACR*2.1*19.02 IM16848
U IO(0) W !!?18,"This report will generate a list of VENDORS whose" W !?18,"file contains either a DUPLICATE or MISSING EIN."
DIR ;
DEVICE ;Dev Select
U IO(0) W *7,!!?18,"Since this report may take awhile to compile" W !?18,"it is recommended that you QUEUE to a PRINTER." S AFSLIOQ=""
;K DIR S %ZIS="PQ" W ! D ^%ZIS I POP W !,"NO DEVICE SELECTED - REQUEST ABORTED" S DIR(0)="E" U IO(0) D ^DIR S IOP=$I D ^%ZIS G END:Y=0,DEVICE:Y=1 ;ACR*2.1*19.05 IM16848
K DIR S %ZIS="PQ" W ! D ^%ZIS ;ACR*2.1*19.05 IM16848
I POP D G END:Y=0,DEVICE:Y=1 ;ACR*2.1*19.05 IM16848
.W !,"NO DEVICE SELECTED - REQUEST ABORTED" ;ACR*2.1*19.05 IM16848
.S DIR(0)="E" U IO(0) D ^DIR ;ACR*2.1*19.05 IM16848
.D ^%ZIS ;ACR*2.1*19.05 IM16848
S AFSLIO=IO I $D(IO("Q"))=1 S AFSLIOQ=IO("Q")
I AFSLIOQ="" W ! D WAIT^DICD G CALC
I $D(IO("S"))!($E(IOST)'="P") G DEVICE
ZTLOAD ;Loads Taskman
S ZTRTN="CALC^AFSLDRV",ZTIO="",ZTDESC="COMPILE DUPLICATE EIN REPORT"
F AFSLSAVE="AFSLFAC(","AFSLIO","AFSLUSR","AFSLIOQ","AFSLFACP" S ZTSAVE(AFSLSAVE)=""
;D ^%ZTLOAD K IO("Q") S IOP=$I D HOME^%ZIS K IOP ;ACR*2.1*19.05 IM16848
D ^%ZTLOAD K IO("Q") D HOME^%ZIS K IOP ;ACR*2.1*19.05 IM16848
END K AFSLUSR,AFSLFAC,AFSLBAD,AFSLVNDR,AFSLEIN,AFSLDAT,AFSLIO,AFSLIOQ,AFSLPAGE,AFSLSAVE,AFSLSKIP,AFSLTIM,AFSLADRN,AFSLDAT,AFSLEIN,AFSLFAC,AFSLIO,AFSLIOQ,AFSLNODE,AFSLPAGE
K AFSLSKIP,AFSLSTAT,AFSLSTE,AFSLTIM,AFSLUSR,AFSLVNDR,AFSLDTSV,AFSLLUDT
K C,D,DCC,DI,DIR,DNP,DTOUT,DIROUT,DUOUT,DIRUT,FLDS,FR,I,POP,X,Y,%ZIS
Q
CALC ;S AFSLVNDR=0 K ^AFSLCTMP ; SCRATCH WORK GLOBAL ;ACR*2.1*19.05 IM16848
S AFSLVNDR=0 ;ACR*2.1*19.05 IM16848
N ACRTMP ;ACR*2.1*19.05 IM16848
S ACRTMP="^AFSLCTMP" ;ACR*2.1*19.05 IM16848
K @ACRTMP ;ACR*2.1*19.05 IM16848
B S AFSLVNDR=$O(^AUTTVNDR(AFSLVNDR)) I 'AFSLVNDR S AFSLEIN=0 G CHECK
I '$D(^AUTTVNDR(AFSLVNDR,11)) G B
S AFSLEIN=$S($P(^AUTTVNDR(AFSLVNDR,11),U,1):$P(^AUTTVNDR(AFSLVNDR,11),U,1)_$P(^AUTTVNDR(AFSLVNDR,11),U,2),1:"NOT ON FILE")
S ^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR)=""
I '$D(^AUTTVNDR(AFSLVNDR,13)) S AFSLADRN="^^^"
I $D(^AUTTVNDR(AFSLVNDR,13)) S AFSLADRN=^AUTTVNDR(AFSLVNDR,13)
G B
CHECK S AFSLEIN=$O(^AFSLCTMP("DUP",AFSLEIN)) G:AFSLEIN="" ZTLOAD1 S AFSLVNDR=""
VNDR S AFSLVNDR=$O(^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR)) G:AFSLVNDR="" CHECK
I '$O(^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR)),'$D(^AFSLCTMP(AFSLEIN)) K ^AFSLCTMP("DUP",AFSLEIN) G VNDR
S X="UNKNOWN" S:$D(^AUTTVNDR(AFSLVNDR,0)) X=$P(^(0),U,1)
S AFSLADRN="^^^"
I $D(^AUTTVNDR(AFSLVNDR,13)) S AFSLADRN=^AUTTVNDR(AFSLVNDR,13)
S ^AFSLCTMP(AFSLEIN,AFSLVNDR)=X_"^"_AFSLADRN
K ^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR) G VNDR
ZTLOAD1 ;Loads Taskman
I AFSLIOQ="" G PRINT
S ZTRTN="PRINT^AFSLDRV",ZTDESC="PRINT DUPLICATE EIN REPORT",ZTIO=AFSLIO,ZTSAVE("AFSLIO")="",ZTSAVE("AFSLIOQ")="",ZTSAVE("AFSLUSR")="",ZTSAVE("^AFSLCTMP(")="",ZTSAVE("AFSLFACP")=""
;D ^%ZTLOAD K IO("Q") S IOP=$I D HOME^%ZIS K IOP ;ACR*2.1*19.05 IM16848
D ^%ZTLOAD K IO("Q") D HOME^%ZIS K IOP ;ACR*2.1*19.05 IM16848
Q
PRINT S (AFSLEIN,AFSLPAGE,AFSLSKIP)=0 D HEADER S C=0
P1 S AFSLEIN=$O(^AFSLCTMP(AFSLEIN)) G TOTL:'AFSLEIN S AFSLVNDR="" I AFSLSKIP'=AFSLEIN W !
P2 S AFSLVNDR=$O(^AFSLCTMP(AFSLEIN,AFSLVNDR)) G:AFSLVNDR="" P1
S AFSLSTE=$P(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,4)
I $P(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,4)="" S AFSLSTAT=""
I $P(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,4)'="" S AFSLSTAT=$P(^DIC(5,AFSLSTE,0),U,2)
U IO W !?1,AFSLEIN,?16,$E($P(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,1),1,30) S C=C+1 W ?63,$P(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,2),?96,$P(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,3),?116,AFSLSTAT,?120,$P(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,5)
D LSTUSED
I IOST["P-"&($Y>56) D HEADER
I IOST["C-"&($Y>24) D HEADER ; K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0 D HEADER
S AFSLSKIP=AFSLEIN G P2
TOTL U IO W !!,?1,"TOTAL",?30,C
K DIR S DIR(0)="E" W !! U IO(0) D ^DIR Q:Y=0
BADEIN ;PRINTS LIST OF VENDORS WITH NO EIN ON FILE
S AFSLPAGE=0 D BADHEAD
U IO W !! S AFSLBAD="",C=0
BAD1 S AFSLBAD=$O(^AFSLCTMP("NOT ON FILE",AFSLBAD)) G BADTOTL:AFSLBAD=""
I '$D(^AUTTVNDR(AFSLBAD,0)) U IO(0) W !,"VENDOR ENTRY ",AFSLBAD," INCOMPLETE. MUST BE CORRECTED." H 5 G BAD1
U IO W !?12,$P(^AUTTVNDR(AFSLBAD,0),U,1) S C=C+1
I IOST["P-"&($Y>56) D BADHEAD
I IOST["C-"&($Y>24) D BADHEAD ; K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0 D BADHEAD
G BAD1
BADTOTL U IO W !!?1,"TOTAL",?12,C
K DIR S DIR(0)="E" W !! U IO(0) D ^DIR Q:Y=0
Q
U IO W @IOF S AFSLPAGE=AFSLPAGE+1
D NOW^%DTC,YX^%DTC S AFSLDAT=$P(Y,"@",1),AFSLTIM=$P(Y,"@",2)
U IO W !,"*",AFSLDAT S X=$P(^DIC(4,DUZ(2),0),U,1) W ?((80/2)-($L(X)/2)),X
;W ?71,AFSLTIM,"*",!,"*User: ",AFSLUSR,?70,"Device:",$J(AFSLIO,2),"*"
U IO W !! S X="DUPLICATE VENDOR EIN Report - Page " W ?((80/2)-($L(X)/2)),X_AFSLPAGE
;W !! S X="For "_$P(^AUTTLOC(AFSLFACP,0),U,2) W ?((80/2)-($L(X)/2)),X
U IO W !! F I=1:1:80 W "*"
U IO W !!?12,"VENDOR EIN",?30,"VENDOR NAME",?66,"ADDRESS"
U IO W ! F I=1:1:80 W "~"
U IO W !
Q
BADHEAD ;Missing EIN head
U IO W @IOF S AFSLPAGE=AFSLPAGE+1
D NOW^%DTC,YX^%DTC S AFSLDAT=$P(Y,"@",1),AFSLTIM=$P(Y,"@",2)
U IO W !,"*",AFSLDAT S X=$P(^DIC(4,DUZ(2),0),U,1) W ?((80/2)-($L(X)/2)),X
W ?71,AFSLTIM,"*",!,"*User: ",AFSLUSR,?70,"Device:",$J(AFSLIO,2),"*"
W !! S X="VENDOR(s) MISSING EIN Report - Page " W ?((80/2)-($L(X)/2)),X_AFSLPAGE
W !! F I=1:1:80 W "*"
W !!?8,"The following have no EIN in the VENDOR FILE." W !?25,"VALIDATE & CORRECT."
W ! F I=1:1:80 W "~"
W !
Q
LSTUSED ;CHK LAST USED DATE
S AFSLNODE=0
Q:'$D(^AFSLF(DUZ(2),"VB",AFSLVNDR))
LST2 S AFSLNODE=$O(^AFSLF(DUZ(2),"VB",AFSLVNDR,AFSLNODE)) G LSTEND:+AFSLNODE=0
S AFSLDTSV=AFSLNODE
G LST2
LSTEND S AFSLLUDT="" S:$D(AFSLDTSV) AFSLLUDT=$P(^AFSLF(DUZ(2),"D",AFSLDTSV,0),U,2)
U IO W ?65,$E(AFSLLUDT,4,5),"-",$E(AFSLLUDT,6,7),"-",$E(AFSLLUDT,2,3)
Q
AFSLDRV ;IHS/OIRM/DSD/JDM - PRINT DUPLICATE VENDORS BY EIN. [ 9/27/2005 12:53 PM ]
+1 ;;3.0t1;1166 APPROVALS FOR PAYMENT;**19**;AUG 31, 2005
+2 ;Prints list of duplicate vendors by EIN
+3 ;K ^AFSLCTMP ; SCRATCH WORK GLOBAL ;ACR*2.1*19.05 IM16848
+4 ;ACR*2.1*19.05 IM16848
NEW ACRTMP
+5 ;ACR*2.1*19.05 IM16848
SET ACRTMP="^AFSLCTMP"
+6 ;ACR*2.1*19.05 IM16848
KILL @ACRTMP
+7 ;S AFSLUSR=$P(^VA(200,DUZ,0),U,1),AFSLFAC=$P(^AUTTLOC(DUZ(2),0),U,2) ;ACR*2.1*19.02 IM16848
+8 ;ACR*2.1*19.02 IM16848
SET AFSLUSR=$$NAME2^ACRFUTL1(DUZ)
+9 ;ACR*2.1*19.02 IM16848
SET AFSLFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,2)
+10 USE IO(0)
WRITE !!?18,"This report will generate a list of VENDORS whose"
WRITE !?18,"file contains either a DUPLICATE or MISSING EIN."
DIR ;
DEVICE ;Dev Select
+1 USE IO(0)
WRITE *7,!!?18,"Since this report may take awhile to compile"
WRITE !?18,"it is recommended that you QUEUE to a PRINTER."
SET AFSLIOQ=""
+2 ;K DIR S %ZIS="PQ" W ! D ^%ZIS I POP W !,"NO DEVICE SELECTED - REQUEST ABORTED" S DIR(0)="E" U IO(0) D ^DIR S IOP=$I D ^%ZIS G END:Y=0,DEVICE:Y=1 ;ACR*2.1*19.05 IM16848
+3 ;ACR*2.1*19.05 IM16848
KILL DIR
SET %ZIS="PQ"
WRITE !
DO ^%ZIS
+4 ;ACR*2.1*19.05 IM16848
IF POP
Begin DoDot:1
+5 ;ACR*2.1*19.05 IM16848
WRITE !,"NO DEVICE SELECTED - REQUEST ABORTED"
+6 ;ACR*2.1*19.05 IM16848
SET DIR(0)="E"
USE IO(0)
DO ^DIR
+7 ;ACR*2.1*19.05 IM16848
DO ^%ZIS
End DoDot:1
IF Y=0
GOTO END
IF Y=1
GOTO DEVICE
+8 SET AFSLIO=IO
IF $DATA(IO("Q"))=1
SET AFSLIOQ=IO("Q")
+9 IF AFSLIOQ=""
WRITE !
DO WAIT^DICD
GOTO CALC
+10 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
GOTO DEVICE
ZTLOAD ;Loads Taskman
+1 SET ZTRTN="CALC^AFSLDRV"
SET ZTIO=""
SET ZTDESC="COMPILE DUPLICATE EIN REPORT"
+2 FOR AFSLSAVE="AFSLFAC(","AFSLIO","AFSLUSR","AFSLIOQ","AFSLFACP"
SET ZTSAVE(AFSLSAVE)=""
+3 ;D ^%ZTLOAD K IO("Q") S IOP=$I D HOME^%ZIS K IOP ;ACR*2.1*19.05 IM16848
+4 ;ACR*2.1*19.05 IM16848
DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
KILL IOP
END KILL AFSLUSR,AFSLFAC,AFSLBAD,AFSLVNDR,AFSLEIN,AFSLDAT,AFSLIO,AFSLIOQ,AFSLPAGE,AFSLSAVE,AFSLSKIP,AFSLTIM,AFSLADRN,AFSLDAT,AFSLEIN,AFSLFAC,AFSLIO,AFSLIOQ,AFSLNODE,AFSLPAGE
+1 KILL AFSLSKIP,AFSLSTAT,AFSLSTE,AFSLTIM,AFSLUSR,AFSLVNDR,AFSLDTSV,AFSLLUDT
+2 KILL C,D,DCC,DI,DIR,DNP,DTOUT,DIROUT,DUOUT,DIRUT,FLDS,FR,I,POP,X,Y,%ZIS
+3 QUIT
CALC ;S AFSLVNDR=0 K ^AFSLCTMP ; SCRATCH WORK GLOBAL ;ACR*2.1*19.05 IM16848
+1 ;ACR*2.1*19.05 IM16848
SET AFSLVNDR=0
+2 ;ACR*2.1*19.05 IM16848
NEW ACRTMP
+3 ;ACR*2.1*19.05 IM16848
SET ACRTMP="^AFSLCTMP"
+4 ;ACR*2.1*19.05 IM16848
KILL @ACRTMP
B SET AFSLVNDR=$ORDER(^AUTTVNDR(AFSLVNDR))
IF 'AFSLVNDR
SET AFSLEIN=0
GOTO CHECK
+1 IF '$DATA(^AUTTVNDR(AFSLVNDR,11))
GOTO B
+2 SET AFSLEIN=$SELECT($PIECE(^AUTTVNDR(AFSLVNDR,11),U,1):$PIECE(^AUTTVNDR(AFSLVNDR,11),U,1)_$PIECE(^AUTTVNDR(AFSLVNDR,11),U,2),1:"NOT ON FILE")
+3 SET ^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR)=""
+4 IF '$DATA(^AUTTVNDR(AFSLVNDR,13))
SET AFSLADRN="^^^"
+5 IF $DATA(^AUTTVNDR(AFSLVNDR,13))
SET AFSLADRN=^AUTTVNDR(AFSLVNDR,13)
+6 GOTO B
CHECK SET AFSLEIN=$ORDER(^AFSLCTMP("DUP",AFSLEIN))
IF AFSLEIN=""
GOTO ZTLOAD1
SET AFSLVNDR=""
VNDR SET AFSLVNDR=$ORDER(^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR))
IF AFSLVNDR=""
GOTO CHECK
+1 IF '$ORDER(^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR))
IF '$DATA(^AFSLCTMP(AFSLEIN))
KILL ^AFSLCTMP("DUP",AFSLEIN)
GOTO VNDR
+2 SET X="UNKNOWN"
IF $DATA(^AUTTVNDR(AFSLVNDR,0))
SET X=$PIECE(^(0),U,1)
+3 SET AFSLADRN="^^^"
+4 IF $DATA(^AUTTVNDR(AFSLVNDR,13))
SET AFSLADRN=^AUTTVNDR(AFSLVNDR,13)
+5 SET ^AFSLCTMP(AFSLEIN,AFSLVNDR)=X_"^"_AFSLADRN
+6 KILL ^AFSLCTMP("DUP",AFSLEIN,AFSLVNDR)
GOTO VNDR
ZTLOAD1 ;Loads Taskman
+1 IF AFSLIOQ=""
GOTO PRINT
+2 SET ZTRTN="PRINT^AFSLDRV"
SET ZTDESC="PRINT DUPLICATE EIN REPORT"
SET ZTIO=AFSLIO
SET ZTSAVE("AFSLIO")=""
SET ZTSAVE("AFSLIOQ")=""
SET ZTSAVE("AFSLUSR")=""
SET ZTSAVE("^AFSLCTMP(")=""
SET ZTSAVE("AFSLFACP")=""
+3 ;D ^%ZTLOAD K IO("Q") S IOP=$I D HOME^%ZIS K IOP ;ACR*2.1*19.05 IM16848
+4 ;ACR*2.1*19.05 IM16848
DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
KILL IOP
+5 QUIT
PRINT SET (AFSLEIN,AFSLPAGE,AFSLSKIP)=0
DO HEADER
SET C=0
P1 SET AFSLEIN=$ORDER(^AFSLCTMP(AFSLEIN))
IF 'AFSLEIN
GOTO TOTL
SET AFSLVNDR=""
IF AFSLSKIP'=AFSLEIN
WRITE !
P2 SET AFSLVNDR=$ORDER(^AFSLCTMP(AFSLEIN,AFSLVNDR))
IF AFSLVNDR=""
GOTO P1
+1 SET AFSLSTE=$PIECE(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,4)
+2 IF $PIECE(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,4)=""
SET AFSLSTAT=""
+3 IF $PIECE(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,4)'=""
SET AFSLSTAT=$PIECE(^DIC(5,AFSLSTE,0),U,2)
+4 USE IO
WRITE !?1,AFSLEIN,?16,$EXTRACT($PIECE(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,1),1,30)
SET C=C+1
WRITE ?63,$PIECE(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,2),?96,$PIECE(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,3),?116,AFSLSTAT,?120,$PIECE(^AFSLCTMP(AFSLEIN,AFSLVNDR),U,5)
+5 DO LSTUSED
+6 IF IOST["P-"&($Y>56)
DO HEADER
+7 ; K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0 D HEADER
IF IOST["C-"&($Y>24)
DO HEADER
+8 SET AFSLSKIP=AFSLEIN
GOTO P2
TOTL USE IO
WRITE !!,?1,"TOTAL",?30,C
+1 KILL DIR
SET DIR(0)="E"
WRITE !!
USE IO(0)
DO ^DIR
IF Y=0
QUIT
BADEIN ;PRINTS LIST OF VENDORS WITH NO EIN ON FILE
+1 SET AFSLPAGE=0
DO BADHEAD
+2 USE IO
WRITE !!
SET AFSLBAD=""
SET C=0
BAD1 SET AFSLBAD=$ORDER(^AFSLCTMP("NOT ON FILE",AFSLBAD))
IF AFSLBAD=""
GOTO BADTOTL
+1 IF '$DATA(^AUTTVNDR(AFSLBAD,0))
USE IO(0)
WRITE !,"VENDOR ENTRY ",AFSLBAD," INCOMPLETE. MUST BE CORRECTED."
HANG 5
GOTO BAD1
+2 USE IO
WRITE !?12,$PIECE(^AUTTVNDR(AFSLBAD,0),U,1)
SET C=C+1
+3 IF IOST["P-"&($Y>56)
DO BADHEAD
+4 ; K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0 D BADHEAD
IF IOST["C-"&($Y>24)
DO BADHEAD
+5 GOTO BAD1
BADTOTL USE IO
WRITE !!?1,"TOTAL",?12,C
+1 KILL DIR
SET DIR(0)="E"
WRITE !!
USE IO(0)
DO ^DIR
IF Y=0
QUIT
+2 QUIT
+1 USE IO
WRITE @IOF
SET AFSLPAGE=AFSLPAGE+1
+2 DO NOW^%DTC
DO YX^%DTC
SET AFSLDAT=$PIECE(Y,"@",1)
SET AFSLTIM=$PIECE(Y,"@",2)
+3 USE IO
WRITE !,"*",AFSLDAT
SET X=$PIECE(^DIC(4,DUZ(2),0),U,1)
WRITE ?((80/2)-($LENGTH(X)/2)),X
+4 ;W ?71,AFSLTIM,"*",!,"*User: ",AFSLUSR,?70,"Device:",$J(AFSLIO,2),"*"
+5 USE IO
WRITE !!
SET X="DUPLICATE VENDOR EIN Report - Page "
WRITE ?((80/2)-($LENGTH(X)/2)),X_AFSLPAGE
+6 ;W !! S X="For "_$P(^AUTTLOC(AFSLFACP,0),U,2) W ?((80/2)-($L(X)/2)),X
+7 USE IO
WRITE !!
FOR I=1:1:80
WRITE "*"
+8 USE IO
WRITE !!?12,"VENDOR EIN",?30,"VENDOR NAME",?66,"ADDRESS"
+9 USE IO
WRITE !
FOR I=1:1:80
WRITE "~"
+10 USE IO
WRITE !
+11 QUIT
BADHEAD ;Missing EIN head
+1 USE IO
WRITE @IOF
SET AFSLPAGE=AFSLPAGE+1
+2 DO NOW^%DTC
DO YX^%DTC
SET AFSLDAT=$PIECE(Y,"@",1)
SET AFSLTIM=$PIECE(Y,"@",2)
+3 USE IO
WRITE !,"*",AFSLDAT
SET X=$PIECE(^DIC(4,DUZ(2),0),U,1)
WRITE ?((80/2)-($LENGTH(X)/2)),X
+4 WRITE ?71,AFSLTIM,"*",!,"*User: ",AFSLUSR,?70,"Device:",$JUSTIFY(AFSLIO,2),"*"
+5 WRITE !!
SET X="VENDOR(s) MISSING EIN Report - Page "
WRITE ?((80/2)-($LENGTH(X)/2)),X_AFSLPAGE
+6 WRITE !!
FOR I=1:1:80
WRITE "*"
+7 WRITE !!?8,"The following have no EIN in the VENDOR FILE."
WRITE !?25,"VALIDATE & CORRECT."
+8 WRITE !
FOR I=1:1:80
WRITE "~"
+9 WRITE !
+10 QUIT
LSTUSED ;CHK LAST USED DATE
+1 SET AFSLNODE=0
+2 IF '$DATA(^AFSLF(DUZ(2),"VB",AFSLVNDR))
QUIT
LST2 SET AFSLNODE=$ORDER(^AFSLF(DUZ(2),"VB",AFSLVNDR,AFSLNODE))
IF +AFSLNODE=0
GOTO LSTEND
+1 SET AFSLDTSV=AFSLNODE
+2 GOTO LST2
LSTEND SET AFSLLUDT=""
IF $DATA(AFSLDTSV)
SET AFSLLUDT=$PIECE(^AFSLF(DUZ(2),"D",AFSLDTSV,0),U,2)
+1 USE IO
WRITE ?65,$EXTRACT(AFSLLUDT,4,5),"-",$EXTRACT(AFSLLUDT,6,7),"-",$EXTRACT(AFSLLUDT,2,3)
+2 QUIT
