ACHSYDRV ; IHS/ITSC/PMF - SEARCH FOR DUP EIN NUMBERS IN VENDOR FILE ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
; This report will generate a list of VENDORS whose file
; contains either a DUPLICATE or MISSING EIN.
; Kernel variables need to be defined.
;
S ACHSUSR=$$USR^ACHS,ACHSFAC=$P(^AUTTLOC(DUZ(2),0),U,2)
W !!?18,"This report will generate a list of VENDORS whose",!?18,"file contains either a DUPLICATE or MISSING EIN."
DEVICE ;Device Selection
W *7,!!?18,"Since this report may take awhile to compile",!?18,"it is recommended that you QUEUE to a PRINTER.",!
S %ZIS="PQ"
D ^%ZIS
I POP W !,"NO DEVICE SELECTED - REQUEST ABORTED" D HOME^%ZIS S Y=$$DIR^XBDIR("E") G END:Y=0,DEVICE:Y=1
I '$D(IO("Q")) W:'$D(IO("S")) ! D:'$D(IO("S")) WAIT^DICD G CALC
;
S ZTRTN="CALC^ACHSYDRV",ZTIO="",ZTDESC="DUPLICATE EIN REPORT",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL_$S($D(IOPAR):U_IOPAR,1:"")
F %="ACHSFAC","ACHSUSR","ACHSQIO","ACHSFACP" S ZTSAVE(%)=""
D ^%ZTLOAD
K IO("Q"),ZTSK
D HOME^%ZIS
END ;
K ACHSUSR,DIR,DTOUT,DIROUT,DUOUT,DIRUT,ACHSFAC,ACHSBAD,ACHSVNDR,ACHSEIN,ACHSDAT,ACHSQIO,ACHSPAGE,ACHSSAVE,ACHSSKIP,ACHSTIM,C,I,^TMP("ACHSYDRV",$J)
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
D ERPT^ACHS
Q
;
CALC ;EP - From TaskMan
; E is EIN, V is IEN
N ACHSLUDT,ACHSNODE
K ^TMP("ACHSYDRV",$J),E,V
S V=0
F S V=$O(^AUTTVNDR(V)) Q:'V I $D(^AUTTVNDR(V,11)) S ^TMP("ACHSYDRV",$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("ACHSYDRV",$J,"DUP")) G PRINT
S E=0
CHECK1 ;
S E=$O(^TMP("ACHSYDRV",$J,"DUP",E))
I E="" K E,V G PRINT
S V=""
VNDR ;
S V=$O(^TMP("ACHSYDRV",$J,"DUP",E,V))
G:V="" CHECK1
I '$O(^TMP("ACHSYDRV",$J,"DUP",E,V)),'$D(^TMP("ACHSYDRV",$J,E)) K ^TMP("ACHSYDRV",$J,"DUP",E) G VNDR
S X="UNKNOWN"
S:$D(^AUTTVNDR(V,0)) X=$P(^(0),U)
S ^TMP("ACHSYDRV",$J,E,V)=X
K ^TMP("ACHSYDRV",$J,"DUP",E,V)
G VNDR
;
PRINT ;
D BRPT^ACHSFU
S (ACHSEIN,ACHSPAGE,ACHSSKIP)=0
D HEADER
S C=0
I '$D(^TMP("ACHSYDRV",$J)) G END
P1 ;
S ACHSEIN=$O(^TMP("ACHSYDRV",$J,ACHSEIN))
G TOTL:'ACHSEIN
S ACHSVNDR=""
I ACHSSKIP'=ACHSEIN W !
P2 ;
S ACHSVNDR=$O(^TMP("ACHSYDRV",$J,ACHSEIN,ACHSVNDR))
G:ACHSVNDR="" P1
U IO
W !?12,ACHSEIN,?30,$E($P(^TMP("ACHSYDRV",$J,ACHSEIN,ACHSVNDR),U),1,30)
S C=C+1
D LSTUSED
I IOST["P-",$Y>(IOSL-10) D HEADER
I IOST["C-",'$D(IO("S")),$Y>(IOSL-6) Q:'$$DIR^XBDIR("E","","","","","",2) D HEADER
S ACHSSKIP=ACHSEIN
G P2
;
TOTL ;
U IO
W !!?1,"TOTAL",?30,C
I IOST["C-",'$D(IO("S")) Q:'$$DIR^XBDIR("E","","","","","",2)
BADEIN ; Print list of Vendors with no EIN on file
S ACHSPAGE=0
D BADHEAD
I '$D(^TMP("ACHSYDRV",$J,"NOT ON FILE")) U IO W !!,"Good for YOU!! All VENDORS in your file have EIN's!" G END
W !!
S ACHSBAD="",C=0
BAD1 ;
S ACHSBAD=$O(^TMP("ACHSYDRV",$J,"NOT ON FILE",ACHSBAD))
G BADTOTL:ACHSBAD=""
W !?12,$P(^AUTTVNDR(ACHSBAD,0),U)
S C=C+1
I IOST["P-",$Y>(IOSL-10) D BADHEAD
I IOST["C-",'$D(IO("S")),$Y>(IOSL-6) Q:'$$DIR^XBDIR("E","","","","","",2) D BADHEAD
G BAD1
;
BADTOTL ;
U IO
W !!?1,"TOTAL",?12,C
I IOST["C-",'$D(IO("S")) Q:'$$DIR^XBDIR("E","","","","","",2)
W @IOF
G END
;
U IO
W @IOF
S ACHSPAGE=ACHSPAGE+1
S Y=$$HTE^XLFDT($H),ACHSDAT=$P(Y,"@",1),ACHSTIM=$P(Y,"@",2)
W !,"*",ACHSDAT
S X=$$LOC^ACHS
W ?((80/2)-($L(X)/2)),X,!!
S X="DUPLICATE VENDOR EIN Report - Page "
W ?((80/2)-($L(X)/2)),X_ACHSPAGE
W !!,$$REPEAT^XLFSTR("*",80)
W !!?12,"VENDOR EIN",?30,"VENDOR NAME",?66,"LAST USED"
W !,$$REPEAT^XLFSTR("~",80),!
Q
;
BADHEAD ;Prints heading of missing EIN's
W @IOF
S ACHSPAGE=ACHSPAGE+1
S Y=$$HTE^XLFDT($H),ACHSDAT=$P(Y,"@",1),ACHSTIM=$P(Y,"@",2)
W !,"*",ACHSDAT
S X=$$LOC^ACHS
W ?((80/2)-($L(X)/2)),X
W ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*",!!
S X="VENDOR(s) MISSING EIN Report - Page "
W ?((80/2)-($L(X)/2)),X_ACHSPAGE
W !!,$$REPEAT^XLFSTR("*",80)
W !!?8,"The following do(es) not have an EIN entry in the VENDOR FILE."
W !?25,"PLEASE validate and correct."
W !,$$REPEAT^XLFSTR("~",80),!
Q
;
LSTUSED ;CHECKS LAST USED DATE IN ^ACHSF(DUZ(2),"VB"
S ACHSNODE=0
Q:'$D(^ACHSF(DUZ(2),"VB",ACHSVNDR))
LST2 ;
S ACHSNODE=$O(^ACHSF(DUZ(2),"VB",ACHSVNDR,ACHSNODE))
G LSTEND:+ACHSNODE=0
S ACHSDTSV=ACHSNODE
G LST2
;
LSTEND ;
S ACHSLUDT=""
S:$D(ACHSDTSV) ACHSLUDT=$P(^ACHSF(DUZ(2),"D",ACHSDTSV,0),U,2)
U IO
W ?65,$E(ACHSLUDT,4,5),"-",$E(ACHSLUDT,6,7),"-",$E(ACHSLUDT,2,3)
Q
;
ACHSYDRV ; IHS/ITSC/PMF - SEARCH FOR DUP EIN NUMBERS IN VENDOR FILE ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 ; This report will generate a list of VENDORS whose file
+4 ; contains either a DUPLICATE or MISSING EIN.
+5 ; Kernel variables need to be defined.
+6 ;
+7 SET ACHSUSR=$$USR^ACHS
SET ACHSFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,2)
+8 WRITE !!?18,"This report will generate a list of VENDORS whose",!?18,"file contains either a DUPLICATE or MISSING EIN."
DEVICE ;Device Selection
+1 WRITE *7,!!?18,"Since this report may take awhile to compile",!?18,"it is recommended that you QUEUE to a PRINTER.",!
+2 SET %ZIS="PQ"
+3 DO ^%ZIS
+4 IF POP
WRITE !,"NO DEVICE SELECTED - REQUEST ABORTED"
DO HOME^%ZIS
SET Y=$$DIR^XBDIR("E")
IF Y=0
GOTO END
IF Y=1
GOTO DEVICE
+5 IF '$DATA(IO("Q"))
IF '$DATA(IO("S"))
WRITE !
IF '$DATA(IO("S"))
DO WAIT^DICD
GOTO CALC
+6 ;
+7 SET ZTRTN="CALC^ACHSYDRV"
SET ZTIO=""
SET ZTDESC="DUPLICATE EIN REPORT"
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL_$SELECT($DATA(IOPAR):U_IOPAR,1:"")
+8 FOR %="ACHSFAC","ACHSUSR","ACHSQIO","ACHSFACP"
SET ZTSAVE(%)=""
+9 DO ^%ZTLOAD
+10 KILL IO("Q"),ZTSK
+11 DO HOME^%ZIS
END ;
+1 KILL ACHSUSR,DIR,DTOUT,DIROUT,DUOUT,DIRUT,ACHSFAC,ACHSBAD,ACHSVNDR,ACHSEIN,ACHSDAT,ACHSQIO,ACHSPAGE,ACHSSAVE,ACHSSKIP,ACHSTIM,C,I,^TMP("ACHSYDRV",$JOB)
+2 DO ^%ZISC
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 DO ERPT^ACHS
+5 QUIT
+6 ;
CALC ;EP - From TaskMan
+1 ; E is EIN, V is IEN
+2 NEW ACHSLUDT,ACHSNODE
+3 KILL ^TMP("ACHSYDRV",$JOB),E,V
+4 SET V=0
+5 FOR
SET V=$ORDER(^AUTTVNDR(V))
IF 'V
QUIT
IF $DATA(^AUTTVNDR(V,11))
SET ^TMP("ACHSYDRV",$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("ACHSYDRV",$JOB,"DUP"))
GOTO PRINT
+7 SET E=0
CHECK1 ;
+1 SET E=$ORDER(^TMP("ACHSYDRV",$JOB,"DUP",E))
+2 IF E=""
KILL E,V
GOTO PRINT
+3 SET V=""
VNDR ;
+1 SET V=$ORDER(^TMP("ACHSYDRV",$JOB,"DUP",E,V))
+2 IF V=""
GOTO CHECK1
+3 IF '$ORDER(^TMP("ACHSYDRV",$JOB,"DUP",E,V))
IF '$DATA(^TMP("ACHSYDRV",$JOB,E))
KILL ^TMP("ACHSYDRV",$JOB,"DUP",E)
GOTO VNDR
+4 SET X="UNKNOWN"
+5 IF $DATA(^AUTTVNDR(V,0))
SET X=$PIECE(^(0),U)
+6 SET ^TMP("ACHSYDRV",$JOB,E,V)=X
+7 KILL ^TMP("ACHSYDRV",$JOB,"DUP",E,V)
+8 GOTO VNDR
+9 ;
PRINT ;
+1 DO BRPT^ACHSFU
+2 SET (ACHSEIN,ACHSPAGE,ACHSSKIP)=0
+3 DO HEADER
+4 SET C=0
+5 IF '$DATA(^TMP("ACHSYDRV",$JOB))
GOTO END
P1 ;
+1 SET ACHSEIN=$ORDER(^TMP("ACHSYDRV",$JOB,ACHSEIN))
+2 IF 'ACHSEIN
GOTO TOTL
+3 SET ACHSVNDR=""
+4 IF ACHSSKIP'=ACHSEIN
WRITE !
P2 ;
+1 SET ACHSVNDR=$ORDER(^TMP("ACHSYDRV",$JOB,ACHSEIN,ACHSVNDR))
+2 IF ACHSVNDR=""
GOTO P1
+3 USE IO
+4 WRITE !?12,ACHSEIN,?30,$EXTRACT($PIECE(^TMP("ACHSYDRV",$JOB,ACHSEIN,ACHSVNDR),U),1,30)
+5 SET C=C+1
+6 DO LSTUSED
+7 IF IOST["P-"
IF $Y>(IOSL-10)
DO HEADER
+8 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>(IOSL-6)
IF '$$DIR^XBDIR("E","","","","","",2)
QUIT
DO HEADER
+9 SET ACHSSKIP=ACHSEIN
+10 GOTO P2
+11 ;
TOTL ;
+1 USE IO
+2 WRITE !!?1,"TOTAL",?30,C
+3 IF IOST["C-"
IF '$DATA(IO("S"))
IF '$$DIR^XBDIR("E","","","","","",2)
QUIT
BADEIN ; Print list of Vendors with no EIN on file
+1 SET ACHSPAGE=0
+2 DO BADHEAD
+3 IF '$DATA(^TMP("ACHSYDRV",$JOB,"NOT ON FILE"))
USE IO
WRITE !!,"Good for YOU!! All VENDORS in your file have EIN's!"
GOTO END
+4 WRITE !!
+5 SET ACHSBAD=""
SET C=0
BAD1 ;
+1 SET ACHSBAD=$ORDER(^TMP("ACHSYDRV",$JOB,"NOT ON FILE",ACHSBAD))
+2 IF ACHSBAD=""
GOTO BADTOTL
+3 WRITE !?12,$PIECE(^AUTTVNDR(ACHSBAD,0),U)
+4 SET C=C+1
+5 IF IOST["P-"
IF $Y>(IOSL-10)
DO BADHEAD
+6 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>(IOSL-6)
IF '$$DIR^XBDIR("E","","","","","",2)
QUIT
DO BADHEAD
+7 GOTO BAD1
+8 ;
BADTOTL ;
+1 USE IO
+2 WRITE !!?1,"TOTAL",?12,C
+3 IF IOST["C-"
IF '$DATA(IO("S"))
IF '$$DIR^XBDIR("E","","","","","",2)
QUIT
+4 WRITE @IOF
+5 GOTO END
+6 ;
+1 USE IO
+2 WRITE @IOF
+3 SET ACHSPAGE=ACHSPAGE+1
+4 SET Y=$$HTE^XLFDT($HOROLOG)
SET ACHSDAT=$PIECE(Y,"@",1)
SET ACHSTIM=$PIECE(Y,"@",2)
+5 WRITE !,"*",ACHSDAT
+6 SET X=$$LOC^ACHS
+7 WRITE ?((80/2)-($LENGTH(X)/2)),X,!!
+8 SET X="DUPLICATE VENDOR EIN Report - Page "
+9 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSPAGE
+10 WRITE !!,$$REPEAT^XLFSTR("*",80)
+11 WRITE !!?12,"VENDOR EIN",?30,"VENDOR NAME",?66,"LAST USED"
+12 WRITE !,$$REPEAT^XLFSTR("~",80),!
+13 QUIT
+14 ;
BADHEAD ;Prints heading of missing EIN's
+1 WRITE @IOF
+2 SET ACHSPAGE=ACHSPAGE+1
+3 SET Y=$$HTE^XLFDT($HOROLOG)
SET ACHSDAT=$PIECE(Y,"@",1)
SET ACHSTIM=$PIECE(Y,"@",2)
+4 WRITE !,"*",ACHSDAT
+5 SET X=$$LOC^ACHS
+6 WRITE ?((80/2)-($LENGTH(X)/2)),X
+7 WRITE ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*",!!
+8 SET X="VENDOR(s) MISSING EIN Report - Page "
+9 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSPAGE
+10 WRITE !!,$$REPEAT^XLFSTR("*",80)
+11 WRITE !!?8,"The following do(es) not have an EIN entry in the VENDOR FILE."
+12 WRITE !?25,"PLEASE validate and correct."
+13 WRITE !,$$REPEAT^XLFSTR("~",80),!
+14 QUIT
+15 ;
LSTUSED ;CHECKS LAST USED DATE IN ^ACHSF(DUZ(2),"VB"
+1 SET ACHSNODE=0
+2 IF '$DATA(^ACHSF(DUZ(2),"VB",ACHSVNDR))
QUIT
LST2 ;
+1 SET ACHSNODE=$ORDER(^ACHSF(DUZ(2),"VB",ACHSVNDR,ACHSNODE))
+2 IF +ACHSNODE=0
GOTO LSTEND
+3 SET ACHSDTSV=ACHSNODE
+4 GOTO LST2
+5 ;
LSTEND ;
+1 SET ACHSLUDT=""
+2 IF $DATA(ACHSDTSV)
SET ACHSLUDT=$PIECE(^ACHSF(DUZ(2),"D",ACHSDTSV,0),U,2)
+3 USE IO
+4 WRITE ?65,$EXTRACT(ACHSLUDT,4,5),"-",$EXTRACT(ACHSLUDT,6,7),"-",$EXTRACT(ACHSLUDT,2,3)
+5 QUIT
+6 ;
