APCLPP2P.m

APCLPP2P ; IHS/CMI/LAB - provider profile print ;

 ;;2.0;IHS PCC SUITE;**2,7,10,11**;MAY 14, 2009;Build 58

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in PV

 ;

START ;

 S APCLPG=0,APCLQUIT=""

 S APCLNITM=$S(APCLLSV="S":5,1:10)

 S APCLPRV=0 F  S APCLPRV=$O(APCLPROV(APCLPRV)) Q:APCLPRV'=+APCLPRV!(APCLQUIT)  D PRN

DONE ;

 D DONE^APCLOSUT

 K ^XTMP("APCLPP2",APCLJOB,APCLBTH)

 K APCLQUIT

 Q

PRN ;

 D HEAD Q:APCLQUIT

 W !,"1 - Designated Primary Care Provider Panel",!

 W !,"You are the Designated Primary Care Provider for ",$$C(APCLDPPT(APCLPRV),0)," patients.  In this"

 W !,"time period you have provided services (any type) to ",$$C(APCLDPPS(APCLPRV),0)," (",$$PER(APCLDPPS(APCLPRV),APCLDPPT(APCLPRV)),") patients"

 W !,"from your Designated Primary Care Provider Panel."

 W !!,"In this time period, you provided ambulatory services at least twice to ",$$C(APCLDP2V(APCLPRV),0)

 W !,"patients who have no Designated Primary Care Provider identified."

 W !!,"2 - Demographics and Workload for All Patients Served (Any Type of Service)"

 I $Y>(IOSL-4) D HEAD Q:APCLQUIT

 W !!,"In this time period you have provided services (any type) to ",$$C(APCLDW1(APCLPRV),0)," patients.  "

 W !,$$C(APCLDW2(APCLPRV),0)," (",$$PER(APCLDW2(APCLPRV),APCLDW1(APCLPRV)),") are from your Designated Primary Provider Panel.  ",$$C(APCLDW3(APCLPRV),0)," (",$$PER(APCLDW3(APCLPRV),APCLDW1(APCLPRV)),") are"

 I $Y>(IOSL-4) D HEAD Q:APCLQUIT

 I $Y>(IOSL-4) D HEAD Q:APCLQUIT

 W !,"not from your Designated Primary Care Provider Panel."

 I $Y>(IOSL-4) D HEAD Q:APCLQUIT

 W !!,$$PER(APCLDW4(APCLPRV),APCLDW1(APCLPRV))," of your patients were Male, ",$$PER(APCLDW5(APCLPRV),APCLDW1(APCLPRV))," Female, and ",$$PER(APCLDW51(APCLPRV),APCLDW1(APCLPRV))," Unknown Gender."

 I $Y>(IOSL-4) D HEAD Q:APCLQUIT

 W !!,$$PER(APCLDW6(APCLPRV),APCLDW1(APCLPRV))," were 18 and under; ",$$PER(APCLDW7(APCLPRV),APCLDW1(APCLPRV))," were 19-49; "

 W $$PER(APCLDW8(APCLPRV),APCLDW1(APCLPRV))," were 50-64; and ",$$PER(APCLDW9(APCLPRV),APCLDW1(APCLPRV))," were 65 and over."

 I $Y>(IOSL-3) D HEAD Q:APCLQUIT

COMM ;communities

 I $Y>(IOSL-APCLNITM) D HEAD Q:APCLQUIT

 K APCLDISP F X=1:1:APCLNITM S APCLDISP(X)=""

 W !!,"The leading residences for your ",?40,"The leading tribes represented",!,"patients are:",?40,"among your patients are:"

 S (APCLX,APCLC)=0 F  S APCLX=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMMC",APCLX)) Q:APCLX'=+APCLX!(APCLC>4)!(APCLQUIT)  D

 .S APCLY="" F  S APCLY=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMMC",APCLX,APCLY)) Q:APCLY=""!(APCLQUIT)  D

 ..S APCLC=APCLC+1 S APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMMC",APCLX,APCLY)

 ..S APCLB=$$C(APCLA,0)

 ..S Z=$$PER(APCLA,APCLDW1(APCLPRV))

 ..I '$D(APCLDISP(APCLC)) S APCLDISP(APCLC)=""

 ..S $P(APCLDISP(APCLC),U)=$E(APCLY,1,20)_U_APCLB_U_Z

 S (APCLX,APCLC)=0 F  S APCLX=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBEC",APCLX)) Q:APCLX'=+APCLX!(APCLC>4)!(APCLQUIT)  D

 .S APCLY="" F  S APCLY=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBEC",APCLX,APCLY)) Q:APCLY=""!(APCLQUIT)  D

 ..S APCLC=APCLC+1 S APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBEC",APCLX,APCLY)

 ..S APCLB=$$C(APCLA,0)

 ..S Z=$$PER(APCLA,APCLDW1(APCLPRV))

 ..I '$D(APCLDISP(APCLC)) S APCLDISP(APCLC)=""

 ..S $P(APCLDISP(APCLC),U,4)=$E(APCLY,1,22)_U_APCLB_U_Z

 I $Y>(IOSL-4) D HEAD Q:APCLQUIT

 S APCLX=0 F  S APCLX=$O(APCLDISP(APCLX)) Q:APCLX'=+APCLX!(APCLX>APCLNITM)!(APCLQUIT)  D

 .I $Y>(IOSL-3) D HEAD Q:APCLQUIT

 .W !?1,$P(APCLDISP(APCLX),U) I $P(APCLDISP(APCLX),U,2)]"" W ?22,$$PAD($P(APCLDISP(APCLX),U,2),6),?29,$J($P(APCLDISP(APCLX),U,3),4,0),"%"

 .W ?41,$P(APCLDISP(APCLX),U,4) I $P(APCLDISP(APCLX),U,5)]"" W ?66,$$PAD($P(APCLDISP(APCLX),U,5),6),?73,$J($P(APCLDISP(APCLX),U,6),4,0),"%"

 Q:APCLQUIT

 W !!,"Of these services, ",$$C(APCLTCR(APCLPRV),0)," (",$$PER(APCLTCR(APCLPRV),APCLDW1(APCLPRV))

 W ") were chart reviews and ",$$C(APCLTTEL(APCLPRV),0)," (",$$PER(APCLTTEL(APCLPRV),APCLDW1(APCLPRV)),") were",!,"telecommunications services."

 I $Y>(IOSL-4) D HEAD Q:APCLQUIT

AMB ;

 W !!,"3 - Ambulatory Workload:  You had a total of ",$$C(APCLDW10(APCLPRV),0)," ambulatory visits during",!

 W "this time period.  You were the Primary Provider for ",$$C(APCLDW11(APCLPRV),0)," visits (",$$PER(APCLDW11(APCLPRV),APCLDW10(APCLPRV)),") and"

 W !,"Secondary Provider for ",$$C(APCLDW12(APCLPRV),0)," visits (",$$PER(APCLDW12(APCLPRV),APCLDW10(APCLPRV)),")."

LOCSC ;

 I $Y>(IOSL-8) D HEAD Q:APCLQUIT

 W !!,"Your services were provided at the",?40,"Your services included the following",!,"following locations:",?40,"Service Categories:"

 K APCLDISP F X=1:1:APCLNITM S APCLDISP(X)=""

 ;tally up top 4 locations and other.

 S (APCLX,APCLC)=0 F  S APCLX=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX)) Q:APCLX'=+APCLX!(APCLC>3)!(APCLQUIT)  D

 .S APCLY="" F  S APCLY=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)) Q:APCLY=""!(APCLQUIT)!(APCLC>3)  D

 ..S APCLC=APCLC+1 S APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)

 ..K ^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)

 ..S APCLB=$$C(APCLA,0)

 ..S Z=$$PER(APCLA,APCLDW10(APCLPRV))

 ..I '$D(APCLDISP(APCLC)) S APCLDISP(APCLC)=""

 ..S $P(APCLDISP(APCLC),U)=$E(APCLY,1,20)_U_APCLB_U_Z

 S APCLTOTH="",APCLX=0 F  S APCLX=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX)) Q:APCLX'=+APCLX  D

 .S APCLY=0 F  S APCLY=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)) Q:APCLY=""!(APCLY>3)  S APCLTOTH(APCLPRV)=APCLTOTH(APCLPRV)+^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)

 I APCLTOTH(APCLPRV) S APCLDISP(5)="OTHER"_U_$$C(APCLTOTH(APCLPRV),0)_U_$$PER(APCLTOTH(APCLPRV),APCLDW10(APCLPRV))

SC ;

 S (APCLX,APCLC)=0 F  S APCLX=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SCC",APCLX)) Q:APCLX'=+APCLX!(APCLC>(APCLNITM-1))!(APCLQUIT)  D

 .S APCLY="" F  S APCLY=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SCC",APCLX,APCLY)) Q:APCLY=""!(APCLQUIT)  D

 ..S APCLC=APCLC+1 S APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SCC",APCLX,APCLY)

 ..S APCLB=$$C(APCLA,0)

 ..S Z=$$PER(APCLA,APCLDW10(APCLPRV))

 ..I '$D(APCLDISP(APCLC)) S APCLDISP(APCLC)=""

 ..S $P(APCLDISP(APCLC),U,4)=$E(APCLY,1,22)_U_APCLB_U_Z

 I $Y>(IOSL-APCLNITM) D HEAD Q:APCLQUIT

 S APCLX=0 F  S APCLX=$O(APCLDISP(APCLX)) Q:APCLX'=+APCLX!(APCLX>APCLNITM)!(APCLQUIT)  D

 .I $Y>(IOSL-3) D HEAD Q:APCLQUIT

 .W !?1,$P(APCLDISP(APCLX),U) I $P(APCLDISP(APCLX),U,2)]"" W ?22,$$PAD($P(APCLDISP(APCLX),U,2),6),?29,$J($P(APCLDISP(APCLX),U,3),4,0),"%"

 .W ?41,$P(APCLDISP(APCLX),U,4) I $P(APCLDISP(APCLX),U,5)]"" W ?66,$$PAD($P(APCLDISP(APCLX),U,5),6),?73,$J($P(APCLDISP(APCLX),U,6),4,0),"%"

 Q:APCLQUIT

PV ;

 I $Y>(IOSL-APCLNITM) D HEAD Q:APCLQUIT

 K APCLDISP F X=1:1:APCLNITM S APCLDISP(X)=""

 W !!,"The ",APCLNITM," leading Purposes of Visit",?40,"The ",APCLNITM," leading Medications you"

 W !,"(including Primary and Secondary POV's)",?40,"prescribed or refilled as Primary"

 W !,"that you identified were:",?40,"Provider for the Visit were:"

 S (APCLX,APCLC)=0 F  S APCLX=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDXC",APCLX)) Q:APCLX'=+APCLX!(APCLC>(APCLNITM-1))!(APCLQUIT)  D

 .S APCLY="" F  S APCLY=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDXC",APCLX,APCLY)) Q:APCLY=""!(APCLQUIT)  D

 ..S APCLC=APCLC+1 S APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDXC",APCLX,APCLY)

 ..S APCLB=$$C(APCLA,0)

 ..I '$D(APCLDISP(APCLC)) S APCLDISP(APCLC)=""

 ..;S Z=$P(^ICD9(APCLY,0),U),$E(Z,8)=$E($P(^ICD9(APCLY,0),U,3),1,19),$P(APCLDISP(APCLC),U)=Z_U_APCLB  ;cmi/anch/maw 9/10/2007 orig line

 ..S Z=$P($$ICDDX^ICDEX(APCLY),U,2),$E(Z,10)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,16),$P(APCLDISP(APCLC),U)=Z_U_APCLB  ;cmi/anch/maw 9/10/2007 csv

 S (APCLX,APCLC)=0 F  S APCLX=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RXC",APCLX)) Q:APCLX'=+APCLX!(APCLC>(APCLNITM-1))!(APCLQUIT)  D

 .S APCLY="" F  S APCLY=$O(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RXC",APCLX,APCLY)) Q:APCLY=""!(APCLQUIT)  D

 ..S APCLC=APCLC+1 S APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RXC",APCLX,APCLY)

 ..S APCLB=$$C(APCLA,0)

 ..I '$D(APCLDISP(APCLC)) S APCLDISP(APCLC)=""

 ..S $P(APCLDISP(APCLC),U,4)=$E(APCLY,1,30)_U_APCLB

 I $Y>(IOSL-APCLNITM) D HEAD Q:APCLQUIT

 S APCLX=0 F  S APCLX=$O(APCLDISP(APCLX)) Q:APCLX'=+APCLX!(APCLX>APCLNITM)!(APCLQUIT)  D

 .I $Y>(IOSL-APCLNITM) D HEAD Q:APCLQUIT

 .W !?1,$P(APCLDISP(APCLX),U) I $P(APCLDISP(APCLX),U,2)]"" W ?28,$$PAD($P(APCLDISP(APCLX),U,2),6)

 .W ?41,$P(APCLDISP(APCLX),U,4) I $P(APCLDISP(APCLX),U,5)]"" W ?72,$$PAD($P(APCLDISP(APCLX),U,5),6)

 Q:APCLQUIT

 D PROC^APCLPP2Q

 Q

HEAD ;EP

 G:'APCLPG HEAD1

 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 APCLQUIT=1 Q

HEAD1 ;

 I $D(IOF) W @IOF

 S APCLPG=APCLPG+1

 W !?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG,!

 W $$CTR("Provider Practice Description For "_APCLPRVN(APCLPRV)_", "_APCLPRVD(APCLPRV),80),!

 W !?12,"For the Time Period:  ",$$FMTE^XLFDT(APCLBD)," - ",$$FMTE^XLFDT(APCLED),!

 I $G(APCLSEAT) W $$CTR("Search Template of Patients Used: "_$P(^DIBT(APCLSEAT,0),U)),!

 I APCLEXCL W !,"** Please Note that certain diagnoses codes have been excluded",!,"from the list of purpose of visits.",!

 Q

PER(N,D) ;return % of n/d

 I 'D Q "0%"

 NEW Z

 S Z=N/D,Z=Z*100,Z=$J(Z,3,0)

 Q $$STRIP^XLFSTR(Z," ")_"%"

C(X,X2,X3) ;

 D COMMA^%DTC

 Q $$STRIP^XLFSTR(X," ")

PAD(D,L) ; -- SUBRTN to pad length of data

 ; -- D=data L=length

 S L=L-$L(D)

 Q $E($$REPEAT^XLFSTR(" ",L),1,L)_D

 ;

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

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

 ;----------

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR("A")="End of Report.  Press return",DIR(0)="E" D ^DIR

 Q

 ;----------

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 APCLPRV.

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

 ;----------

 ;

APCLPP2P  ; IHS/CMI/LAB - provider profile print ;

 +1       ;;2.0;IHS PCC SUITE;**2,7,10,11**;MAY 14, 2009;Build 58

 +2       ;

 +3       ;cmi/anch/maw 9/10/2007 code set versioning in PV

 +4       ;

START     ;

 +1        SET APCLPG=0

           SET APCLQUIT=""

 +2        SET APCLNITM=$SELECT(APCLLSV="S":5,1:10)

 +3        SET APCLPRV=0

           FOR 

               SET APCLPRV=$ORDER(APCLPROV(APCLPRV))

               IF APCLPRV'=+APCLPRV!(APCLQUIT)

                   QUIT 

               DO PRN

DONE      ;

 +1        DO DONE^APCLOSUT

 +2        KILL ^XTMP("APCLPP2",APCLJOB,APCLBTH)

 +3        KILL APCLQUIT

 +4        QUIT 

PRN       ;

 +1        DO HEAD

           IF APCLQUIT

               QUIT 

 +2        WRITE !,"1 - Designated Primary Care Provider Panel",!

 +3        WRITE !,"You are the Designated Primary Care Provider for ",$$C(APCLDPPT(APCLPRV),0)," patients.  In this"

 +4        WRITE !,"time period you have provided services (any type) to ",$$C(APCLDPPS(APCLPRV),0)," (",$$PER(APCLDPPS(APCLPRV),APCLDPPT(APCLPRV)),") patients"

 +5        WRITE !,"from your Designated Primary Care Provider Panel."

 +6        WRITE !!,"In this time period, you provided ambulatory services at least twice to ",$$C(APCLDP2V(APCLPRV),0)

 +7        WRITE !,"patients who have no Designated Primary Care Provider identified."

 +8        WRITE !!,"2 - Demographics and Workload for All Patients Served (Any Type of Service)"

 +9        IF $Y>(IOSL-4)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +10       WRITE !!,"In this time period you have provided services (any type) to ",$$C(APCLDW1(APCLPRV),0)," patients.  "

 +11       WRITE !,$$C(APCLDW2(APCLPRV),0)," (",$$PER(APCLDW2(APCLPRV),APCLDW1(APCLPRV)),") are from your Designated Primary Provider Panel.  ",$$C(APCLDW3(APCLPRV),0)," (",$$PER(APCLDW3(APCLPRV),APCLDW1(APCLPRV)),") are"

 +12       IF $Y>(IOSL-4)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +13       IF $Y>(IOSL-4)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +14       WRITE !,"not from your Designated Primary Care Provider Panel."

 +15       IF $Y>(IOSL-4)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +16       WRITE !!,$$PER(APCLDW4(APCLPRV),APCLDW1(APCLPRV))," of your patients were Male, ",$$PER(APCLDW5(APCLPRV),APCLDW1(APCLPRV))," Female, and ",$$PER(APCLDW51(APCLPRV),APCLDW1(APCLPRV))," Unknown Gender."

 +17       IF $Y>(IOSL-4)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +18       WRITE !!,$$PER(APCLDW6(APCLPRV),APCLDW1(APCLPRV))," were 18 and under; ",$$PER(APCLDW7(APCLPRV),APCLDW1(APCLPRV))," were 19-49; "

 +19       WRITE $$PER(APCLDW8(APCLPRV),APCLDW1(APCLPRV))," were 50-64; and ",$$PER(APCLDW9(APCLPRV),APCLDW1(APCLPRV))," were 65 and over."

 +20       IF $Y>(IOSL-3)

               DO HEAD

               IF APCLQUIT

                   QUIT 

COMM      ;communities

 +1        IF $Y>(IOSL-APCLNITM)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +2        KILL APCLDISP

           FOR X=1:1:APCLNITM

               SET APCLDISP(X)=""

 +3        WRITE !!,"The leading residences for your ",?40,"The leading tribes represented",!,"patients are:",?40,"among your patients are:"

 +4        SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMMC",APCLX))

               IF APCLX'=+APCLX!(APCLC>4)!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +5                SET APCLY=""

                   FOR 

                       SET APCLY=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMMC",APCLX,APCLY))

                       IF APCLY=""!(APCLQUIT)

                           QUIT 

                       Begin DoDot:2

 +6                        SET APCLC=APCLC+1

                           SET APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","COMMC",APCLX,APCLY)

 +7                        SET APCLB=$$C(APCLA,0)

 +8                        SET Z=$$PER(APCLA,APCLDW1(APCLPRV))

 +9                        IF '$DATA(APCLDISP(APCLC))

                               SET APCLDISP(APCLC)=""

 +10                       SET $PIECE(APCLDISP(APCLC),U)=$EXTRACT(APCLY,1,20)_U_APCLB_U_Z

                       End DoDot:2

               End DoDot:1

 +11       SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBEC",APCLX))

               IF APCLX'=+APCLX!(APCLC>4)!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +12               SET APCLY=""

                   FOR 

                       SET APCLY=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBEC",APCLX,APCLY))

                       IF APCLY=""!(APCLQUIT)

                           QUIT 

                       Begin DoDot:2

 +13                       SET APCLC=APCLC+1

                           SET APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","TRIBEC",APCLX,APCLY)

 +14                       SET APCLB=$$C(APCLA,0)

 +15                       SET Z=$$PER(APCLA,APCLDW1(APCLPRV))

 +16                       IF '$DATA(APCLDISP(APCLC))

                               SET APCLDISP(APCLC)=""

 +17                       SET $PIECE(APCLDISP(APCLC),U,4)=$EXTRACT(APCLY,1,22)_U_APCLB_U_Z

                       End DoDot:2

               End DoDot:1

 +18       IF $Y>(IOSL-4)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +19       SET APCLX=0

           FOR 

               SET APCLX=$ORDER(APCLDISP(APCLX))

               IF APCLX'=+APCLX!(APCLX>APCLNITM)!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +20               IF $Y>(IOSL-3)

                       DO HEAD

                       IF APCLQUIT

                           QUIT 

 +21               WRITE !?1,$PIECE(APCLDISP(APCLX),U)

                   IF $PIECE(APCLDISP(APCLX),U,2)]""

                       WRITE ?22,$$PAD($PIECE(APCLDISP(APCLX),U,2),6),?29,$JUSTIFY($PIECE(APCLDISP(APCLX),U,3),4,0),"%"

 +22               WRITE ?41,$PIECE(APCLDISP(APCLX),U,4)

                   IF $PIECE(APCLDISP(APCLX),U,5)]""

                       WRITE ?66,$$PAD($PIECE(APCLDISP(APCLX),U,5),6),?73,$JUSTIFY($PIECE(APCLDISP(APCLX),U,6),4,0),"%"

               End DoDot:1

 +23       IF APCLQUIT

               QUIT 

 +24       WRITE !!,"Of these services, ",$$C(APCLTCR(APCLPRV),0)," (",$$PER(APCLTCR(APCLPRV),APCLDW1(APCLPRV))

 +25       WRITE ") were chart reviews and ",$$C(APCLTTEL(APCLPRV),0)," (",$$PER(APCLTTEL(APCLPRV),APCLDW1(APCLPRV)),") were",!,"telecommunications services."

 +26       IF $Y>(IOSL-4)

               DO HEAD

               IF APCLQUIT

                   QUIT 

AMB       ;

 +1        WRITE !!,"3 - Ambulatory Workload:  You had a total of ",$$C(APCLDW10(APCLPRV),0)," ambulatory visits during",!

 +2        WRITE "this time period.  You were the Primary Provider for ",$$C(APCLDW11(APCLPRV),0)," visits (",$$PER(APCLDW11(APCLPRV),APCLDW10(APCLPRV)),") and"

 +3        WRITE !,"Secondary Provider for ",$$C(APCLDW12(APCLPRV),0)," visits (",$$PER(APCLDW12(APCLPRV),APCLDW10(APCLPRV)),")."

LOCSC     ;

 +1        IF $Y>(IOSL-8)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +2        WRITE !!,"Your services were provided at the",?40,"Your services included the following",!,"following locations:",?40,"Service Categories:"

 +3        KILL APCLDISP

           FOR X=1:1:APCLNITM

               SET APCLDISP(X)=""

 +4       ;tally up top 4 locations and other.

 +5        SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX))

               IF APCLX'=+APCLX!(APCLC>3)!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +6                SET APCLY=""

                   FOR 

                       SET APCLY=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY))

                       IF APCLY=""!(APCLQUIT)!(APCLC>3)

                           QUIT 

                       Begin DoDot:2

 +7                        SET APCLC=APCLC+1

                           SET APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)

 +8                        KILL ^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)

 +9                        SET APCLB=$$C(APCLA,0)

 +10                       SET Z=$$PER(APCLA,APCLDW10(APCLPRV))

 +11                       IF '$DATA(APCLDISP(APCLC))

                               SET APCLDISP(APCLC)=""

 +12                       SET $PIECE(APCLDISP(APCLC),U)=$EXTRACT(APCLY,1,20)_U_APCLB_U_Z

                       End DoDot:2

               End DoDot:1

 +13       SET APCLTOTH=""

           SET APCLX=0

           FOR 

               SET APCLX=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX))

               IF APCLX'=+APCLX

                   QUIT 

               Begin DoDot:1

 +14               SET APCLY=0

                   FOR 

                       SET APCLY=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY))

                       IF APCLY=""!(APCLY>3)

                           QUIT 

                       SET APCLTOTH(APCLPRV)=APCLTOTH(APCLPRV)+^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","LOCC",APCLX,APCLY)

               End DoDot:1

 +15       IF APCLTOTH(APCLPRV)

               SET APCLDISP(5)="OTHER"_U_$$C(APCLTOTH(APCLPRV),0)_U_$$PER(APCLTOTH(APCLPRV),APCLDW10(APCLPRV))

SC        ;

 +1        SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SCC",APCLX))

               IF APCLX'=+APCLX!(APCLC>(APCLNITM-1))!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +2                SET APCLY=""

                   FOR 

                       SET APCLY=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SCC",APCLX,APCLY))

                       IF APCLY=""!(APCLQUIT)

                           QUIT 

                       Begin DoDot:2

 +3                        SET APCLC=APCLC+1

                           SET APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","SCC",APCLX,APCLY)

 +4                        SET APCLB=$$C(APCLA,0)

 +5                        SET Z=$$PER(APCLA,APCLDW10(APCLPRV))

 +6                        IF '$DATA(APCLDISP(APCLC))

                               SET APCLDISP(APCLC)=""

 +7                        SET $PIECE(APCLDISP(APCLC),U,4)=$EXTRACT(APCLY,1,22)_U_APCLB_U_Z

                       End DoDot:2

               End DoDot:1

 +8        IF $Y>(IOSL-APCLNITM)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +9        SET APCLX=0

           FOR 

               SET APCLX=$ORDER(APCLDISP(APCLX))

               IF APCLX'=+APCLX!(APCLX>APCLNITM)!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +10               IF $Y>(IOSL-3)

                       DO HEAD

                       IF APCLQUIT

                           QUIT 

 +11               WRITE !?1,$PIECE(APCLDISP(APCLX),U)

                   IF $PIECE(APCLDISP(APCLX),U,2)]""

                       WRITE ?22,$$PAD($PIECE(APCLDISP(APCLX),U,2),6),?29,$JUSTIFY($PIECE(APCLDISP(APCLX),U,3),4,0),"%"

 +12               WRITE ?41,$PIECE(APCLDISP(APCLX),U,4)

                   IF $PIECE(APCLDISP(APCLX),U,5)]""

                       WRITE ?66,$$PAD($PIECE(APCLDISP(APCLX),U,5),6),?73,$JUSTIFY($PIECE(APCLDISP(APCLX),U,6),4,0),"%"

               End DoDot:1

 +13       IF APCLQUIT

               QUIT 

PV        ;

 +1        IF $Y>(IOSL-APCLNITM)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +2        KILL APCLDISP

           FOR X=1:1:APCLNITM

               SET APCLDISP(X)=""

 +3        WRITE !!,"The ",APCLNITM," leading Purposes of Visit",?40,"The ",APCLNITM," leading Medications you"

 +4        WRITE !,"(including Primary and Secondary POV's)",?40,"prescribed or refilled as Primary"

 +5        WRITE !,"that you identified were:",?40,"Provider for the Visit were:"

 +6        SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDXC",APCLX))

               IF APCLX'=+APCLX!(APCLC>(APCLNITM-1))!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +7                SET APCLY=""

                   FOR 

                       SET APCLY=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDXC",APCLX,APCLY))

                       IF APCLY=""!(APCLQUIT)

                           QUIT 

                       Begin DoDot:2

 +8                        SET APCLC=APCLC+1

                           SET APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","OUTDXC",APCLX,APCLY)

 +9                        SET APCLB=$$C(APCLA,0)

 +10                       IF '$DATA(APCLDISP(APCLC))

                               SET APCLDISP(APCLC)=""

 +11      ;S Z=$P(^ICD9(APCLY,0),U),$E(Z,8)=$E($P(^ICD9(APCLY,0),U,3),1,19),$P(APCLDISP(APCLC),U)=Z_U_APCLB  ;cmi/anch/maw 9/10/2007 orig line

 +12      ;cmi/anch/maw 9/10/2007 csv

                           SET Z=$PIECE($$ICDDX^ICDEX(APCLY),U,2)

                           SET $EXTRACT(Z,10)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,16)

                           SET $PIECE(APCLDISP(APCLC),U)=Z_U_APCLB

                       End DoDot:2

               End DoDot:1

 +13       SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RXC",APCLX))

               IF APCLX'=+APCLX!(APCLC>(APCLNITM-1))!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +14               SET APCLY=""

                   FOR 

                       SET APCLY=$ORDER(^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RXC",APCLX,APCLY))

                       IF APCLY=""!(APCLQUIT)

                           QUIT 

                       Begin DoDot:2

 +15                       SET APCLC=APCLC+1

                           SET APCLA=^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLPRV,"REPORT","RXC",APCLX,APCLY)

 +16                       SET APCLB=$$C(APCLA,0)

 +17                       IF '$DATA(APCLDISP(APCLC))

                               SET APCLDISP(APCLC)=""

 +18                       SET $PIECE(APCLDISP(APCLC),U,4)=$EXTRACT(APCLY,1,30)_U_APCLB

                       End DoDot:2

               End DoDot:1

 +19       IF $Y>(IOSL-APCLNITM)

               DO HEAD

               IF APCLQUIT

                   QUIT 

 +20       SET APCLX=0

           FOR 

               SET APCLX=$ORDER(APCLDISP(APCLX))

               IF APCLX'=+APCLX!(APCLX>APCLNITM)!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +21               IF $Y>(IOSL-APCLNITM)

                       DO HEAD

                       IF APCLQUIT

                           QUIT 

 +22               WRITE !?1,$PIECE(APCLDISP(APCLX),U)

                   IF $PIECE(APCLDISP(APCLX),U,2)]""

                       WRITE ?28,$$PAD($PIECE(APCLDISP(APCLX),U,2),6)

 +23               WRITE ?41,$PIECE(APCLDISP(APCLX),U,4)

                   IF $PIECE(APCLDISP(APCLX),U,5)]""

                       WRITE ?72,$$PAD($PIECE(APCLDISP(APCLX),U,5),6)

               End DoDot:1

 +24       IF APCLQUIT

               QUIT 

 +25       DO PROC^APCLPP2Q

 +26       QUIT 

HEAD      ;EP

 +1        IF 'APCLPG

               GOTO HEAD1

 +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 APCLQUIT=1

                       QUIT 

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        SET APCLPG=APCLPG+1

 +3        WRITE !?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG,!

 +4        WRITE $$CTR("Provider Practice Description For "_APCLPRVN(APCLPRV)_", "_APCLPRVD(APCLPRV),80),!

 +5        WRITE !?12,"For the Time Period:  ",$$FMTE^XLFDT(APCLBD)," - ",$$FMTE^XLFDT(APCLED),!