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
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^APCLPRPM"")"
S XBNS="APCL",XBRC="PROC^APCLPRPM",XBRX="EOJ^APCLPRPM",XBIOP=0 D ^XBDBQUE
Q
;
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
Q
EOJ ;
D EN^XBVK("APCL")
K L,M,S,T,X,X1,X2,Y,Z,B
D KILL^AUPNPAT
D ^XBFMK
Q
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
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("APCLPRPM",APCLJOB,APCLBTH,APCLPROV,DFN)=""
Q
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
Q
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
Q
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,!
Q
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)
Q
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
