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 ;
