APCLDP1.m

APCLDP1 ; IHS/CMI/LAB - ACTIVE CLIENT LIST ;

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

 ;

START ;

 D XIT

 I '$D(IOF) D HOME^%ZIS

 W @(IOF),!!

 W "**  PATIENTS BY DESIGNATED PRIMARY CARE PROVIDER, WITH VISIT COUNTS, DX'S **",!

 W "This report will produce a list of patients by their Designated Primary ",!,"Care Provider.  It will include the patient's name, chart #, age, "

 W !,"number of times seen by the Designated Primary Care Provider, number of times "

 W !,"seen by other primary providers and diagnoses.",!

GETDATES ;

BD ;get beginning date

 W !,"Please enter the date range during which the patient should have been seen.",!

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S APCLBD=Y

ED ;get ending date

 W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Date:  " S Y=APCLBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S APCLED=Y

 S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y

 ;

ASK ;

 S APCLPROV=""

 S DIR(0)="S^1:ONE PROVIDER;2:ALL PROVIDERS",DIR("A")="Run the report for",DIR("B")=1 D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) GETDATES

 G:Y=2 ZIS

PROV ;

 ;

 S DIC=$S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),DIC("A")="Enter PROVIDER: ",DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 G ASK

 S APCLPROV=+Y

 S APCLPRV=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,+Y,0),U),1:$P(^DIC(16,+Y,0),U))

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G ASK

 S XBRC="PROC^APCLDP1",XBRP="^APCLDP1P",XBNS="APCL",XBRX="XIT^APCLDP1"

 D ^XBDBQUE

XIT K ZTSK,Y,APCLBD,APCLED,IO("Q"),APCL80D,APCLBTH,APCLHRCN,APCLJOB,APCLLENG,APCLPCNT,APCLPG,APCLNUM,APCLX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D

 K APCLPRNM,APCLPRNT,APCLPROB,APCLPRV,APCLR,APCLRCNT,APCLRLOC,APCLSD,APCLTOT,APCLBDD,APCLBT,APCLEDD,APCLEDO,APCLBDO,APCLBT,APCLFOUN,APCLHIT,APCLID,APCLLINE,APCLP,APCLQ,APCLRCNT,APCLET

 K I,J,K,P,X,Y,Z,%,DDH,DIV,DIU,DFN,DIG,DIW,APCLAGE,APCLPROV,C,D0,DA,DIC,DR,DIQ

 D EN^XBVK("APCL")

 Q

 ;

PROC ;EP - entry point for processing

 S APCLJOB=$J,APCLBTH=$H,APCLTOT=0,DFN=0,APCLBT=$H

 D XTMP^APCLOSUT("APCLDP1","PCC - DESIGNATED PROV REPORT")

 I APCLPROV]"" D PROC0 Q

 F  S APCLPROV=$O(^AUPNPAT("AK",APCLPROV)) Q:APCLPROV'=+APCLPROV  D PROC0

 S APCLET=$H

 K DFN

 Q

PROC0 ;

 S DFN=0 F  S DFN=$O(^AUPNPAT("AK",APCLPROV,DFN)) Q:DFN'=+DFN  D PROC1

 Q

PROC1 ;

 Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))

 S ^XTMP("APCLDP1",APCLJOB,APCLBTH,APCLPROV,DFN)=""

 Q

VSTS ; process visits

 S APCLR=0,APCLBDO=9999999-APCLBD,APCLEDO=9999999-APCLED,APCLSD=APCLED-1,APCLRCNT=0

 F  S APCLSD=$O(^AUPNVSIT("AA",DFN,APCLSD)) Q:APCLSD>APCLBDO!(APCLSD="")  D

 .S APCLR=0 F  S APCLR=$O(^AUPNVSIT("AA",DFN,APCLSD,APCLR)) Q:APCLR'=+APCLR  D

 ..Q:'$P(^AUPNVSIT(APCLR,0),U,9)

 ..Q:$P(^AUPNVSIT(APCLR,0),U,11)

 ..Q:"ECT"[$P(^AUPNVSIT(APCLR,0),U,7)

 ..S APCLRCNT=APCLRCNT+1 ;COUNT # VISITS

 .Q

 I APCLRCNT'<APCLNUM S ^XTMP("APCLDP1",APCLJOB,APCLBTH,DFN)=""

 Q

 ;

APCLDP1   ; IHS/CMI/LAB - ACTIVE CLIENT LIST ;

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

 +2       ;

START     ;

 +1        DO XIT

 +2        IF '$DATA(IOF)

               DO HOME^%ZIS

 +3        WRITE @(IOF),!!

 +4        WRITE "**  PATIENTS BY DESIGNATED PRIMARY CARE PROVIDER, WITH VISIT COUNTS, DX'S **",!

 +5        WRITE "This report will produce a list of patients by their Designated Primary ",!,"Care Provider.  It will include the patient's name, chart #, age, "

 +6        WRITE !,"number of times seen by the Designated Primary Care Provider, number of times "

 +7        WRITE !,"seen by other primary providers and diagnoses.",!

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !,"Please enter the date range during which the patient should have been seen.",!

 +2        WRITE !

           SET DIR(0)="D^:DT:EP"

           SET DIR("A")="Enter beginning Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET APCLBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="DA^"_APCLBD_":DT:EP"

           SET DIR("A")="Enter ending Date:  "

           SET Y=APCLBD

           DO DD^%DT

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET APCLED=Y

 +4        SET X1=APCLBD

           SET X2=-1

           DO C^%DTC

           SET APCLSD=X

           SET Y=APCLBD

           DO DD^%DT

           SET APCLBDD=Y

           SET Y=APCLED

           DO DD^%DT

           SET APCLEDD=Y

 +5       ;

ASK       ;

 +1        SET APCLPROV=""

 +2        SET DIR(0)="S^1:ONE PROVIDER;2:ALL PROVIDERS"

           SET DIR("A")="Run the report for"

           SET DIR("B")=1

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO GETDATES

 +4        IF Y=2

               GOTO ZIS

PROV      ;

 +1       ;

 +2        SET DIC=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:200,1:6)

           SET DIC("A")="Enter PROVIDER: "

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               GOTO ASK

 +4        SET APCLPROV=+Y

 +5        SET APCLPRV=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,+Y,0),U),1:$PIECE(^DIC(16,+Y,0),U))

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO ASK

 +3        SET XBRC="PROC^APCLDP1"

           SET XBRP="^APCLDP1P"

           SET XBNS="APCL"

           SET XBRX="XIT^APCLDP1"

 +4        DO ^XBDBQUE

XIT        KILL ZTSK,Y,APCLBD,APCLED,IO("Q"),APCL80D,APCLBTH,APCLHRCN,APCLJOB,APCLLENG,APCLPCNT,APCLPG,APCLNUM,APCLX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D

 +1        KILL APCLPRNM,APCLPRNT,APCLPROB,APCLPRV,APCLR,APCLRCNT,APCLRLOC,APCLSD,APCLTOT,APCLBDD,APCLBT,APCLEDD,APCLEDO,APCLBDO,APCLBT,APCLFOUN,APCLHIT,APCLID,APCLLINE,APCLP,APCLQ,APCLRCNT,APCLET

 +2        KILL I,J,K,P,X,Y,Z,%,DDH,DIV,DIU,DFN,DIG,DIW,APCLAGE,APCLPROV,C,D0,DA,DIC,DR,DIQ

 +3        DO EN^XBVK("APCL")

 +4        QUIT 

 +5       ;

PROC      ;EP - entry point for processing

 +1        SET APCLJOB=$JOB

           SET APCLBTH=$HOROLOG

           SET APCLTOT=0

           SET DFN=0

           SET APCLBT=$HOROLOG

 +2        DO XTMP^APCLOSUT("APCLDP1","PCC - DESIGNATED PROV REPORT")

 +3        IF APCLPROV]""

               DO PROC0

               QUIT 

 +4        FOR 

               SET APCLPROV=$ORDER(^AUPNPAT("AK",APCLPROV))

               IF APCLPROV'=+APCLPROV

                   QUIT 

               DO PROC0

 +5        SET APCLET=$HOROLOG

 +6        KILL DFN

 +7        QUIT 

PROC0     ;

 +1        SET DFN=0

           FOR 

               SET DFN=$ORDER(^AUPNPAT("AK",APCLPROV,DFN))

               IF DFN'=+DFN

                   QUIT 

               DO PROC1

 +2        QUIT 

PROC1     ;

 +1        IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))

               QUIT 

 +2        SET ^XTMP("APCLDP1",APCLJOB,APCLBTH,APCLPROV,DFN)=""

 +3        QUIT 

VSTS      ; process visits

 +1        SET APCLR=0

           SET APCLBDO=9999999-APCLBD

           SET APCLEDO=9999999-APCLED

           SET APCLSD=APCLED-1

           SET APCLRCNT=0

 +2        FOR 

               SET APCLSD=$ORDER(^AUPNVSIT("AA",DFN,APCLSD))

               IF APCLSD>APCLBDO!(APCLSD="")

                   QUIT 

               Begin DoDot:1

 +3                SET APCLR=0

                   FOR 

                       SET APCLR=$ORDER(^AUPNVSIT("AA",DFN,APCLSD,APCLR))

                       IF APCLR'=+APCLR

                           QUIT 

                       Begin DoDot:2

 +4                        IF '$PIECE(^AUPNVSIT(APCLR,0),U,9)

                               QUIT 

 +5                        IF $PIECE(^AUPNVSIT(APCLR,0),U,11)

                               QUIT 

 +6                        IF "ECT"[$PIECE(^AUPNVSIT(APCLR,0),U,7)

                               QUIT 

 +7       ;COUNT # VISITS

                           SET APCLRCNT=APCLRCNT+1

                       End DoDot:2

 +8                QUIT 

               End DoDot:1

 +9        IF APCLRCNT'<APCLNUM

               SET ^XTMP("APCLDP1",APCLJOB,APCLBTH,DFN)=""

 +10       QUIT 

 +11      ;