BMCTENP ; IHS/PHXAO/TMJ - cont. of top ten ;
;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;4.0*9 11.6.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
;
PRINT W:$D(IOF) @IOF,?15,"***** RCIS FREQUENCY OF DIAGNOSIS REPORT *****",!!
COVPAGE ;EP
W:$D(IOF) @IOF
W !?15,"********** RCIS FREQUENCY OF DIAGNOSES REPORT **********"
W !!,"REPORT REQUESTED BY: ",$P(^VA(200,DUZ,0),U)
W !!,"The following report contains a ",$S(BMCPTVS="V":"RCIS Referral",1:"Patient")," report based on the",!,"following criteria:",!
SHOW ;
W !,$S(BMCPTVS="P":"PATIENT",1:"REFERRAL")," Selection Criteria"
W:BMCTYPE="D" !!?6,"Referral Date range: ",BMCBDD," to ",BMCEDD,!
W:BMCTYPE="S" !!?6,"Search Template: ",$P(^DIBT(BMCSEAT,0),U),!
I '$D(^BMCRTMP(BMCRPT,11)) W !!?5,"ALL REFERRALS 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) DX's included.",!
I $D(BMCPRIM) W !!?5,"PRIMARY DX's Only",!
W:$D(BMCVTOT) !!!,"Total COUNT of ",$S(BMCPTVS="P":"Patients",1:"Referrals"),": ",BMCVTOT
D PAUSE^BMCRL01
W:$D(IOF) @IOF
K BMCQUIT
W !?15,"********** RCIS 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(""BMCTEN"",BMCJOB,BMCBT,",A=%_"""POV"",BMCPOV)",B=%_"""APC"",BMCAPC)",C=%_"1)",E=%_"2)",F=%_"3)",G=%_"4)"
W !!,"No. REFERRALs: ",BMCVTOT,?20,"No. DXs: ",BMCTOT,?40,"DX/REFERRAL ratio: ",$S(BMCVTOT>0:$J((BMCTOT/BMCVTOT),1,2),1:0)," (min. std. > 1.6)"
W !!!,"TOP ",BMCLNO," DX'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)
.;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES;4.0*9 11.6.2012 IHS.OIT.FCJ CHG FOR ICD-10
.;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
.I BMCCHRT="L" W !?3,I,".",?7,$P($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,2),?15,$E($P($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,4),1,50)," (",@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,0),U,4),1,17),?18," (",$P($$ICDDX^ICDCODE(BMCPOV,0),U,2),")",?27,"|" S L=+(@A),D=L\BMCDASH F %=1:1:D W "*"
.W !,$E($P($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,4),1,17),?18," (",$P($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,2),")",?27,"|" S L=+(@A),D=L\BMCDASH F %=1:1:D W "*"
.W " ",+(@A)
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)
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
BMCTENP ; IHS/PHXAO/TMJ - cont. of top ten ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
+2 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+3 ;4.0*9 11.6.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
+4 ;
PRINT IF $DATA(IOF)
WRITE @IOF,?15,"***** RCIS FREQUENCY OF DIAGNOSIS REPORT *****",!!
COVPAGE ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !?15,"********** RCIS FREQUENCY OF DIAGNOSES REPORT **********"
+3 WRITE !!,"REPORT REQUESTED BY: ",$PIECE(^VA(200,DUZ,0),U)
+4 WRITE !!,"The following report contains a ",$SELECT(BMCPTVS="V":"RCIS Referral",1:"Patient")," report based on the",!,"following criteria:",!
SHOW ;
+1 WRITE !,$SELECT(BMCPTVS="P":"PATIENT",1:"REFERRAL")," Selection Criteria"
+2 IF BMCTYPE="D"
WRITE !!?6,"Referral 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 REFERRALS 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) DX's included.",!
+3 IF $DATA(BMCPRIM)
WRITE !!?5,"PRIMARY DX's Only",!
+4 IF $DATA(BMCVTOT)
WRITE !!!,"Total COUNT of ",$SELECT(BMCPTVS="P":"Patients",1:"Referrals"),": ",BMCVTOT
+5 DO PAUSE^BMCRL01
+6 IF $DATA(IOF)
WRITE @IOF
+7 KILL BMCQUIT
+8 WRITE !?15,"********** RCIS 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(""BMCTEN"",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. REFERRALs: ",BMCVTOT,?20,"No. DXs: ",BMCTOT,?40,"DX/REFERRAL ratio: ",$SELECT(BMCVTOT>0:$JUSTIFY((BMCTOT/BMCVTOT),1,2),1:0)," (min. std. > 1.6)"
+3 WRITE !!!,"TOP ",BMCLNO," DX'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 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES;4.0*9 11.6.2012 IHS.OIT.FCJ CHG FOR ICD-10
+9 ;I BMCCHRT="L" W !?3,I,".",?7,$P(^ICD9(BMCPOV,0),U),?15,$P(^ICD9(BMCPOV,0),U,3)," (",@A,")" Q
+10 ;I BMCCHRT="L" W !?3,I,".",?7,$P($$ICDDX^ICDCODE(BMCPOV,0),U,2),?15,$P($$ICDDX^ICDCODE(BMCPOV,0),U,4)," (",@A,")" Q
+11 IF BMCCHRT="L"
WRITE !?3,I,".",?7,$PIECE($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,2),?15,$EXTRACT($PIECE($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,4),1,50)," (",@A,")"
QUIT
+12 ;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 "*"
+13 ;W !,$E($P($$ICDDX^ICDCODE(BMCPOV,0),U,4),1,17),?18," (",$P($$ICDDX^ICDCODE(BMCPOV,0),U,2),")",?27,"|" S L=+(@A),D=L\BMCDASH F %=1:1:D W "*"
+14 WRITE !,$EXTRACT($PIECE($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,4),1,17),?18," (",$PIECE($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,2),")",?27,"|"
SET L=+(@A)
SET D=L\BMCDASH
FOR %=1:1:D
WRITE "*"
+15 WRITE " ",+(@A)
End DoDot:1
+16 IF $DATA(BMCQUIT)
GOTO PEXIT
+17 IF $Y>(IOSL-5)
DO FF
IF $DATA(BMCQUIT)
GOTO PEXIT
+18 IF BMCCHRT="B"
Begin DoDot:1
+19 WRITE !
SET J=27
FOR X=1:1:10
WRITE ?J,"|_________"
SET J=J+10
+20 WRITE "|",!
+21 SET J=27
FOR X=0:1:10
WRITE ?J,BMCDASH*10*X
SET J=J+10
+22 WRITE !!,"each * represents ",BMCDASH," POV"_$SELECT(BMCDASH>1:"'s",1:""),!
End DoDot:1
+23 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)
End DoDot:1
+8 IF $Y>(IOSL-5)
DO FF
IF $DATA(BMCQUIT)
GOTO PEXIT
+9 IF BMCCHRT="B"
Begin DoDot:1
+10 WRITE !
SET J=27
FOR X=1:1:10
WRITE ?J,"|_________"
SET J=J+10
+11 WRITE "|",!
+12 SET J=27
FOR X=0:1:10
WRITE ?J,BMCDASH*10*X
SET J=J+10
+13 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
