- 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
