APCDPTAB.m

APCDPTAB ; IHS/CMI/LAB - Provider table print

 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 ;

 ;

 ;

EP ;EP - called from option interactive

 D EOJ

 W:$D(IOF) @IOF

 S APCDTEXT="INTROT" F APCDJ=1:1 S APCDX=$T(@APCDTEXT+APCDJ) Q:$P(APCDX,";;",2)="END"  S APCDT=$P(APCDX,";;",2) W !,APCDT

PROVKEY ;

 K APCDTRIM S APCDTRIT=""

 S DIR(0)="S^A:All Users;P:Providers Only (defined by having the PROVIDER key)",DIR("A")="List which set of entries",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) G EOJ

 S APCDPKEY=Y

ACTIVE ;

 K APCDSTAT

 S DIR(0)="S^A:Active Providers;I:Inactive Providers;B:Both Active and Inactive Providers",DIR("A")="List which set of providers",DIR("B")="A" K DA D ^DIR K DIR

 I $D(DIRUT) G PROVKEY

 S APCDSTAT=Y,APCDSTAN=Y(0)

AFFL ;

 K APCDAFFM S APCDAFFT=""

 S DIR(0)="S^O:One or a Set of Affiliations;A:Any/All Affiliations",DIR("A")="Include Providers with which Affiliation",DIR("B")="A" K DA D ^DIR K DIR

 I $D(DIRUT) G ACTIVE

 S APCDAFFT=Y

 I APCDAFFT="A" W !!,"Providers of all affiliations will be included in the report.",! G DISC

 S X="AFFILIATION",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" S APCDERR=1 D EOJ Q Q

 D PEP^AMQQGTX0(+Y,"APCDAFFM(")

 I '$D(APCDAFFM) G AFFL

 I $D(APCDAFFM("*")) K APCDAFFM G AFFL

DISC ;

 K APCDDISM S APCDDIST=""

 S DIR(0)="S^O:One or a Set of Disciplines/Provider Classes;A:Any/All Disciplines/Provider Classes",DIR("A")="Include Providers with which Provider Class",DIR("B")="A" K DA D ^DIR K DIR

 I $D(DIRUT) G ACTIVE

 S APCDDIST=Y

 I APCDDIST="A" W !!,"Providers of all Disciplines will be included in the report.",! G DIVC

 S X="DISCIPLINE",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" S APCDERR=1 D EOJ Q Q

 D PEP^AMQQGTX0(+Y,"APCDDISM(")

 I '$D(APCDDISM) G DISC

 I $D(APCDDISM("*")) K APCDDISM G DISC

DIVC ;

 W !!,"You can select just providers who have access to a particular"

 W !,"division.  Since there is no designation in file 200 to specify"

 W !,"which facility a provider works knowing which Division they have"

 W !,"access to may help determine where they work."

 W !

 K APCDDIVM S APCDDIVT=""

 S DIR(0)="S^O:One or a Set of Divisions/Locations;A:Any/All Divisions/Locations",DIR("A")="Include Providers with access to which division",DIR("B")="A" K DA D ^DIR K DIR

 I $D(DIRUT) G ACTIVE

 S APCDDIVT=Y

 I APCDDIVT="A" W !!,"All will be included in the report.",! G SORTR

 S X="LOCATION OF ENCOUNTER",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" S APCDERR=1 D EOJ Q Q

 D PEP^AMQQGTX0(+Y,"APCDDIVM(")

 I '$D(APCDDIVM) G DIVC

 I $D(APCDDIVM("*")) K APCDDIVM G DIVC

SORTR ;

 S APCDSORT=""

 S DIR(0)="S^N:Provider Name;A:Affiliation;D:Discipline/Class;S:Active/Inactive Status",DIR("A")="Sort the list by",DIR("B")="N"

 KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G DIVC

 S APCDSORT=Y

ZIS ;

 S XBRP="PRINT^APCDPTAB",XBRC="PROC^APCDPTAB",XBRX="EOJ^APCDPTAB",XBNS="APCD"

 D ^XBDBQUE

 Q

EOJ ;

 D ^XBFMK

 K DIC,DIR

 D EN^XBVK("APCD")

 Q

 ;

PROC ;

 S APCDJ=$J,APCDH=$H

 K ^XTMP("APCDPTAB",APCDJ,APCDH)

 S ^XTMP("APCDPTAB",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC PROVIDER REPORT"

 S APCDIEN=0 F  S APCDIEN=$O(^VA(200,APCDIEN)) Q:APCDIEN'=+APCDIEN  D

 .I APCDPKEY="P",'$D(^XUSEC("PROVIDER",APCDIEN)) Q  ;no provider key

 .I APCDSTAT="I",$P($G(^VA(200,APCDIEN,"PS")),U,4)="" Q

 .I APCDSTAT="A",$P($G(^VA(200,APCDIEN,"PS")),U,4)]"" Q

 .I $D(APCDAFFM) S X=$P($G(^VA(200,APCDIEN,9999999)),U,1) Q:X=""   I X]"",'$D(APCDAFFM(X)) Q  ;not correct AFF

 .I $D(APCDDISM) S X=$P($G(^VA(200,APCDIEN,"PS")),U,5) Q:X=""  I X,'$D(APCDDISM(X)) Q  ;not correct DIS

 .I $D(APCDDIVM) D  I 'G Q

 ..S G=0,X=0 F  S X=$O(^VA(200,APCDIEN,2,"B",X)) Q:X'=+X!(G)  I $D(APCDDIVM(X)) S G=1

 .S X=$$SORT(APCDIEN,APCDSORT)

 .I X="" S X="---"

 .S ^XTMP("APCDPTAB",APCDJ,APCDH,"PTS",X,APCDIEN)=""

 .Q

 Q

DONE ;

 I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  PRESS ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 K APCDTS,APCDS,APCDM,APCDET

 K ^XTMP("APCDPTAB",APCDJ,APCDH),APCDJ,APCDH

 Q

 ;

 ;

PRINT ;EP - called from xbdbque

 S APCDQ=0,APCDPG=0

 D HEADER

 S APCDSV="" F  S APCDSV=$O(^XTMP("APCDPTAB",APCDJ,APCDH,"PTS",APCDSV)) Q:APCDSV=""!(APCDQ)  D

 .I APCDSORT'="N" D

 ..I APCDSV="ZZZZZZZ" W !!,"UNKNOWN",! Q

 ..W !!,APCDSV,!

 .S APCDIEN=0 F  S APCDIEN=$O(^XTMP("APCDPTAB",APCDJ,APCDH,"PTS",APCDSV,APCDIEN)) Q:APCDIEN'=+APCDIEN  D

 ..I $Y>(IOSL-3) D HEADER Q:APCDQ

 ..W !,$E($P(^VA(200,APCDIEN,0),U),1,25),?27,$E($$VAL^XBDIQ1(200,APCDIEN,9999999.01),1,8)

 ..W ?36,$E($$VAL^XBDIQ1(200,APCDIEN,53.5),1,17)

 ..W ?54,$$VAL^XBDIQ1(200,APCDIEN,9999999.039)

 ..S APCDX=0 S APCDX=$O(^VA(200,APCDIEN,2,APCDX)) I APCDX,$P($G(^AUTTLOC(APCDX,0)),U,7)]"" W ?61,$P($G(^AUTTLOC(APCDX,0)),U,7)

 ..W ?72,$$DATE($$VALI^XBDIQ1(200,APCDIEN,53.4))

 ..F  S APCDX=$O(^VA(200,APCDIEN,2,APCDX)) Q:APCDX'=+APCDX  I APCDX,$P($G(^AUTTLOC(APCDX,0)),U,7)]"" W !?61,$P($G(^AUTTLOC(APCDX,0)),U,7)

 D DONE

 Q

HEADER ;EP

 G:'APCDPG HEADER1

 K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCDQ=1 Q

HEADER1 ;

 W:$D(IOF) @IOF S APCDPG=APCDPG+1

 W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCDPG,!

 W $$CTR($P(^DIC(4,DUZ(2),0),U),80),!

 W !,$$CTR("PROVIDER LISTING",80)

 S X="Status:  "_APCDSTAN W !,$$CTR(X,80)

 S X="Affiliations: "

 I APCDAFFT="A" S X=X_"All Affiliations"

 I APCDAFFT="S" D

 .S Y="" F  S Y=$O(APCDAFFM(Y)) Q:Y'=+Y  S X=X_" "_Y

 W !,$$CTR(X,80)

 I APCDDIST="A" S X=X_"All Disciplines/Provider Classes"

 I APCDDIST="S" D

 .S Y="" F  S Y=$O(APCDDISM(Y)) Q:Y'=+Y  S X=X_" "_$P($G(^DIC(7,Y,9999999)),U)

 W !,$$CTR(X,80)

 W !!,"NAME",?27,"AFFL",?36,"PROV CLASS",?54,"ADC",?72,"INACTIVE"

 W !,$TR($J("",80)," ","-")

 Q

D(D) ;

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))

C(X,X2,X3) ;

 D COMMA^%DTC

 Q X

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

SORT(P,S) ;

 NEW R

 S R=""

 D @(S_"SORT")

 I R="" S R="ZZZZZZZ"

 Q R

 ;

ASORT ;

 S R=$$VAL^XBDIQ1(200,P,9999999.01)

 Q

NSORT ;

 S R=$$VAL^XBDIQ1(200,P,.01)

 Q

DSORT ;

 S R=$$VAL^XBDIQ1(200,P,53.5)

 Q

SSORT ;

 S R=$$VALI^XBDIQ1(200,P,53.4)

 I R="" S R="ACTIVE" Q

 S R="INACTIVE"

 Q

DATE(D) ;

 I D="" Q ""

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E((1700+$E(D,1,3)),3,4)

INTROT ;

 ;;                 PROVIDER LISTING

 ;;

 ;;This option will produce a report of all entries in File 200.

 ;;You will be able to select which entries to print based on any of the

 ;;following criteria:

 ;;     Providers Only or all entries (providers are defined as those holding

 ;;        the PROVIDER key, general users will not hold this key)

 ;;     Active/Inactive Status

 ;;     Provider Affiliation

 ;;     Provider Discipline (Class)

 ;;     Division the person has access to (this is an attempt to determine which

 ;;        facility the provider works at, there currently no field to designate

 ;;        where the provider works.)

 ;;The report can be sorted by name, affiliation, discipline, active/inactive

 ;;status or division.

 ;;END

APCDPTAB  ; IHS/CMI/LAB - Provider table print

 +1       ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 +2       ;

 +3       ;

 +4       ;

EP        ;EP - called from option interactive

 +1        DO EOJ

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        SET APCDTEXT="INTROT"

           FOR APCDJ=1:1

               SET APCDX=$TEXT(@APCDTEXT+APCDJ)

               IF $PIECE(APCDX,";;",2)="END"

                   QUIT 

               SET APCDT=$PIECE(APCDX,";;",2)

               WRITE !,APCDT

PROVKEY   ;

 +1        KILL APCDTRIM

           SET APCDTRIT=""

 +2        SET DIR(0)="S^A:All Users;P:Providers Only (defined by having the PROVIDER key)"

           SET DIR("A")="List which set of entries"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO EOJ

 +4        SET APCDPKEY=Y

ACTIVE    ;

 +1        KILL APCDSTAT

 +2        SET DIR(0)="S^A:Active Providers;I:Inactive Providers;B:Both Active and Inactive Providers"

           SET DIR("A")="List which set of providers"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO PROVKEY

 +4        SET APCDSTAT=Y

           SET APCDSTAN=Y(0)

AFFL      ;

 +1        KILL APCDAFFM

           SET APCDAFFT=""

 +2        SET DIR(0)="S^O:One or a Set of Affiliations;A:Any/All Affiliations"

           SET DIR("A")="Include Providers with which Affiliation"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO ACTIVE

 +4        SET APCDAFFT=Y

 +5        IF APCDAFFT="A"

               WRITE !!,"Providers of all affiliations will be included in the report.",!

               GOTO DISC

 +6        SET X="AFFILIATION"

           SET DIC="^AMQQ(5,"

           SET DIC(0)="FM"

           SET DIC("S")="I $P(^(0),U,14)"

           DO ^DIC

           KILL DIC,DA

           IF Y=-1

               WRITE "OOPS - QMAN NOT CURRENT - QUITTING"

               SET APCDERR=1

               DO EOJ

               QUIT Q

 +7        DO PEP^AMQQGTX0(+Y,"APCDAFFM(")

 +8        IF '$DATA(APCDAFFM)

               GOTO AFFL

 +9        IF $DATA(APCDAFFM("*"))

               KILL APCDAFFM

               GOTO AFFL

DISC      ;

 +1        KILL APCDDISM

           SET APCDDIST=""

 +2        SET DIR(0)="S^O:One or a Set of Disciplines/Provider Classes;A:Any/All Disciplines/Provider Classes"

           SET DIR("A")="Include Providers with which Provider Class"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO ACTIVE

 +4        SET APCDDIST=Y

 +5        IF APCDDIST="A"

               WRITE !!,"Providers of all Disciplines will be included in the report.",!

               GOTO DIVC

 +6        SET X="DISCIPLINE"

           SET DIC="^AMQQ(5,"

           SET DIC(0)="FM"

           SET DIC("S")="I $P(^(0),U,14)"

           DO ^DIC

           KILL DIC,DA

           IF Y=-1

               WRITE "OOPS - QMAN NOT CURRENT - QUITTING"

               SET APCDERR=1

               DO EOJ

               QUIT Q

 +7        DO PEP^AMQQGTX0(+Y,"APCDDISM(")

 +8        IF '$DATA(APCDDISM)

               GOTO DISC

 +9        IF $DATA(APCDDISM("*"))

               KILL APCDDISM

               GOTO DISC

DIVC      ;

 +1        WRITE !!,"You can select just providers who have access to a particular"

 +2        WRITE !,"division.  Since there is no designation in file 200 to specify"

 +3        WRITE !,"which facility a provider works knowing which Division they have"

 +4        WRITE !,"access to may help determine where they work."

 +5        WRITE !

 +6        KILL APCDDIVM

           SET APCDDIVT=""

 +7        SET DIR(0)="S^O:One or a Set of Divisions/Locations;A:Any/All Divisions/Locations"

           SET DIR("A")="Include Providers with access to which division"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +8        IF $DATA(DIRUT)

               GOTO ACTIVE

 +9        SET APCDDIVT=Y

 +10       IF APCDDIVT="A"

               WRITE !!,"All will be included in the report.",!

               GOTO SORTR

 +11       SET X="LOCATION OF ENCOUNTER"

           SET DIC="^AMQQ(5,"

           SET DIC(0)="FM"

           SET DIC("S")="I $P(^(0),U,14)"

           DO ^DIC

           KILL DIC,DA

           IF Y=-1

               WRITE "OOPS - QMAN NOT CURRENT - QUITTING"

               SET APCDERR=1

               DO EOJ

               QUIT Q

 +12       DO PEP^AMQQGTX0(+Y,"APCDDIVM(")

 +13       IF '$DATA(APCDDIVM)

               GOTO DIVC

 +14       IF $DATA(APCDDIVM("*"))

               KILL APCDDIVM

               GOTO DIVC

SORTR     ;

 +1        SET APCDSORT=""

 +2        SET DIR(0)="S^N:Provider Name;A:Affiliation;D:Discipline/Class;S:Active/Inactive Status"

           SET DIR("A")="Sort the list by"

           SET DIR("B")="N"

 +3        KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO DIVC

 +5        SET APCDSORT=Y

ZIS       ;

 +1        SET XBRP="PRINT^APCDPTAB"

           SET XBRC="PROC^APCDPTAB"

           SET XBRX="EOJ^APCDPTAB"

           SET XBNS="APCD"

 +2        DO ^XBDBQUE

 +3        QUIT 

EOJ       ;

 +1        DO ^XBFMK

 +2        KILL DIC,DIR

 +3        DO EN^XBVK("APCD")

 +4        QUIT 

 +5       ;

PROC      ;

 +1        SET APCDJ=$JOB

           SET APCDH=$HOROLOG

 +2        KILL ^XTMP("APCDPTAB",APCDJ,APCDH)

 +3        SET ^XTMP("APCDPTAB",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC PROVIDER REPORT"

 +4        SET APCDIEN=0

           FOR 

               SET APCDIEN=$ORDER(^VA(200,APCDIEN))

               IF APCDIEN'=+APCDIEN

                   QUIT 

               Begin DoDot:1

 +5       ;no provider key

                   IF APCDPKEY="P"

                       IF '$DATA(^XUSEC("PROVIDER",APCDIEN))

                           QUIT 

 +6                IF APCDSTAT="I"

                       IF $PIECE($GET(^VA(200,APCDIEN,"PS")),U,4)=""

                           QUIT 

 +7                IF APCDSTAT="A"

                       IF $PIECE($GET(^VA(200,APCDIEN,"PS")),U,4)]""

                           QUIT 

 +8       ;not correct AFF

                   IF $DATA(APCDAFFM)

                       SET X=$PIECE($GET(^VA(200,APCDIEN,9999999)),U,1)

                       IF X=""

                           QUIT 

                       IF X]""

                           IF '$DATA(APCDAFFM(X))

                               QUIT 

 +9       ;not correct DIS

                   IF $DATA(APCDDISM)

                       SET X=$PIECE($GET(^VA(200,APCDIEN,"PS")),U,5)

                       IF X=""

                           QUIT 

                       IF X

                           IF '$DATA(APCDDISM(X))

                               QUIT 

 +10               IF $DATA(APCDDIVM)

                       Begin DoDot:2

 +11                       SET G=0

                           SET X=0

                           FOR 

                               SET X=$ORDER(^VA(200,APCDIEN,2,"B",X))

                               IF X'=+X!(G)

                                   QUIT 

                               IF $DATA(APCDDIVM(X))

                                   SET G=1

                       End DoDot:2

                       IF 'G

                           QUIT 

 +12               SET X=$$SORT(APCDIEN,APCDSORT)

 +13               IF X=""

                       SET X="---"

 +14               SET ^XTMP("APCDPTAB",APCDJ,APCDH,"PTS",X,APCDIEN)=""

 +15               QUIT 

               End DoDot:1

 +16       QUIT 

DONE      ;

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   SET DIR(0)="EO"

                   SET DIR("A")="End of report.  PRESS ENTER"

                   DO ^DIR

                   KILL DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

 +2        KILL APCDTS,APCDS,APCDM,APCDET

 +3        KILL ^XTMP("APCDPTAB",APCDJ,APCDH),APCDJ,APCDH

 +4        QUIT 

 +5       ;

 +6       ;

PRINT     ;EP - called from xbdbque

 +1        SET APCDQ=0

           SET APCDPG=0

 +2        DO HEADER

 +3        SET APCDSV=""

           FOR 

               SET APCDSV=$ORDER(^XTMP("APCDPTAB",APCDJ,APCDH,"PTS",APCDSV))

               IF APCDSV=""!(APCDQ)

                   QUIT 

               Begin DoDot:1

 +4                IF APCDSORT'="N"

                       Begin DoDot:2

 +5                        IF APCDSV="ZZZZZZZ"

                               WRITE !!,"UNKNOWN",!

                               QUIT 

 +6                        WRITE !!,APCDSV,!

                       End DoDot:2

 +7                SET APCDIEN=0

                   FOR 

                       SET APCDIEN=$ORDER(^XTMP("APCDPTAB",APCDJ,APCDH,"PTS",APCDSV,APCDIEN))

                       IF APCDIEN'=+APCDIEN

                           QUIT 

                       Begin DoDot:2

 +8                        IF $Y>(IOSL-3)

                               DO HEADER

                               IF APCDQ

                                   QUIT 

 +9                        WRITE !,$EXTRACT($PIECE(^VA(200,APCDIEN,0),U),1,25),?27,$EXTRACT($$VAL^XBDIQ1(200,APCDIEN,9999999.01),1,8)

 +10                       WRITE ?36,$EXTRACT($$VAL^XBDIQ1(200,APCDIEN,53.5),1,17)

 +11                       WRITE ?54,$$VAL^XBDIQ1(200,APCDIEN,9999999.039)

 +12                       SET APCDX=0

                           SET APCDX=$ORDER(^VA(200,APCDIEN,2,APCDX))

                           IF APCDX

                               IF $PIECE($GET(^AUTTLOC(APCDX,0)),U,7)]""

                                   WRITE ?61,$PIECE($GET(^AUTTLOC(APCDX,0)),U,7)

 +13                       WRITE ?72,$$DATE($$VALI^XBDIQ1(200,APCDIEN,53.4))

 +14                       FOR 

                               SET APCDX=$ORDER(^VA(200,APCDIEN,2,APCDX))

                               IF APCDX'=+APCDX

                                   QUIT 

                               IF APCDX

                                   IF $PIECE($GET(^AUTTLOC(APCDX,0)),U,7)]""

                                       WRITE !?61,$PIECE($GET(^AUTTLOC(APCDX,0)),U,7)

                       End DoDot:2

               End DoDot:1

 +15       DO DONE

 +16       QUIT 

HEADER    ;EP

 +1        IF 'APCDPG

               GOTO HEADER1

 +2        KILL DIR

           IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCDQ=1

                       QUIT 

HEADER1   ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET APCDPG=APCDPG+1

 +2        WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCDPG,!

 +3        WRITE $$CTR($PIECE(^DIC(4,DUZ(2),0),U),80),!

 +4        WRITE !,$$CTR("PROVIDER LISTING",80)

 +5        SET X="Status:  "_APCDSTAN

           WRITE !,$$CTR(X,80)

 +6        SET X="Affiliations: "

 +7        IF APCDAFFT="A"

               SET X=X_"All Affiliations"

 +8        IF APCDAFFT="S"

               Begin DoDot:1

 +9                SET Y=""

                   FOR 

                       SET Y=$ORDER(APCDAFFM(Y))

                       IF Y'=+Y

                           QUIT 

                       SET X=X_" "_Y

               End DoDot:1

 +10       WRITE !,$$CTR(X,80)

 +11       IF APCDDIST="A"

               SET X=X_"All Disciplines/Provider Classes"

 +12       IF APCDDIST="S"

               Begin DoDot:1

 +13               SET Y=""

                   FOR 

                       SET Y=$ORDER(APCDDISM(Y))

                       IF Y'=+Y

                           QUIT 

                       SET X=X_" "_$PIECE($GET(^DIC(7,Y,9999999)),U)

               End DoDot:1

 +14       WRITE !,$$CTR(X,80)

 +15       WRITE !!,"NAME",?27,"AFFL",?36,"PROV CLASS",?54,"ADC",?72,"INACTIVE"

 +16       WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +17       QUIT 

D(D)      ;

 +1        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))

C(X,X2,X3) ;

 +1        DO COMMA^%DTC

 +2        QUIT X

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

 +3       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 +2       ;----------

SORT(P,S) ;

 +1        NEW R

 +2        SET R=""

 +3        DO @(S_"SORT")

 +4        IF R=""

               SET R="ZZZZZZZ"

 +5        QUIT R

 +6       ;

ASORT     ;

 +1        SET R=$$VAL^XBDIQ1(200,P,9999999.01)

 +2        QUIT 

NSORT     ;

 +1        SET R=$$VAL^XBDIQ1(200,P,.01)

 +2        QUIT 

DSORT     ;

 +1        SET R=$$VAL^XBDIQ1(200,P,53.5)

 +2        QUIT 

SSORT     ;

 +1        SET R=$$VALI^XBDIQ1(200,P,53.4)

 +2        IF R=""

               SET R="ACTIVE"

               QUIT 

 +3        SET R="INACTIVE"

 +4        QUIT 

DATE(D)   ;

 +1        IF D=""

               QUIT ""

 +2        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT((1700+$EXTRACT(D,1,3)),3,4)

INTROT    ;

 +1       ;;                 PROVIDER LISTING

 +2       ;;

 +3       ;;This option will produce a report of all entries in File 200.

 +4       ;;You will be able to select which entries to print based on any of the

 +5       ;;following criteria:

 +6       ;;     Providers Only or all entries (providers are defined as those holding

 +7       ;;        the PROVIDER key, general users will not hold this key)

 +8       ;;     Active/Inactive Status

 +9       ;;     Provider Affiliation

 +10      ;;     Provider Discipline (Class)

 +11      ;;     Division the person has access to (this is an attempt to determine which

 +12      ;;        facility the provider works at, there currently no field to designate

 +13      ;;        where the provider works.)

 +14      ;;The report can be sorted by name, affiliation, discipline, active/inactive

 +15      ;;status or division.

 +16      ;;END