APCLVPVC ; IHS/CMI/LAB - APC visit counts by selected vars ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
START ;
I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q
S APCLSITE=DUZ(2)
S APCLJOB=$J,APCLBTH=$H
D INFORM
SEARCH ;
S DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)" S DIC="^DIBT(",DIC("A")="Enter SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR
I Y=-1 G XIT
S APCLSEAT=+Y
;
CP ;
S APCLCP=""
S DIR(0)="S^P:Provider;C:Clinic",DIR("A")="Tally which of the above",DIR("B")="P" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G XIT
S APCLCP=Y
GETDATES ;
BD ;get beginning date
W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Visit Date for Search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G CP
S APCLBD=Y
ED ;get ending date
W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Visit Date for Search: " 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
;
ZIS ;call to XBDBQUE
S XBRP="PRINT^APCLVPVC",XBRC="PROCESS^APCLVPVC",XBRX="XIT^APCLVPVC",XBNS="APCL"
D ^XBDBQUE
D XIT
Q
XIT ;
K APCLDX,APCLCP,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLTITL,APCL80S,APCLEDD,APCLHD1,APCLHD2,APCLLENG,APCLLOCT,APCLPG,APCLSRT2,APCLTOT,APCLBDD,APCLPROV,APCLSEC,APCLZ,APCLADIS,APCLQUIT,APCLLOCC,APCLBT,APCLBTH,APCLCLN,APCLCLNC
K APCLDT,APCLPDFN,APCLPRNT,APCLSEAT,APCLSITE,APCLSORT,C,D,E,F,A,B,Z,X,I,J
K APCLJOB,APCLRXCL,APCLOTHC
K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M
Q
INFORM ;
W:$D(IOF) @IOF
W !!,?10,"****PROVIDER OR CLINIC VISIT COUNTS FROM A TEMPLATE OF PATIENTS****",!!
W !!,"This report will tally the number of times a certain pre-defined set of ",!,"patients (within a Template) were seen by various providers",!,"or went to various clinics.",!!
W "The Template of Patients must first be created prior to running this report!",!!
Q
PROCESS ;
S APCLBT=$H
K ^TMP("APCLVPVC",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLVPVC","PCC REPORT OF VISITS")
;
;
S ;
S DFN=0 F S DFN=$O(^DIBT(APCLSEAT,1,DFN)) Q:DFN'=+DFN D @APCLCP
END ;
S APCLET=$H
D EOJ
Q
C ;clinic
S APCLPDFN=0 F S APCLPDFN=$O(^AUPNVSIT("AC",DFN,APCLPDFN)) Q:APCLPDFN'=+APCLPDFN I $P(^AUPNVSIT(APCLPDFN,0),U,8)]"" D C1
Q
C1 ;
S D=$P($P(^AUPNVSIT(APCLPDFN,0),U),".")
Q:D<APCLBD
Q:D>APCLED
S APCLCLN=$P(^DIC(40.7,$P(^AUPNVSIT(APCLPDFN,0),U,8),0),U)
S APCLCLNC=$S($P(^DIC(40.7,$P(^AUPNVSIT(APCLPDFN,0),U,8),0),U,2)]"":$P(^DIC(40.7,$P(^AUPNVSIT(APCLPDFN,0),U,8),0),U,2),1:"???")
S ^(APCLCLNC)=$S($D(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLCLN,APCLCLNC)):^(APCLCLNC)+1,1:1)
Q
P ;
S APCLPDFN="" F S APCLPDFN=$O(^AUPNVPRV("AC",DFN,APCLPDFN)) Q:APCLPDFN'=+APCLPDFN I $D(^AUPNVPRV(APCLPDFN,0)) S APCLVREC=^(0) D P1,EOJ
Q
P1 ;
S D=$P(^AUPNVPRV(APCLPDFN,0),U,3)
Q:D=""
Q:'$D(^AUPNVSIT(D,0))
S D=$P($P(^AUPNVSIT(D,0),U),".")
Q:D<APCLBD
Q:D>APCLED
S APCLAP=$P(APCLVREC,U),APCLNAME=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,APCLAP,0),U),1:$P(^DIC(16,APCLAP,0),U))
S APCLDISC="" D CHKDISC
Q:$D(APCLSKIP)
S ^(APCLDISC)=$S($D(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLNAME,APCLDISC)):^(APCLDISC)+1,1:1)
Q
EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ,APCLLOCC
Q
;
CHKDISC ;
I $P(^DD(9000010.06,.01,0),U,2)[200 D CHKDISC2 Q ;FILE 200 CONV
S APCLY=$P(^DIC(6,APCLAP,0),U,4)
I APCLY="" S APCLDISC="??" Q
S APCLDISC=$P(^DIC(7,APCLY,0),U) I APCLDISC="" S APCLDISC="??" Q
Q
;
;
CHKDISC2 ;CHECK DISC IF CONVERTED TO FILE 200
I '$D(^VA(200,APCLAP)) S APCLSKIP=1 Q
S APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I") I APCLDPTR=""!(APCLDPTR="UNKNOWN") S APCLDISC="???" Q
S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="" S APCLDISC="UNKNOWN"
Q
;
PRINT ;
S APCL80S="*******************************************************************************"
S APCLDT=$$FMTE^XLFDT(DT)
S (APCLTOT,APCLPG)=0 D HEAD
S APCLSORT=0 K APCLQUIT
F I=0:0 S APCLSORT=$O(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT)) Q:APCLSORT=""!($D(APCLQUIT)) D PRINT1
G:$D(APCLQUIT) DONE
I $Y>(IOSL-5) D HEAD G:$D(APCLQUIT) DONE
W !?61,"-------",!
W ?52,"Total:",?60,$J(APCLTOT,8),!
DONE ;
D DONE^APCLOSUT
K ^TMP("APCLVPVC",APCLJOB,APCLBTH)
Q
PRINT1 ;
I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)
S APCLSRT2=$O(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT,""))
S APCLPRNT=APCLSORT
W !?5,$E(APCLPRNT,1,25),?35,$E(APCLSRT2,1,20),?60,$J(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT,APCLSRT2),8)
S APCLTOT=APCLTOT+^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT,APCLSRT2)
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 APCLQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W APCL80S,!
W "*",?3,$P(^DIC(4,APCLSITE,0),U),?58,APCLDT,?72,"Page ",APCLPG,?78,"*",!
W "*",?78,"*",!
S APCLLENG=26
W "*",?((80-APCLLENG)/2),"NUMBER OF VISITS BY PROVIDER",?78,"*",!
W "*",?26,"SEARCH TEMPLATE: ",$P(^DIBT(APCLSEAT,0),U),?78,"*",!
W APCL80S,!
W !!
W ?5,"PROVIDER",?35,"CLASS",?60,"# VISITS",!
Q
APCLVPVC ; IHS/CMI/LAB - APC visit counts by selected vars ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
START ;
+1 IF '$GET(DUZ(2))
WRITE $CHAR(7),$CHAR(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!!
QUIT
+2 SET APCLSITE=DUZ(2)
+3 SET APCLJOB=$JOB
SET APCLBTH=$HOROLOG
+4 DO INFORM
SEARCH ;
+1 SET DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)"
SET DIC="^DIBT("
SET DIC("A")="Enter SEARCH TEMPLATE name: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DICR
+2 IF Y=-1
GOTO XIT
+3 SET APCLSEAT=+Y
+4 ;
CP ;
+1 SET APCLCP=""
+2 SET DIR(0)="S^P:Provider;C:Clinic"
SET DIR("A")="Tally which of the above"
SET DIR("B")="P"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
GOTO XIT
+4 SET APCLCP=Y
GETDATES ;
BD ;get beginning date
+1 WRITE !
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter beginning Visit Date for Search"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO CP
+3 SET APCLBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="DA^"_APCLBD_":DT:EP"
SET DIR("A")="Enter ending Visit Date for Search: "
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
+5 ;
ZIS ;call to XBDBQUE
+1 SET XBRP="PRINT^APCLVPVC"
SET XBRC="PROCESS^APCLVPVC"
SET XBRX="XIT^APCLVPVC"
SET XBNS="APCL"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
XIT ;
+1 KILL APCLDX,APCLCP,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLTITL,APCL80S,APCLEDD,APCLHD1,APCLHD2,APCLLENG,APCLLOCT,APCLPG,APCLSRT2,APCLTOT,APCLBDD,APCLPROV,APCLSEC,APCLZ,APCLADIS,APCLQUIT,APCLLOCC,APCLBT,APCLBTH,APCLCLN,APCLCLNC
+2 KILL APCLDT,APCLPDFN,APCLPRNT,APCLSEAT,APCLSITE,APCLSORT,C,D,E,F,A,B,Z,X,I,J
+3 KILL APCLJOB,APCLRXCL,APCLOTHC
+4 KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M
+5 QUIT
INFORM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,?10,"****PROVIDER OR CLINIC VISIT COUNTS FROM A TEMPLATE OF PATIENTS****",!!
+3 WRITE !!,"This report will tally the number of times a certain pre-defined set of ",!,"patients (within a Template) were seen by various providers",!,"or went to various clinics.",!!
+4 WRITE "The Template of Patients must first be created prior to running this report!",!!
+5 QUIT
PROCESS ;
+1 SET APCLBT=$HOROLOG
+2 KILL ^TMP("APCLVPVC",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLVPVC","PCC REPORT OF VISITS")
+4 ;
+5 ;
S ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^DIBT(APCLSEAT,1,DFN))
IF DFN'=+DFN
QUIT
DO @APCLCP
END ;
+1 SET APCLET=$HOROLOG
+2 DO EOJ
+3 QUIT
C ;clinic
+1 SET APCLPDFN=0
FOR
SET APCLPDFN=$ORDER(^AUPNVSIT("AC",DFN,APCLPDFN))
IF APCLPDFN'=+APCLPDFN
QUIT
IF $PIECE(^AUPNVSIT(APCLPDFN,0),U,8)]""
DO C1
+2 QUIT
C1 ;
+1 SET D=$PIECE($PIECE(^AUPNVSIT(APCLPDFN,0),U),".")
+2 IF D<APCLBD
QUIT
+3 IF D>APCLED
QUIT
+4 SET APCLCLN=$PIECE(^DIC(40.7,$PIECE(^AUPNVSIT(APCLPDFN,0),U,8),0),U)
+5 SET APCLCLNC=$SELECT($PIECE(^DIC(40.7,$PIECE(^AUPNVSIT(APCLPDFN,0),U,8),0),U,2)]"":$PIECE(^DIC(40.7,$PIECE(^AUPNVSIT(APCLPDFN,0),U,8),0),U,2),1:"???")
+6 SET ^(APCLCLNC)=$SELECT($DATA(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLCLN,APCLCLNC)):^(APCLCLNC)+1,1:1)
+7 QUIT
P ;
+1 SET APCLPDFN=""
FOR
SET APCLPDFN=$ORDER(^AUPNVPRV("AC",DFN,APCLPDFN))
IF APCLPDFN'=+APCLPDFN
QUIT
IF $DATA(^AUPNVPRV(APCLPDFN,0))
SET APCLVREC=^(0)
DO P1
DO EOJ
+2 QUIT
P1 ;
+1 SET D=$PIECE(^AUPNVPRV(APCLPDFN,0),U,3)
+2 IF D=""
QUIT
+3 IF '$DATA(^AUPNVSIT(D,0))
QUIT
+4 SET D=$PIECE($PIECE(^AUPNVSIT(D,0),U),".")
+5 IF D<APCLBD
QUIT
+6 IF D>APCLED
QUIT
+7 SET APCLAP=$PIECE(APCLVREC,U)
SET APCLNAME=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,APCLAP,0),U),1:$PIECE(^DIC(16,APCLAP,0),U))
+8 SET APCLDISC=""
DO CHKDISC
+9 IF $DATA(APCLSKIP)
QUIT
+10 SET ^(APCLDISC)=$SELECT($DATA(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLNAME,APCLDISC)):^(APCLDISC)+1,1:1)
+11 QUIT
EOJ KILL APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ,APCLLOCC
+1 QUIT
+2 ;
CHKDISC ;
+1 ;FILE 200 CONV
IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
DO CHKDISC2
QUIT
+2 SET APCLY=$PIECE(^DIC(6,APCLAP,0),U,4)
+3 IF APCLY=""
SET APCLDISC="??"
QUIT
+4 SET APCLDISC=$PIECE(^DIC(7,APCLY,0),U)
IF APCLDISC=""
SET APCLDISC="??"
QUIT
+5 QUIT
+6 ;
+7 ;
CHKDISC2 ;CHECK DISC IF CONVERTED TO FILE 200
+1 IF '$DATA(^VA(200,APCLAP))
SET APCLSKIP=1
QUIT
+2 SET APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I")
IF APCLDPTR=""!(APCLDPTR="UNKNOWN")
SET APCLDISC="???"
QUIT
+3 SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
IF APCLDISC=""
SET APCLDISC="UNKNOWN"
+4 QUIT
+5 ;
PRINT ;
+1 SET APCL80S="*******************************************************************************"
+2 SET APCLDT=$$FMTE^XLFDT(DT)
+3 SET (APCLTOT,APCLPG)=0
DO HEAD
+4 SET APCLSORT=0
KILL APCLQUIT
+5 FOR I=0:0
SET APCLSORT=$ORDER(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT))
IF APCLSORT=""!($DATA(APCLQUIT))
QUIT
DO PRINT1
+6 IF $DATA(APCLQUIT)
GOTO DONE
+7 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQUIT)
GOTO DONE
+8 WRITE !?61,"-------",!
+9 WRITE ?52,"Total:",?60,$JUSTIFY(APCLTOT,8),!
DONE ;
+1 DO DONE^APCLOSUT
+2 KILL ^TMP("APCLVPVC",APCLJOB,APCLBTH)
+3 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 SET APCLSRT2=$ORDER(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT,""))
+3 SET APCLPRNT=APCLSORT
+4 WRITE !?5,$EXTRACT(APCLPRNT,1,25),?35,$EXTRACT(APCLSRT2,1,20),?60,$JUSTIFY(^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT,APCLSRT2),8)
+5 SET APCLTOT=APCLTOT+^TMP("APCLVPVC",APCLJOB,APCLBTH,APCLSORT,APCLSRT2)
+6 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 APCLQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE APCL80S,!
+3 WRITE "*",?3,$PIECE(^DIC(4,APCLSITE,0),U),?58,APCLDT,?72,"Page ",APCLPG,?78,"*",!
+4 WRITE "*",?78,"*",!
+5 SET APCLLENG=26
+6 WRITE "*",?((80-APCLLENG)/2),"NUMBER OF VISITS BY PROVIDER",?78,"*",!
+7 WRITE "*",?26,"SEARCH TEMPLATE: ",$PIECE(^DIBT(APCLSEAT,0),U),?78,"*",!
+8 WRITE APCL80S,!
+9 WRITE !!
+10 WRITE ?5,"PROVIDER",?35,"CLASS",?60,"# VISITS",!
+11 QUIT
