AUTVDUP ; IHS/DIR/JDM/DFM - SEARCH FOR DUP EIN NUMBERS IN VENDOR FILE ; [ 06/28/1999 2:24 PM ]
;;98.1;IHS DICTIONARIES (POINTERS);**2**;MAR 04, 1998;Build 6
; IHS/ASDST/GTH AUT*98.1*2 - Y2K Fix, display 4-digit year.
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." Q
D HOME^%ZIS,DT^DICRW
W !!,$$CTR("This report will generate a list of VENDORS whose",80),!,$$CTR("file contains either a DUPLICATE or MISSING EIN.",80)
DEVICE ;Device Selection
W *7,!!,$$CTR("Since this report may take awhile to compile",80),!,$$CTR("it is recommended that you QUEUE to a PRINTER.",80)
K DIR S %ZIS="PQ" W ! D ^%ZIS I POP W !,"NO DEVICE SELECTED - REQUEST ABORTED" S DIR(0)="E" D ^DIR S IOP=$I D ^%ZIS G END:Y=0,DEVICE:Y=1
I '$D(IO("Q")) G CALC
;
S ZTRTN="CALC^AUTVDUP",ZTDESC="DUPLICATE EIN REPORT"
D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS
END ;
K DIR,DTOUT,DIROUT,DUOUT,DIRUT,C,I,^TMP($J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
CALC ;EP - From TaskMan
NEW AUTBAD,AUTDAT,AUTEIN,AUTPAGE,AUTSKIP,AUTTIM,AUTVNDR
I '$D(ZTQUEUED),'$D(IO("S")) U IO(0) D WAIT^DICD U IO
K ^TMP($J),E,V ; E is EIN, V is IEN
S V=0
F S V=$O(^AUTTVNDR(V)) Q:'V I $D(^AUTTVNDR(V,11)) S ^TMP($J,"DUP",$S($P(^AUTTVNDR(V,11),U):$P(^AUTTVNDR(V,11),U)_$P(^AUTTVNDR(V,11),U,2),1:"NOT ON FILE"),V)=""
I '$D(^TMP($J,"DUP")) G PRINT
S E=0
CHECK1 ; Check EIN.
S E=$O(^TMP($J,"DUP",E))
I E="" K E,V,^TMP($J,"DUP") G PRINT
S V=""
VNDR ; Check vendor(s) with this EIN.
S V=$O(^TMP($J,"DUP",E,V))
G:V="" CHECK1
I '$O(^TMP($J,"DUP",E,V)),'$D(^TMP($J,E)) K ^TMP($J,"DUP",E) G VNDR
S ^TMP($J,E,V)=$S($D(^AUTTVNDR(V,0)):$P(^(0),U),1:"UNKNOWN")
G VNDR
PRINT ;
S (AUTEIN,AUTPAGE,AUTSKIP)=0
D NOW^%DTC,YX^%DTC S AUTDAT=$P(Y,"@",1),AUTTIM=$P(Y,"@",2)
D HEADER,HDR S C=0
I '$D(^TMP($J)) G END
P1 S AUTEIN=$O(^TMP($J,AUTEIN))
G TOTL:'AUTEIN S AUTVNDR=""
I AUTSKIP'=AUTEIN W !
P2 S AUTVNDR=$O(^TMP($J,AUTEIN,AUTVNDR))
G:AUTVNDR="" P1
W !,?12,AUTEIN,?30,$E($P(^TMP($J,AUTEIN,AUTVNDR),U),1,30) S C=C+1
D LSTUSED(AUTVNDR)
I IOST["P-"&($Y>(IOSL-10)) D HEADER,HDR
I IOST["C-",'$D(IO("S"))&($Y>(IOSL-4)) K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0 D HEADER,HDR
S AUTSKIP=AUTEIN
G P2
TOTL W !!,?1,"TOTAL",?30,C
I IOST["C-",'$D(IO("S")) K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0
BADEIN ; Print list of Vendors with no EIN on file
S AUTPAGE=0
D BADHEAD
I '$D(^TMP($J,"NOT ON FILE")) W !!,"Good for YOU!! All VENDORS in your file have EIN's!" G END
S %=0 F S %=$O(^TMP($J,"NOT ON FILE",%)) Q:'$D(^AUTTVNDR(%)) S ^TMP($J,"NOT ON FILE",$P(^AUTTVNDR(%,0),U))="" K ^TMP($J,"NOT ON FILE",%)
W !! S AUTBAD="",C=0
BAD1 S AUTBAD=$O(^TMP($J,"NOT ON FILE",AUTBAD))
G BADTOTL:AUTBAD=""
W !,?12,AUTBAD S C=C+1
I IOST["P-"&($Y>(IOSL-10)) D BADHEAD
I IOST["C-",'$D(IO("S"))&($Y>(IOSL-4)) K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0 D BADHEAD
G BAD1
BADTOTL ;
W !!,?1,"TOTAL",?12,C
I IOST["C-",'$D(IO("S")) K DIR S DIR(0)="E" W !! D ^DIR Q:Y=0
W @IOF
G END
S AUTPAGE=AUTPAGE+1
W @IOF,!,"*",AUTDAT,$$CTR($$LOC,(80-(2*$X))),?80-$L(AUTTIM_"*"),AUTTIM,"*",!,"*User: ",$$USR,$$CTR("DUPLICATE VENDOR EIN - Page "_AUTPAGE,(80-(2*$X))),?80-$L("Device:"_IO_"*"),"Device:",IO,"*",!,$$DUP("*",80)
Q
HDR ;
W !!?12,"VENDOR EIN",?30,"VENDOR NAME",?66,"LAST USED CHS",!,$$DUP("~",80),!
Q
;
BADHEAD ; Prints heading of missing EIN's
D HEADER
W !!,$$CTR("The following do(es) not have an EIN entry in the VENDOR FILE.",80),!,$$CTR("PLEASE validate and correct.",80),!,$$DUP("~",80),!
Q
;
LSTUSED(V) ; Checks last used date in ^ACHSF(,"VB"
NEW D,I,L ; I = IEN, L = Location, V = Vendor ien
S L=0
; begin IHS/ASDST/GTH AUT*98.1*2 - Y2K Fix, display 4-digit year.
; F S L=$O(^ACHSF(L)) Q:'L S I=0 F S I=$O(^ACHSF(L,"VB",V,I)) Q:'I S D=I
; Q:'$D(D)
; S %=$P($G(^ACHSF(I,"D",D,0)),U,2)
; W ?65,$E(%,4,5),"-",$E(%,6,7),"-",$E(%,2,3)
;
F Q:'$O(^ACHSF(L)) S L=$O(^ACHSF(L)) S I=0 F S I=$O(^ACHSF(L,"VB",V,I)) Q:'I S D(L)=I
Q:'$D(D)
S %=0
F S %=$O(D(%)) Q:'% S D(%)=$P($G(^ACHSF(%,"D",D(%),0)),U,2)
S (%,D)=0
F S %=$O(D(%)) Q:'% I D(%)>D S D=D(%)
W ?66,$$FMTE^XLFDT(D,5)
; end IHS/ASDST/GTH AUT*98.1*2 - Y2K Fix, display 4-digit year.
;
Q
;
LOC() Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
USR() Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
CTR(X,Y) ; Center X in field of length Y.
S %=$S($D(Y):Y,$D(IOM):IOM,1:80)
Q $J("",%-$L(X)\2)_X
DUP(X,Y) ; Duplicate X for Y times.
S %="",$P(%,X,Y+1)=""
Q %
AUTVDUP ; IHS/DIR/JDM/DFM - SEARCH FOR DUP EIN NUMBERS IN VENDOR FILE ; [ 06/28/1999 2:24 PM ]
+1 ;;98.1;IHS DICTIONARIES (POINTERS);**2**;MAR 04, 1998;Build 6
+2 ; IHS/ASDST/GTH AUT*98.1*2 - Y2K Fix, display 4-digit year.
+3 ;
+4 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
QUIT
+5 DO HOME^%ZIS
DO DT^DICRW
+6 WRITE !!,$$CTR("This report will generate a list of VENDORS whose",80),!,$$CTR("file contains either a DUPLICATE or MISSING EIN.",80)
DEVICE ;Device Selection
+1 WRITE *7,!!,$$CTR("Since this report may take awhile to compile",80),!,$$CTR("it is recommended that you QUEUE to a PRINTER.",80)
+2 KILL DIR
SET %ZIS="PQ"
WRITE !
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED - REQUEST ABORTED"
SET DIR(0)="E"
DO ^DIR
SET IOP=$IO
DO ^%ZIS
IF Y=0
GOTO END
IF Y=1
GOTO DEVICE
+3 IF '$DATA(IO("Q"))
GOTO CALC
+4 ;
+5 SET ZTRTN="CALC^AUTVDUP"
SET ZTDESC="DUPLICATE EIN REPORT"
+6 DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO HOME^%ZIS
END ;
+1 KILL DIR,DTOUT,DIROUT,DUOUT,DIRUT,C,I,^TMP($JOB)
+2 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
CALC ;EP - From TaskMan
+1 NEW AUTBAD,AUTDAT,AUTEIN,AUTPAGE,AUTSKIP,AUTTIM,AUTVNDR
+2 IF '$DATA(ZTQUEUED)
IF '$DATA(IO("S"))
USE IO(0)
DO WAIT^DICD
USE IO
+3 ; E is EIN, V is IEN
KILL ^TMP($JOB),E,V
+4 SET V=0
+5 FOR
SET V=$ORDER(^AUTTVNDR(V))
IF 'V
QUIT
IF $DATA(^AUTTVNDR(V,11))
SET ^TMP($JOB,"DUP",$SELECT($PIECE(^AUTTVNDR(V,11),U):$PIECE(^AUTTVNDR(V,11),U)_$PIECE(^AUTTVNDR(V,11),U,2),1:"NOT ON FILE"),V)=""
+6 IF '$DATA(^TMP($JOB,"DUP"))
GOTO PRINT
+7 SET E=0
CHECK1 ; Check EIN.
+1 SET E=$ORDER(^TMP($JOB,"DUP",E))
+2 IF E=""
KILL E,V,^TMP($JOB,"DUP")
GOTO PRINT
+3 SET V=""
VNDR ; Check vendor(s) with this EIN.
+1 SET V=$ORDER(^TMP($JOB,"DUP",E,V))
+2 IF V=""
GOTO CHECK1
+3 IF '$ORDER(^TMP($JOB,"DUP",E,V))
IF '$DATA(^TMP($JOB,E))
KILL ^TMP($JOB,"DUP",E)
GOTO VNDR
+4 SET ^TMP($JOB,E,V)=$SELECT($DATA(^AUTTVNDR(V,0)):$PIECE(^(0),U),1:"UNKNOWN")
+5 GOTO VNDR
PRINT ;
+1 SET (AUTEIN,AUTPAGE,AUTSKIP)=0
+2 DO NOW^%DTC
DO YX^%DTC
SET AUTDAT=$PIECE(Y,"@",1)
SET AUTTIM=$PIECE(Y,"@",2)
+3 DO HEADER
DO HDR
SET C=0
+4 IF '$DATA(^TMP($JOB))
GOTO END
P1 SET AUTEIN=$ORDER(^TMP($JOB,AUTEIN))
+1 IF 'AUTEIN
GOTO TOTL
SET AUTVNDR=""
+2 IF AUTSKIP'=AUTEIN
WRITE !
P2 SET AUTVNDR=$ORDER(^TMP($JOB,AUTEIN,AUTVNDR))
+1 IF AUTVNDR=""
GOTO P1
+2 WRITE !,?12,AUTEIN,?30,$EXTRACT($PIECE(^TMP($JOB,AUTEIN,AUTVNDR),U),1,30)
SET C=C+1
+3 DO LSTUSED(AUTVNDR)
+4 IF IOST["P-"&($Y>(IOSL-10))
DO HEADER
DO HDR
+5 IF IOST["C-"
IF '$DATA(IO("S"))&($Y>(IOSL-4))
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
IF Y=0
QUIT
DO HEADER
DO HDR
+6 SET AUTSKIP=AUTEIN
+7 GOTO P2
TOTL WRITE !!,?1,"TOTAL",?30,C
+1 IF IOST["C-"
IF '$DATA(IO("S"))
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
IF Y=0
QUIT
BADEIN ; Print list of Vendors with no EIN on file
+1 SET AUTPAGE=0
+2 DO BADHEAD
+3 IF '$DATA(^TMP($JOB,"NOT ON FILE"))
WRITE !!,"Good for YOU!! All VENDORS in your file have EIN's!"
GOTO END
+4 SET %=0
FOR
SET %=$ORDER(^TMP($JOB,"NOT ON FILE",%))
IF '$DATA(^AUTTVNDR(%))
QUIT
SET ^TMP($JOB,"NOT ON FILE",$PIECE(^AUTTVNDR(%,0),U))=""
KILL ^TMP($JOB,"NOT ON FILE",%)
+5 WRITE !!
SET AUTBAD=""
SET C=0
BAD1 SET AUTBAD=$ORDER(^TMP($JOB,"NOT ON FILE",AUTBAD))
+1 IF AUTBAD=""
GOTO BADTOTL
+2 WRITE !,?12,AUTBAD
SET C=C+1
+3 IF IOST["P-"&($Y>(IOSL-10))
DO BADHEAD
+4 IF IOST["C-"
IF '$DATA(IO("S"))&($Y>(IOSL-4))
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
IF Y=0
QUIT
DO BADHEAD
+5 GOTO BAD1
BADTOTL ;
+1 WRITE !!,?1,"TOTAL",?12,C
+2 IF IOST["C-"
IF '$DATA(IO("S"))
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
IF Y=0
QUIT
+3 WRITE @IOF
+4 GOTO END
+1 SET AUTPAGE=AUTPAGE+1
+2 WRITE @IOF,!,"*",AUTDAT,$$CTR($$LOC,(80-(2*$X))),?80-$LENGTH(AUTTIM_"*"),AUTTIM,"*",!,"*User: ",$$USR,$$CTR("DUPLICATE VENDOR EIN - Page "_AUTPAGE,(80-(2*$X))),?80-$LENGTH("Device:"_IO_"*"),"Device:",IO,"*",!,$$DUP("*",80)
+3 QUIT
HDR ;
+1 WRITE !!?12,"VENDOR EIN",?30,"VENDOR NAME",?66,"LAST USED CHS",!,$$DUP("~",80),!
+2 QUIT
+3 ;
BADHEAD ; Prints heading of missing EIN's
+1 DO HEADER
+2 WRITE !!,$$CTR("The following do(es) not have an EIN entry in the VENDOR FILE.",80),!,$$CTR("PLEASE validate and correct.",80),!,$$DUP("~",80),!
+3 QUIT
+4 ;
LSTUSED(V) ; Checks last used date in ^ACHSF(,"VB"
+1 ; I = IEN, L = Location, V = Vendor ien
NEW D,I,L
+2 SET L=0
+3 ; begin IHS/ASDST/GTH AUT*98.1*2 - Y2K Fix, display 4-digit year.
+4 ; F S L=$O(^ACHSF(L)) Q:'L S I=0 F S I=$O(^ACHSF(L,"VB",V,I)) Q:'I S D=I
+5 ; Q:'$D(D)
+6 ; S %=$P($G(^ACHSF(I,"D",D,0)),U,2)
+7 ; W ?65,$E(%,4,5),"-",$E(%,6,7),"-",$E(%,2,3)
+8 ;
+9 FOR
IF '$ORDER(^ACHSF(L))
QUIT
SET L=$ORDER(^ACHSF(L))
SET I=0
FOR
SET I=$ORDER(^ACHSF(L,"VB",V,I))
IF 'I
QUIT
SET D(L)=I
+10 IF '$DATA(D)
QUIT
+11 SET %=0
+12 FOR
SET %=$ORDER(D(%))
IF '%
QUIT
SET D(%)=$PIECE($GET(^ACHSF(%,"D",D(%),0)),U,2)
+13 SET (%,D)=0
+14 FOR
SET %=$ORDER(D(%))
IF '%
QUIT
IF D(%)>D
SET D=D(%)
+15 WRITE ?66,$$FMTE^XLFDT(D,5)
+16 ; end IHS/ASDST/GTH AUT*98.1*2 - Y2K Fix, display 4-digit year.
+17 ;
+18 QUIT
+19 ;
LOC() QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
USR() QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
CTR(X,Y) ; Center X in field of length Y.
+1 SET %=$SELECT($DATA(Y):Y,$DATA(IOM):IOM,1:80)
+2 QUIT $JUSTIFY("",%-$LENGTH(X)\2)_X
DUP(X,Y) ; Duplicate X for Y times.
+1 SET %=""
SET $PIECE(%,X,Y+1)=""
+2 QUIT %
