BMCFYP ; IHS/PHXAO/TMJ - Print Routine for FY PO Cost Analysis ;
;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;
PRINT W:$D(IOF) @IOF,?20,"***** FREQUENCY OF DIAGNOSIS REPORT *****",!!
COVPAGE ;EP
W:$D(IOF) @IOF
W !?20,"********** FREQUENCY OF DIAGNOSES REPORT **********"
W !!,"REPORT REQUESTED BY: ",$P(^VA(200,DUZ,0),U)
W !!,"The following report contains a ",$S(BMCPTVS="R":"PCC Visit",1:"Patient")," report based on the",!,"following criteria:",!
SHOW ;
W !,$S(BMCPTVS="P":"PATIENT",1:"VISIT")," Selection Criteria"
W:BMCTYPE="D" !!?6,"Encounter Date range: ",BMCBDD," to ",BMCEDD,!
W:BMCTYPE="S" !!?6,"Search Template: ",$P(^DIBT(BMCSEAT,0),U),!
I '$D(^BMCRTMP(BMCRPT,11)) W !!?5,"ALL VISITS IN DATE RANGE SELECTED." G COUNT
S BMCI=0 F S BMCI=$O(^BMCRTMP(BMCRPT,11,BMCI)) Q:BMCI'=+BMCI D
.I $Y>(IOSL-5) D PAUSE^BMCRL01 W @IOF
.W !?6,$P(^BMCTSORT(BMCI,0),U),": "
.K BMCQ S BMCY=0,C=0 K BMCQ F S BMCY=$O(^BMCRTMP(BMCRPT,11,BMCI,11,"B",BMCY)) S C=C+1 W:C'=1&(BMCY'="") " ; " Q:BMCY=""!($D(BMCQ)) S X=BMCY X:$D(^BMCTSORT(BMCI,2)) ^(2) W X
K BMCQ
COUNT ;if COUNTING entries only
I $Y>(IOSL-5) D PAUSE^BMCRL01 W:$D(IOF) @IOF
I $D(BMCALL) W !!?5,"ALL (Primary and Secondary) POV's included.",!
I $D(BMCPRIM) W !!?5,"PRIMARY POV's Only",!
W:$D(BMCRTOT) !!!,"Total COUNT of ",$S(BMCPTVS="P":"Patients",1:"Visits"),": ",BMCRTOT
D PAUSE^BMCRL01
W:$D(IOF) @IOF
K BMCQUIT
W !?20,"********** FREQUENCY OF DIAGNOSES REPORT **********"
PPOV 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 BMCQUIT="" Q
S %="^XTMP(""BMCFY"",BMCJOB,BMCBT,",A=%_"""POV"",BMCPOV)",B=%_"""APC"",BMCAPC)",C=%_"1)",E=%_"2)",F=%_"3)",G=%_"4)"
W !!,"No. VISITs: ",BMCRTOT,?20,"No. POVs: ",BMCTOT,?40,"POV/VISIT ratio: ",$S(BMCRTOT>0:$J((BMCTOT/BMCRTOT),1,2),1:0)," (min. std. > 1.6)"
W !!!,"TOP ",BMCLNO," POV's =>",!
S J=0 F I=1:1 Q:'$D(@F@(I))!($D(BMCQUIT)) D
.S BMCPOV=@F@(I)
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.I I=1,BMCCHRT="B" D SETDASH(A)
.;BMC 4.0*3 10.25.2007 IHS/OIT/FCJ CSV CHANGES NXT 4 LINES
.;I BMCCHRT="L" W !?3,I,".",?7,$P(^ICD9(BMCPOV,0),U),?15,$P(^ICD9(BMCPOV,0),U,3)," (",@A,")" Q
.I BMCCHRT="L" W !?3,I,".",?7,$P($$ICDDX^ICDCODE(BMCPOV,0),U,2),?15,$P($$ICDDX^ICDCODE(BMCPOV,0),U,4)," (",@A,")" Q
.;W !,$E($P(^ICD9(BMCPOV,0),U,3),1,17),?18," (",$P(^ICD9(BMCPOV,0),U),")",?27,"|" S L=+(@A),D=L\BMCDASH F %=1:1:D W "*"
.W !,$E($P($$ICDDX^ICDCODE(BMCPOV,,,"I"),U,4),1,17),?18," (",$P($$ICDDX^ICDCODE(BMCPOV,,,"I"),U,2),")",?27,"|" S L=+(@A),D=L\BMCDASH F %=1:1:D W "*"
.W " ",+(@A)
.Q
G:$D(BMCQUIT) PEXIT
I $Y>(IOSL-5) D FF G:$D(BMCQUIT) PEXIT
I BMCCHRT="B" D
.W ! S J=27 F X=1:1:10 W ?J,"|_________" S J=J+10
.W "|",!
.S J=27 F X=0:1:10 W ?J,BMCDASH*10*X S J=J+10
.W !!,"each * represents ",BMCDASH," POV"_$S(BMCDASH>1:"'s",1:""),!
I $Y>(IOSL-4) D FF G:$D(BMCQUIT) PEXIT
PAPC W !!,"TOP ",BMCLNO," DIAGNOSTIC CATEGORIES =>",!
F I=1:1 Q:'$D(@G@(I))!($D(BMCQUIT)) D
.S BMCAPC=@G@(I)
.I I=1,BMCCHRT="B" D SETDASH(B)
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.I BMCCHRT="L" W !?3,I,".",?7,$P(^ICM(BMCAPC,0),U)," (",@B,")" Q
.W !,$E($P(^ICM(BMCAPC,0),U),1,25),?27,"|" S L=+(@B),D=L\BMCDASH F %=1:1:D W "*"
.W " ",+(@B)
.Q
I $Y>(IOSL-5) D FF G:$D(BMCQUIT) PEXIT
I BMCCHRT="B" D
.W ! S J=27 F X=1:1:10 W ?J,"|_________" S J=J+10
.W "|",!
.S J=27 F X=0:1:10 W ?J,BMCDASH*10*X S J=J+10
.W !!,"each * represents ",BMCDASH," POV"_$S(BMCDASH>1:"'s",1:""),!
PEXIT D DONE^BMCOSUT Q
;
SETDASH(BMCG) ;
NEW L,D,F,M
S L=+(@BMCG)
S M=$L(L),F=$E(L)+1,L=F F %=1:1:(M-1) S L=L_"0"
S:L<100 L=100
S BMCDASH=L\100
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="^",BMCQUIT=""
W:$D(IOF) @IOF
Q
;
BMCFYP ; IHS/PHXAO/TMJ - Print Routine for FY PO Cost Analysis ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
+2 ;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+3 ;
PRINT IF $DATA(IOF)
WRITE @IOF,?20,"***** FREQUENCY OF DIAGNOSIS REPORT *****",!!
COVPAGE ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !?20,"********** FREQUENCY OF DIAGNOSES REPORT **********"
+3 WRITE !!,"REPORT REQUESTED BY: ",$PIECE(^VA(200,DUZ,0),U)
+4 WRITE !!,"The following report contains a ",$SELECT(BMCPTVS="R":"PCC Visit",1:"Patient")," report based on the",!,"following criteria:",!
SHOW ;
+1 WRITE !,$SELECT(BMCPTVS="P":"PATIENT",1:"VISIT")," Selection Criteria"
+2 IF BMCTYPE="D"
WRITE !!?6,"Encounter Date range: ",BMCBDD," to ",BMCEDD,!
+3 IF BMCTYPE="S"
WRITE !!?6,"Search Template: ",$PIECE(^DIBT(BMCSEAT,0),U),!
+4 IF '$DATA(^BMCRTMP(BMCRPT,11))
WRITE !!?5,"ALL VISITS IN DATE RANGE SELECTED."
GOTO COUNT
+5 SET BMCI=0
FOR
SET BMCI=$ORDER(^BMCRTMP(BMCRPT,11,BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-5)
DO PAUSE^BMCRL01
WRITE @IOF
+7 WRITE !?6,$PIECE(^BMCTSORT(BMCI,0),U),": "
+8 KILL BMCQ
SET BMCY=0
SET C=0
KILL BMCQ
FOR
SET BMCY=$ORDER(^BMCRTMP(BMCRPT,11,BMCI,11,"B",BMCY))
SET C=C+1
IF C'=1&(BMCY'="")
WRITE " ; "
IF BMCY=""!($DATA(BMCQ))
QUIT
SET X=BMCY
IF $DATA(^BMCTSORT(BMCI,2))
XECUTE ^(2)
WRITE X
End DoDot:1
+9 KILL BMCQ
COUNT ;if COUNTING entries only
+1 IF $Y>(IOSL-5)
DO PAUSE^BMCRL01
IF $DATA(IOF)
WRITE @IOF
+2 IF $DATA(BMCALL)
WRITE !!?5,"ALL (Primary and Secondary) POV's included.",!
+3 IF $DATA(BMCPRIM)
WRITE !!?5,"PRIMARY POV's Only",!
+4 IF $DATA(BMCRTOT)
WRITE !!!,"Total COUNT of ",$SELECT(BMCPTVS="P":"Patients",1:"Visits"),": ",BMCRTOT
+5 DO PAUSE^BMCRL01
+6 IF $DATA(IOF)
WRITE @IOF
+7 KILL BMCQUIT
+8 WRITE !?20,"********** FREQUENCY OF DIAGNOSES REPORT **********"
PPOV 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 BMCQUIT=""
QUIT
+1 SET %="^XTMP(""BMCFY"",BMCJOB,BMCBT,"
SET A=%_"""POV"",BMCPOV)"
SET B=%_"""APC"",BMCAPC)"
SET C=%_"1)"
SET E=%_"2)"
SET F=%_"3)"
SET G=%_"4)"
+2 WRITE !!,"No. VISITs: ",BMCRTOT,?20,"No. POVs: ",BMCTOT,?40,"POV/VISIT ratio: ",$SELECT(BMCRTOT>0:$JUSTIFY((BMCTOT/BMCRTOT),1,2),1:0)," (min. std. > 1.6)"
+3 WRITE !!!,"TOP ",BMCLNO," POV's =>",!
+4 SET J=0
FOR I=1:1
IF '$DATA(@F@(I))!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+5 SET BMCPOV=@F@(I)
+6 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+7 IF I=1
IF BMCCHRT="B"
DO SETDASH(A)
+8 ;BMC 4.0*3 10.25.2007 IHS/OIT/FCJ CSV CHANGES NXT 4 LINES
+9 ;I BMCCHRT="L" W !?3,I,".",?7,$P(^ICD9(BMCPOV,0),U),?15,$P(^ICD9(BMCPOV,0),U,3)," (",@A,")" Q
+10 IF BMCCHRT="L"
WRITE !?3,I,".",?7,$PIECE($$ICDDX^ICDCODE(BMCPOV,0),U,2),?15,$PIECE($$ICDDX^ICDCODE(BMCPOV,0),U,4)," (",@A,")"
QUIT
+11 ;W !,$E($P(^ICD9(BMCPOV,0),U,3),1,17),?18," (",$P(^ICD9(BMCPOV,0),U),")",?27,"|" S L=+(@A),D=L\BMCDASH F %=1:1:D W "*"
+12 WRITE !,$EXTRACT($PIECE($$ICDDX^ICDCODE(BMCPOV,,,"I"),U,4),1,17),?18," (",$PIECE($$ICDDX^ICDCODE(BMCPOV,,,"I"),U,2),")",?27,"|"
SET L=+(@A)
SET D=L\BMCDASH
FOR %=1:1:D
WRITE "*"
+13 WRITE " ",+(@A)
+14 QUIT
End DoDot:1
+15 IF $DATA(BMCQUIT)
GOTO PEXIT
+16 IF $Y>(IOSL-5)
DO FF
IF $DATA(BMCQUIT)
GOTO PEXIT
+17 IF BMCCHRT="B"
Begin DoDot:1
+18 WRITE !
SET J=27
FOR X=1:1:10
WRITE ?J,"|_________"
SET J=J+10
+19 WRITE "|",!
+20 SET J=27
FOR X=0:1:10
WRITE ?J,BMCDASH*10*X
SET J=J+10
+21 WRITE !!,"each * represents ",BMCDASH," POV"_$SELECT(BMCDASH>1:"'s",1:""),!
End DoDot:1
+22 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
GOTO PEXIT
PAPC WRITE !!,"TOP ",BMCLNO," DIAGNOSTIC CATEGORIES =>",!
+1 FOR I=1:1
IF '$DATA(@G@(I))!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+2 SET BMCAPC=@G@(I)
+3 IF I=1
IF BMCCHRT="B"
DO SETDASH(B)
+4 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+5 IF BMCCHRT="L"
WRITE !?3,I,".",?7,$PIECE(^ICM(BMCAPC,0),U)," (",@B,")"
QUIT
+6 WRITE !,$EXTRACT($PIECE(^ICM(BMCAPC,0),U),1,25),?27,"|"
SET L=+(@B)
SET D=L\BMCDASH
FOR %=1:1:D
WRITE "*"
+7 WRITE " ",+(@B)
+8 QUIT
End DoDot:1
+9 IF $Y>(IOSL-5)
DO FF
IF $DATA(BMCQUIT)
GOTO PEXIT
+10 IF BMCCHRT="B"
Begin DoDot:1
+11 WRITE !
SET J=27
FOR X=1:1:10
WRITE ?J,"|_________"
SET J=J+10
+12 WRITE "|",!
+13 SET J=27
FOR X=0:1:10
WRITE ?J,BMCDASH*10*X
SET J=J+10
+14 WRITE !!,"each * represents ",BMCDASH," POV"_$SELECT(BMCDASH>1:"'s",1:""),!
End DoDot:1
PEXIT DO DONE^BMCOSUT
QUIT
+1 ;
SETDASH(BMCG) ;
+1 NEW L,D,F,M
+2 SET L=+(@BMCG)
+3 SET M=$LENGTH(L)
SET F=$EXTRACT(L)+1
SET L=F
FOR %=1:1:(M-1)
SET L=L_"0"
+4 IF L<100
SET L=100
+5 SET BMCDASH=L\100
+6 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="^"
SET BMCQUIT=""
+2 IF $DATA(IOF)
WRITE @IOF
+3 QUIT
+4 ;
