Routine: ACHSYDRV

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

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

HEADER ;Prints heading

 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),!

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),!

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)

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       ;

HEADER    ;Prints heading

 +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       ;

ACHSYDRV.m