Routine: APCLPRPM

APCLPRPM ; IHS/CMI/LAB - driver for primary care provider report ;

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

 W:$D(IOF) @IOF

 W !,"This report will generate a list of patients for a specific Designated Primary Care"

 W !,"Provider or a list of patients for all Primary Care Providers at this facility."

 I '$G(DUZ(2)) W !!!,$C(7),$C(7),"SITE NOT SET IN YOUR USER PROFILE!  Please notify your Site Manager!" Q

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) EOJ

 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 ;

 ;S FLDS="[APCL PRIM PROV LISTING]",BY=$S(APCLPROV="":"#.14",1:"@INTERNAL(#.14)"),DIC="^AUPNPAT(",L=0 I APCLPROV S DHD="[APCL PRIM PROV HEADING]"

 ;S FR=$S(APCLPROV="":"",1:APCLPROV),TO=$S(APCLPROV="":"",1:APCLPROV)

 ;K DHIT,DIOEND,DIOBEG

 ;D EN1^DIP

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G ASK

 S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) G EOJ

 S APCLBROW=Y

 I $G(Y)="B" D BROWSE,EOJ Q

 W !! S XBRP="PRINT^APCLPRPM",XBRC="PROC^APCLPRPM",XBNS="APCL",XBRX="EOJ^APCLPRPM"

 D ^XBDBQUE

 D EOJ

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^APCLPRPM"")"

 S XBNS="APCL",XBRC="PROC^APCLPRPM",XBRX="EOJ^APCLPRPM",XBIOP=0 D ^XBDBQUE

PAUSE ;

 S DIR(0)="E",DIR("A")="Press return to continue or '^' to quit" D ^DIR K DIR,DA

 S:$D(DIRUT) APCLQUIT=1

 W:$D(IOF) @IOF

EOJ ;

 D EN^XBVK("APCL")

 K L,M,S,T,X,X1,X2,Y,Z,B

 D KILL^AUPNPAT

 D ^XBFMK

PROC ;

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

 D XTMP^APCLOSUT("APCLPRPM","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

PROC0 ;

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

PROC1 ;

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

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

PRINT ;

START ;

 S APCL80D="-------------------------------------------------------------------------------"

 S APCLPG=0

 I '$D(^XTMP("APCLPRPM",APCLJOB,APCLBTH)) D HEAD W !!,"NO PATIENTS TO REPORT" G DONE

 I APCLBROW="B" D HEAD

 S APCLPROV=0 F  S APCLPROV=$O(^XTMP("APCLPRPM",APCLJOB,APCLBTH,APCLPROV)) Q:APCLPROV'=+APCLPROV!($D(APCLQ))  D

 .S DFN="",APCLSUB=0 K APCLQ

 .I APCLBROW="P" D HEAD Q:$D(APCLQ)

 .I APCLBROW="B" W !!

 .W ?9,"PRIMARY CARE PROVIDER:  "_$$VAL^XBDIQ1(200,APCLPROV,.01),!

 .F  S DFN=$O(^XTMP("APCLPRPM",APCLJOB,APCLBTH,APCLPROV,DFN)) Q:DFN=""!($D(APCLQ))  D DFN

 .Q:$D(APCLQ)

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

 .W !,"Total # of Patients for ",$$VAL^XBDIQ1(200,APCLPROV,.01),":  ",APCLSUB,!

 G:$D(APCLQ) DONE

DONE D DONE^APCLOSUT

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

DFN ;

 I $Y>(IOSL-6) D HEAD Q:$D(APCLQ)

 D LVST

 W $E($P(^DPT(DFN,0),U),1,20),?24,$$UP^XLFSTR($$DOB^AUPNPAT(DFN,"E")),?40,$$HRN^AUPNPAT(DFN,DUZ(2)),?50,$E($$COMMRES^AUPNPAT(DFN,"E"),1,15),?66,APCLDT,!

 S APCLSUB=APCLSUB+1

HEAD I 'APCLPG G HEAD1

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

HEAD1 ;

 I APCLPG W:$D(IOF) @IOF

 S APCLPG=APCLPG+1

 W $P(^VA(200,DUZ,0),U,2)

 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!

 W ?5,"DESIGNATED PROVIDER PATIENT LISTING    "_$$FMTE^XLFDT($$NOW^XLFDT)_"    PAGE  "_APCLPG,!

 W ?50,"CURRENT",!

 W "NAME",?24,"DOB",?40,"HRN",?50,"COMMUNITY",?66,"LAST VISIT",!,APCL80D,!

LVST ;ENTRY POINT from [APCL PRIM PROV LISTING print template

 S APCLAST=""

 S APCLVDFN=""

 S APCLAST=$O(^AUPNVSIT("AA",DFN,""))

 I APCLAST="" S APCLAST="NONE FOUND" Q

 S APCLVDFN=$O(^AUPNVSIT("AA",DFN,APCLAST,""))

 S Y=$P(^AUPNVSIT(APCLVDFN,0),U)

 D DD^%DT S APCLDT=$E(Y,1,12)

APCLPRPM  ; IHS/CMI/LAB - driver for primary care provider report ;

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

 +2       ;

 +3        IF $DATA(IOF)

               WRITE @IOF

 +4        WRITE !,"This report will generate a list of patients for a specific Designated Primary Care"

 +5        WRITE !,"Provider or a list of patients for all Primary Care Providers at this facility."

 +6        IF '$GET(DUZ(2))

               WRITE !!!,$CHAR(7),$CHAR(7),"SITE NOT SET IN YOUR USER PROFILE!  Please notify your Site Manager!"

               QUIT

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 EOJ

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

 +1       ;S FLDS="[APCL PRIM PROV LISTING]",BY=$S(APCLPROV="":"#.14",1:"@INTERNAL(#.14)"),DIC="^AUPNPAT(",L=0 I APCLPROV S DHD="[APCL PRIM PROV HEADING]"

 +2       ;S FR=$S(APCLPROV="":"",1:APCLPROV),TO=$S(APCLPROV="":"",1:APCLPROV)

 +3       ;K DHIT,DIOEND,DIOBEG

 +4       ;D EN1^DIP

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO ASK

 +3        SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to "

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO EOJ

 +5        SET APCLBROW=Y

 +6        IF $GET(Y)="B"

               DO BROWSE

               DO EOJ

               QUIT

 +7        WRITE !!

           SET XBRP="PRINT^APCLPRPM"

           SET XBRC="PROC^APCLPRPM"

           SET XBNS="APCL"

           SET XBRX="EOJ^APCLPRPM"

 +8        DO ^XBDBQUE

 +9        DO EOJ

 +10       QUIT

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""PRINT^APCLPRPM"")"

 +2        SET XBNS="APCL"

           SET XBRC="PROC^APCLPRPM"

           SET XBRX="EOJ^APCLPRPM"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT

 +4       ;

PAUSE     ;

 +1        SET DIR(0)="E"

           SET DIR("A")="Press return to continue or '^' to quit"

           DO ^DIR

           KILL DIR,DA

 +2        IF $DATA(DIRUT)

               SET APCLQUIT=1

 +3        IF $DATA(IOF)

               WRITE @IOF

 +4        QUIT

EOJ       ;

 +1        DO EN^XBVK("APCL")

 +2        KILL L,M,S,T,X,X1,X2,Y,Z,B

 +3        DO KILL^AUPNPAT

 +4        DO ^XBFMK

 +5        QUIT

PROC      ;

 +1        SET APCLJOB=$JOB

           SET APCLBTH=$HOROLOG

           SET APCLTOT=0

           SET DFN=0

           SET APCLBT=$HOROLOG

 +2        DO XTMP^APCLOSUT("APCLPRPM","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("APCLPRPM",APCLJOB,APCLBTH,APCLPROV,DFN)=""

 +3        QUIT

PRINT     ;

START     ;

 +1        SET APCL80D="-------------------------------------------------------------------------------"

 +2        SET APCLPG=0

 +3        IF '$DATA(^XTMP("APCLPRPM",APCLJOB,APCLBTH))

               DO HEAD

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

 +4        IF APCLBROW="B"

               DO HEAD

 +5        SET APCLPROV=0

FOR

               SET APCLPROV=$ORDER(^XTMP("APCLPRPM",APCLJOB,APCLBTH,APCLPROV))

               IF APCLPROV'=+APCLPROV!($DATA(APCLQ))

                   QUIT

               Begin DoDot:1

 +6                SET DFN=""

                   SET APCLSUB=0

                   KILL APCLQ

 +7                IF APCLBROW="P"

                       DO HEAD

                       IF $DATA(APCLQ)

                           QUIT

 +8                IF APCLBROW="B"

                       WRITE !!

 +9                WRITE ?9,"PRIMARY CARE PROVIDER:  "_$$VAL^XBDIQ1(200,APCLPROV,.01),!

 +10               FOR

                       SET DFN=$ORDER(^XTMP("APCLPRPM",APCLJOB,APCLBTH,APCLPROV,DFN))

                       IF DFN=""!($DATA(APCLQ))

                           QUIT

                       DO DFN

 +11               IF $DATA(APCLQ)

                       QUIT

 +12               IF $Y>(IOSL-3)

                       DO HEAD

                       IF $DATA(APCLQ)

                           QUIT

 +13               WRITE !,"Total # of Patients for ",$$VAL^XBDIQ1(200,APCLPROV,.01),":  ",APCLSUB,!

               End DoDot:1

 +14       IF $DATA(APCLQ)

               GOTO DONE

DONE       DO DONE^APCLOSUT

 +1        KILL ^XTMP("APCLPRPM",APCLJOB,APCLBTH),APCLJOB,APCLBTH

 +2        QUIT

DFN       ;

 +1        IF $Y>(IOSL-6)

               DO HEAD

               IF $DATA(APCLQ)

                   QUIT

 +2        DO LVST

 +3        WRITE $EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?24,$$UP^XLFSTR($$DOB^AUPNPAT(DFN,"E")),?40,$$HRN^AUPNPAT(DFN,DUZ(2)),?50,$EXTRACT($$COMMRES^AUPNPAT(DFN,"E"),1,15),?66,APCLDT,!

 +4        SET APCLSUB=APCLSUB+1

 +5        QUIT

HEAD       IF 'APCLPG

               GOTO HEAD1

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

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

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

                       SET APCLQ=""

                       QUIT

HEAD1     ;

 +1        IF APCLPG

               IF $DATA(IOF)

                   WRITE @IOF

 +2        SET APCLPG=APCLPG+1

 +3        WRITE $PIECE(^VA(200,DUZ,0),U,2)

 +4        WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!

 +5        WRITE ?5,"DESIGNATED PROVIDER PATIENT LISTING    "_$$FMTE^XLFDT($$NOW^XLFDT)_"    PAGE  "_APCLPG,!

 +6        WRITE ?50,"CURRENT",!

 +7        WRITE "NAME",?24,"DOB",?40,"HRN",?50,"COMMUNITY",?66,"LAST VISIT",!,APCL80D,!

 +8        QUIT

LVST      ;ENTRY POINT from [APCL PRIM PROV LISTING print template

 +1        SET APCLAST=""

 +2        SET APCLVDFN=""

 +3        SET APCLAST=$ORDER(^AUPNVSIT("AA",DFN,""))

 +4        IF APCLAST=""

               SET APCLAST="NONE FOUND"

               QUIT

 +5        SET APCLVDFN=$ORDER(^AUPNVSIT("AA",DFN,APCLAST,""))

 +6        SET Y=$PIECE(^AUPNVSIT(APCLVDFN,0),U)

 +7        DO DD^%DT

           SET APCLDT=$EXTRACT(Y,1,12)

 +8        QUIT

APCLPRPM.m