APCLFPRP ; IHS/CMI/LAB - cont. of top ten ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in PPRC
;
PRINT ;EP
COVPAGE ;EP
W:$D(IOF) @IOF
W !?20,"********** FREQUENCY OF PROCEDURES REPORT **********"
W !!,"REPORT REQUESTED BY: ",$P(^VA(200,DUZ,0),U)
W !!,"The following report contains a ",$S(APCLPTVS="V":"PCC Visit",1:"Patient")," report based on the",!,"following criteria:",!
SHOW ;
W !,$S(APCLPTVS="P":"PATIENT",1:"VISIT")," Selection Criteria"
W:APCLTYPE="D" !!?6,"Encounter Date range: ",APCLBDD," to ",APCLEDD,!
W:APCLTYPE="S" !!?6,"Search Template: ",$P(^DIBT(APCLSEAT,0),U),!
I '$D(^APCLVRPT(APCLRPT,11)) W !!,"ALL VISITS IN DATE RANGE SELECTED." G COUNT
S APCLI=0 F S APCLI=$O(^APCLVRPT(APCLRPT,11,APCLI)) Q:APCLI'=+APCLI D
.I $Y>(IOSL-5) D PAUSE^APCLVL01 W @IOF
.W !?6,$P(^APCLVSTS(APCLI,0),U),": "
.K APCLQ S APCLY="",C=0 K APCLQ F S APCLY=$O(^APCLVRPT(APCLRPT,11,APCLI,11,"B",APCLY)) S C=C+1 W:C'=1&(APCLY'="") " ; " Q:APCLY=""!($D(APCLQ)) S X=APCLY X:$D(^APCLVSTS(APCLI,2)) ^(2) W X
K APCLQ
COUNT ;if COUNTING entries only
I $Y>(IOSL-5) D PAUSE^APCLVL01 W:$D(IOF) @IOF
W:$D(APCLVTOT) !!!,"Total COUNT of ",$S(APCLPTVS="P":"Patients",1:"Visits"),": ",APCLVTOT
D PAUSE^APCLVL01
W:$D(IOF) @IOF
W !?20,"********** FREQUENCY OF PROCEDURES REPORT **********"
PPRC I $E(IOST)="C",IO=IO(0),$Y>(IOSL-4) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q
I $Y>(IOSL-4) W:$D(IOF) @IOF
S %="^XTMP(""APCLFPR"",APCLJOB,APCLBT,",APCLA=%_"""PRC"",APCLPRC)",APCLF=%_"3)"
W !!,"No. VISITs: ",APCLVTOT,?20,"No. PRCs: ",APCLTOT,?40,"PRC/VISIT ratio: ",$S(APCLVTOT>0:$J((APCLTOT/APCLVTOT),1,2),1:0)," (min. std. > 1.6)" S APCLLINO=APCLLINO+2
W !!!,"TOP ",APCLLNO," PRC's =>" S APCLLINO=APCLLINO+3
;F I=1:1 Q:'$D(@APCLF@(I)) S APCLPRC=@APCLF@(I) W !?3,I,".",?7,$P(^ICD0(APCLPRC,0),U),?15,$P(^ICD0(APCLPRC,0),U,4)," (",@APCLA,")" S APCLLINO=APCLLINO+1 I $Y>(IOSL-8) D FF I $D(X),X=U G PEXIT ;cmi/anch/maw 9/12/2007 orig line
F I=1:1 Q:'$D(@APCLF@(I)) S APCLPRC=@APCLF@(I) W !?3,I,".",?7,$P($$ICDOP^ICDEX(APCLPRC,,,"I"),U,2),?15,$P($$ICDOP^ICDEX(APCLPRC,,,"I"),U,5)," (",@APCLA,")" S APCLLINO=APCLLINO+1 I $Y>(IOSL-8) D FF I $D(X),X=U G PEXIT
F %=1:1:2 W ! S APCLLINO=APCLLINO+1 I $Y>(IOSL-5) D FF I $D(X),X=U G PEXIT
PEXIT ;
D DONE^APCLOSUT
K ^XTMP("APCLFPR",APCLJOB,APCLBT) Q
FF I IOST["P-" W:$D(IOF) @IOF Q
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S X="^"
W:$D(IOF) @IOF
Q
;
APCLFPRP ; IHS/CMI/LAB - cont. of top ten ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in PPRC
+4 ;
PRINT ;EP
COVPAGE ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !?20,"********** FREQUENCY OF PROCEDURES REPORT **********"
+3 WRITE !!,"REPORT REQUESTED BY: ",$PIECE(^VA(200,DUZ,0),U)
+4 WRITE !!,"The following report contains a ",$SELECT(APCLPTVS="V":"PCC Visit",1:"Patient")," report based on the",!,"following criteria:",!
SHOW ;
+1 WRITE !,$SELECT(APCLPTVS="P":"PATIENT",1:"VISIT")," Selection Criteria"
+2 IF APCLTYPE="D"
WRITE !!?6,"Encounter Date range: ",APCLBDD," to ",APCLEDD,!
+3 IF APCLTYPE="S"
WRITE !!?6,"Search Template: ",$PIECE(^DIBT(APCLSEAT,0),U),!
+4 IF '$DATA(^APCLVRPT(APCLRPT,11))
WRITE !!,"ALL VISITS IN DATE RANGE SELECTED."
GOTO COUNT
+5 SET APCLI=0
FOR
SET APCLI=$ORDER(^APCLVRPT(APCLRPT,11,APCLI))
IF APCLI'=+APCLI
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-5)
DO PAUSE^APCLVL01
WRITE @IOF
+7 WRITE !?6,$PIECE(^APCLVSTS(APCLI,0),U),": "
+8 KILL APCLQ
SET APCLY=""
SET C=0
KILL APCLQ
FOR
SET APCLY=$ORDER(^APCLVRPT(APCLRPT,11,APCLI,11,"B",APCLY))
SET C=C+1
IF C'=1&(APCLY'="")
WRITE " ; "
IF APCLY=""!($DATA(APCLQ))
QUIT
SET X=APCLY
IF $DATA(^APCLVSTS(APCLI,2))
XECUTE ^(2)
WRITE X
End DoDot:1
+9 KILL APCLQ
COUNT ;if COUNTING entries only
+1 IF $Y>(IOSL-5)
DO PAUSE^APCLVL01
IF $DATA(IOF)
WRITE @IOF
+2 IF $DATA(APCLVTOT)
WRITE !!!,"Total COUNT of ",$SELECT(APCLPTVS="P":"Patients",1:"Visits"),": ",APCLVTOT
+3 DO PAUSE^APCLVL01
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !?20,"********** FREQUENCY OF PROCEDURES REPORT **********"
PPRC IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF $Y>(IOSL-4)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
+1 IF $Y>(IOSL-4)
IF $DATA(IOF)
WRITE @IOF
+2 SET %="^XTMP(""APCLFPR"",APCLJOB,APCLBT,"
SET APCLA=%_"""PRC"",APCLPRC)"
SET APCLF=%_"3)"
+3 WRITE !!,"No. VISITs: ",APCLVTOT,?20,"No. PRCs: ",APCLTOT,?40,"PRC/VISIT ratio: ",$SELECT(APCLVTOT>0:$JUSTIFY((APCLTOT/APCLVTOT),1,2),1:0)," (min. std. > 1.6)"
SET APCLLINO=APCLLINO+2
+4 WRITE !!!,"TOP ",APCLLNO," PRC's =>"
SET APCLLINO=APCLLINO+3
+5 ;F I=1:1 Q:'$D(@APCLF@(I)) S APCLPRC=@APCLF@(I) W !?3,I,".",?7,$P(^ICD0(APCLPRC,0),U),?15,$P(^ICD0(APCLPRC,0),U,4)," (",@APCLA,")" S APCLLINO=APCLLINO+1 I $Y>(IOSL-8) D FF I $D(X),X=U G PEXIT ;cmi/anch/maw 9/12/2007 orig line
+6 FOR I=1:1
IF '$DATA(@APCLF@(I))
QUIT
SET APCLPRC=@APCLF@(I)
WRITE !?3,I,".",?7,$PIECE($$ICDOP^ICDEX(APCLPRC,,,"I"),U,2),?15,$PIECE($$ICDOP^ICDEX(APCLPRC,,,"I"),U,5)," (",@APCLA,")"
SET APCLLINO=APCLLINO+1
IF $Y>(IOSL-8)
DO FF
IF $DATA(X)
IF X=U
GOTO PEXIT
+7 FOR %=1:1:2
WRITE !
SET APCLLINO=APCLLINO+1
IF $Y>(IOSL-5)
DO FF
IF $DATA(X)
IF X=U
GOTO PEXIT
PEXIT ;
+1 DO DONE^APCLOSUT
+2 KILL ^XTMP("APCLFPR",APCLJOB,APCLBT)
QUIT
FF IF IOST["P-"
IF $DATA(IOF)
WRITE @IOF
QUIT
+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 X="^"
+2 IF $DATA(IOF)
WRITE @IOF
+3 QUIT
+4 ;
