- BMCTEN1 ; IHS/PHXAO/TMJ - TOP TEN POVS ;
- ;;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
- ;
- VISIT ;
- S BMCJOB=$J,BMCBT=$H
- K ^XTMP("BMCTEN",BMCJOB,BMCBT)
- D XTMP^BMCOSUT("BMCTEN","RCIS TOP TEN DX REPORT")
- S %="^XTMP(""BMCTEN"",BMCJOB,BMCBT,",BMCA=%_"""POV"",BMCPOV)",BMCB=%_"""APC"",BMCAPC)",BMCC=%_"1)",BMCE=%_"2)",BMCF=%_"3)",BMCG=%_"4)",BMCTOT=0,BMCVTOT=0,BMCLINO=0
- S BMCBD=BMCBD-.00001
- F BMCDATE=BMCBD:0 S BMCDATE=$O(^BMCREF("B",BMCDATE)) Q:'BMCDATE Q:(BMCDATE\1)>BMCED F BMCVIEN=0:0 S BMCVIEN=$O(^BMCREF("B",BMCDATE,BMCVIEN)) Q:'BMCVIEN I $D(^BMCREF(BMCVIEN,0)),$D(^BMCDX("AD",BMCVIEN)) D CK
- D SET
- S BMCET=$H
- Q
- ;
- CK ;
- S BMCRREC=^BMCREF(BMCVIEN,0),DFN=$P(BMCRREC,U,3)
- Q:$P($G(^BMCREF(BMCVIEN,1)),U)'="" ;IHS/OIT/FCJ SEC REF NOT INCLUDED
- S BMCREF=BMCVIEN D SCREENS ;IHS/OIT/FCJ SCREENS USE BMCREF AS REF IEN
- Q:$D(BMCSKIP)
- POV S BMCPOVN="",BMCVTOT=BMCVTOT+1,BMCCC=0
- F S BMCPOVN=$O(^BMCDX("AD",BMCVIEN,BMCPOVN)) Q:'BMCPOVN Q:'$D(^BMCDX(BMCPOVN,0)) S BMCPOV=+^(0),BMCCC=BMCCC+1,BMCPREC=^(0) D POVX
- Q
- ;
- POVX I '$D(^ICD9($P(BMCPREC,U))) Q
- I $D(BMCPRIM),$P(BMCPREC,U,5)'="P" Q
- I $D(BMCPRIM),BMCCC>1 Q
- S BMCTOT=BMCTOT+1
- S BMCDOS=$$AVDOS^BMCRLU(BMCVIEN,"N") ;BMC*4.0*9
- ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES;4.0*9 11.6.2012 IHS.OIT.FCJ CHG FOR ICD-10
- ;S %=$P(^ICD9(BMCPOV,0),U,5) K BMCAPC I % S BMCAPC=%
- ;S %=$P($$ICDDX^ICDCODE(BMCPOV,0),U,6) K BMCAPC I % S BMCAPC=%
- S %=$P($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,6) K BMCAPC I % S BMCAPC=%
- F X=BMCA,BMCB D UTL
- Q
- ;
- SCREENS ;
- K BMCSKIP
- S BMCI=0 F S BMCI=$O(^BMCRTMP(BMCRPT,11,BMCI)) Q:BMCI'=+BMCI!($D(BMCSKIP)) D
- .I '$P(^BMCTSORT(BMCI,0),U,8) D SINGLE Q
- .D MULT
- .Q
- Q
- SINGLE ;
- K X,BMCSPEC S X="",BMCX=0
- X:$D(^BMCTSORT(BMCI,1)) ^(1)
- I X="" S BMCSKIP="" Q
- I '$D(BMCSPEC),'$D(^BMCRTMP(BMCRPT,11,BMCI,11,"B",X)) S BMCSKIP="" Q
- Q
- MULT ;
- K BMCFOUN,BMCSKIP,BMCSPEC,X S BMCX=0,X=""
- X:$D(^BMCTSORT(BMCI,1)) ^(1)
- I $O(X(""))="" S BMCSKIP="" Q
- I '$D(BMCSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^BMCRTMP(BMCRPT,11,BMCI,11,"B",Y)) S BMCFOUN="" Q
- I $D(BMCSPEC),$D(X) S BMCFOUN=1 Q
- S:'$D(BMCFOUN) BMCSKIP=""
- Q
- UTL I X=BMCB,'$D(BMCAPC) Q
- I '$D(@X) S @X=0
- S %=@X,%=%+1,@X=%
- Q
- ;
- SET F BMCPOV=0:0 S BMCPOV=$O(@BMCA) Q:'BMCPOV S %=^(BMCPOV),@BMCC@(9999999-%,BMCPOV)=""
- F BMCAPC=0:0 S BMCAPC=$O(@BMCB) Q:'BMCAPC S %=^(BMCAPC),@BMCE@(9999999-%,BMCAPC)=""
- S1 S (X,I)=0 F S X=$O(@BMCC@(X)) Q:'X F Y=0:0 S Y=$O(@BMCC@(X,Y)) Q:'Y S I=I+1,@BMCF@(I)=Y I I=BMCLNO G S2
- S2 S (X,I)=0 F S X=$O(@BMCE@(X)) Q:'X F Y=0:0 S Y=$O(@BMCE@(X,Y)) Q:'Y S I=I+1,@BMCG@(I)=Y I I=BMCLNO G S3
- S3 Q
- ;
- ;
- FF I IOST["P-" W:$D(IOF) @IOF Q
- 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 X="^"
- W:$D(IOF) @IOF
- Q
- ;
- EXIT ;EP
- K A,B,C,D,E,F,G,H,I,J,K,X,Y,Z,%
- K BMCBD,BMCED,BMCDOB1,BMCDOB2,BMCSEX,A,B,C,X,Y,Z,%,BMCFAC,BMCJOB,BMCLNO,E,F,G,ZTIO,ZTQUEUED,BMCCLN,BMCTYPE,BMCSC,BMCC,BMCPREC,BMCSD,BMCET,BMCSEAT,BMCCHRT,BMCLHDR,BMCDASH,BMCA,BMCB,BMCC,BMCD,BMCE,BMCF,BMCG
- K BMCQUIT,BMCAPC,BMCDATE,BMCPOV,BMCVIEN,BMCNOCK,BMCTOT,BMCPROV,BMCVTOT,BMCLINO,L,I,BMCCMA,BMCPOVN,BMCV,BMCTYPP,BMCSCP,BMCPRIM,BMCALL
- K BMCANS,AMQQTAX,BMCBDD,BMCCNT,BMCCRIT,BMCCTYP,BMCCUT,BMCDISP,BMCEDD,BMCHIGH,BMCI,BMCNCAN,BMCPTVS,BMCRPT,BMCSEL,BMCSKIP,BMCTCW,BMCTEXT,BMCVAR,BMCVIEN,BMCRREC,DFN,BMCX,BMCY,BMCCC
- K BMCBT,BMCREF,BMCTYPR
- Q
- BMCTEN1 ; IHS/PHXAO/TMJ - TOP TEN POVS ;
- +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 ;
- VISIT ;
- +1 SET BMCJOB=$JOB
- SET BMCBT=$HOROLOG
- +2 KILL ^XTMP("BMCTEN",BMCJOB,BMCBT)
- +3 DO XTMP^BMCOSUT("BMCTEN","RCIS TOP TEN DX REPORT")
- +4 SET %="^XTMP(""BMCTEN"",BMCJOB,BMCBT,"
- SET BMCA=%_"""POV"",BMCPOV)"
- SET BMCB=%_"""APC"",BMCAPC)"
- SET BMCC=%_"1)"
- SET BMCE=%_"2)"
- SET BMCF=%_"3)"
- SET BMCG=%_"4)"
- SET BMCTOT=0
- SET BMCVTOT=0
- SET BMCLINO=0
- +5 SET BMCBD=BMCBD-.00001
- +6 FOR BMCDATE=BMCBD:0
- SET BMCDATE=$ORDER(^BMCREF("B",BMCDATE))
- IF 'BMCDATE
- QUIT
- IF (BMCDATE\1)>BMCED
- QUIT
- FOR BMCVIEN=0:0
- SET BMCVIEN=$ORDER(^BMCREF("B",BMCDATE,BMCVIEN))
- IF 'BMCVIEN
- QUIT
- IF $DATA(^BMCREF(BMCVIEN,0))
- IF $DATA(^BMCDX("AD",BMCVIEN))
- DO CK
- +7 DO SET
- +8 SET BMCET=$HOROLOG
- +9 QUIT
- +10 ;
- CK ;
- +1 SET BMCRREC=^BMCREF(BMCVIEN,0)
- SET DFN=$PIECE(BMCRREC,U,3)
- +2 ;IHS/OIT/FCJ SEC REF NOT INCLUDED
- IF $PIECE($GET(^BMCREF(BMCVIEN,1)),U)'=""
- QUIT
- +3 ;IHS/OIT/FCJ SCREENS USE BMCREF AS REF IEN
- SET BMCREF=BMCVIEN
- DO SCREENS
- +4 IF $DATA(BMCSKIP)
- QUIT
- POV SET BMCPOVN=""
- SET BMCVTOT=BMCVTOT+1
- SET BMCCC=0
- +1 FOR
- SET BMCPOVN=$ORDER(^BMCDX("AD",BMCVIEN,BMCPOVN))
- IF 'BMCPOVN
- QUIT
- IF '$DATA(^BMCDX(BMCPOVN,0))
- QUIT
- SET BMCPOV=+^(0)
- SET BMCCC=BMCCC+1
- SET BMCPREC=^(0)
- DO POVX
- +2 QUIT
- +3 ;
- POVX IF '$DATA(^ICD9($PIECE(BMCPREC,U)))
- QUIT
- +1 IF $DATA(BMCPRIM)
- IF $PIECE(BMCPREC,U,5)'="P"
- QUIT
- +2 IF $DATA(BMCPRIM)
- IF BMCCC>1
- QUIT
- +3 SET BMCTOT=BMCTOT+1
- +4 ;BMC*4.0*9
- SET BMCDOS=$$AVDOS^BMCRLU(BMCVIEN,"N")
- +5 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES;4.0*9 11.6.2012 IHS.OIT.FCJ CHG FOR ICD-10
- +6 ;S %=$P(^ICD9(BMCPOV,0),U,5) K BMCAPC I % S BMCAPC=%
- +7 ;S %=$P($$ICDDX^ICDCODE(BMCPOV,0),U,6) K BMCAPC I % S BMCAPC=%
- +8 SET %=$PIECE($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,6)
- KILL BMCAPC
- IF %
- SET BMCAPC=%
- +9 FOR X=BMCA,BMCB
- DO UTL
- +10 QUIT
- +11 ;
- SCREENS ;
- +1 KILL BMCSKIP
- +2 SET BMCI=0
- FOR
- SET BMCI=$ORDER(^BMCRTMP(BMCRPT,11,BMCI))
- IF BMCI'=+BMCI!($DATA(BMCSKIP))
- QUIT
- Begin DoDot:1
- +3 IF '$PIECE(^BMCTSORT(BMCI,0),U,8)
- DO SINGLE
- QUIT
- +4 DO MULT
- +5 QUIT
- End DoDot:1
- +6 QUIT
- SINGLE ;
- +1 KILL X,BMCSPEC
- SET X=""
- SET BMCX=0
- +2 IF $DATA(^BMCTSORT(BMCI,1))
- XECUTE ^(1)
- +3 IF X=""
- SET BMCSKIP=""
- QUIT
- +4 IF '$DATA(BMCSPEC)
- IF '$DATA(^BMCRTMP(BMCRPT,11,BMCI,11,"B",X))
- SET BMCSKIP=""
- QUIT
- +5 QUIT
- MULT ;
- +1 KILL BMCFOUN,BMCSKIP,BMCSPEC,X
- SET BMCX=0
- SET X=""
- +2 IF $DATA(^BMCTSORT(BMCI,1))
- XECUTE ^(1)
- +3 IF $ORDER(X(""))=""
- SET BMCSKIP=""
- QUIT
- +4 IF '$DATA(BMCSPEC)
- SET Y=""
- FOR
- SET Y=$ORDER(X(Y))
- IF Y=""
- QUIT
- IF $DATA(^BMCRTMP(BMCRPT,11,BMCI,11,"B",Y))
- SET BMCFOUN=""
- QUIT
- +5 IF $DATA(BMCSPEC)
- IF $DATA(X)
- SET BMCFOUN=1
- QUIT
- +6 IF '$DATA(BMCFOUN)
- SET BMCSKIP=""
- +7 QUIT
- UTL IF X=BMCB
- IF '$DATA(BMCAPC)
- QUIT
- +1 IF '$DATA(@X)
- SET @X=0
- +2 SET %=@X
- SET %=%+1
- SET @X=%
- +3 QUIT
- +4 ;
- SET FOR BMCPOV=0:0
- SET BMCPOV=$ORDER(@BMCA)
- IF 'BMCPOV
- QUIT
- SET %=^(BMCPOV)
- SET @BMCC@(9999999-%,BMCPOV)=""
- +1 FOR BMCAPC=0:0
- SET BMCAPC=$ORDER(@BMCB)
- IF 'BMCAPC
- QUIT
- SET %=^(BMCAPC)
- SET @BMCE@(9999999-%,BMCAPC)=""
- S1 SET (X,I)=0
- FOR
- SET X=$ORDER(@BMCC@(X))
- IF 'X
- QUIT
- FOR Y=0:0
- SET Y=$ORDER(@BMCC@(X,Y))
- IF 'Y
- QUIT
- SET I=I+1
- SET @BMCF@(I)=Y
- IF I=BMCLNO
- GOTO S2
- S2 SET (X,I)=0
- FOR
- SET X=$ORDER(@BMCE@(X))
- IF 'X
- QUIT
- FOR Y=0:0
- SET Y=$ORDER(@BMCE@(X,Y))
- IF 'Y
- QUIT
- SET I=I+1
- SET @BMCG@(I)=Y
- IF I=BMCLNO
- GOTO S3
- S3 QUIT
- +1 ;
- +2 ;
- FF IF IOST["P-"
- IF $DATA(IOF)
- WRITE @IOF
- QUIT
- +1 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 X="^"
- +2 IF $DATA(IOF)
- WRITE @IOF
- +3 QUIT
- +4 ;
- EXIT ;EP
- +1 KILL A,B,C,D,E,F,G,H,I,J,K,X,Y,Z,%
- +2 KILL BMCBD,BMCED,BMCDOB1,BMCDOB2,BMCSEX,A,B,C,X,Y,Z,%,BMCFAC,BMCJOB,BMCLNO,E,F,G,ZTIO,ZTQUEUED,BMCCLN,BMCTYPE,BMCSC,BMCC,BMCPREC,BMCSD,BMCET,BMCSEAT,BMCCHRT,BMCLHDR,BMCDASH,BMCA,BMCB,BMCC,BMCD,BMCE,BMCF,BMCG
- +3 KILL BMCQUIT,BMCAPC,BMCDATE,BMCPOV,BMCVIEN,BMCNOCK,BMCTOT,BMCPROV,BMCVTOT,BMCLINO,L,I,BMCCMA,BMCPOVN,BMCV,BMCTYPP,BMCSCP,BMCPRIM,BMCALL
- +4 KILL BMCANS,AMQQTAX,BMCBDD,BMCCNT,BMCCRIT,BMCCTYP,BMCCUT,BMCDISP,BMCEDD,BMCHIGH,BMCI,BMCNCAN,BMCPTVS,BMCRPT,BMCSEL,BMCSKIP,BMCTCW,BMCTEXT,BMCVAR,BMCVIEN,BMCRREC,DFN,BMCX,BMCY,BMCCC
- +5 KILL BMCBT,BMCREF,BMCTYPR
- +6 QUIT
