Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCTEN1

BMCTEN1.m

Go to the documentation of this file.
  1. BMCTEN1 ; IHS/PHXAO/TMJ - TOP TEN POVS ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
  1. ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
  1. ;4.0*9 11.6.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
  1. ;
  1. VISIT ;
  1. S BMCJOB=$J,BMCBT=$H
  1. K ^XTMP("BMCTEN",BMCJOB,BMCBT)
  1. D XTMP^BMCOSUT("BMCTEN","RCIS TOP TEN DX REPORT")
  1. 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
  1. S BMCBD=BMCBD-.00001
  1. 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
  1. D SET
  1. S BMCET=$H
  1. Q
  1. ;
  1. CK ;
  1. S BMCRREC=^BMCREF(BMCVIEN,0),DFN=$P(BMCRREC,U,3)
  1. Q:$P($G(^BMCREF(BMCVIEN,1)),U)'="" ;IHS/OIT/FCJ SEC REF NOT INCLUDED
  1. S BMCREF=BMCVIEN D SCREENS ;IHS/OIT/FCJ SCREENS USE BMCREF AS REF IEN
  1. Q:$D(BMCSKIP)
  1. POV S BMCPOVN="",BMCVTOT=BMCVTOT+1,BMCCC=0
  1. 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
  1. Q
  1. ;
  1. POVX I '$D(^ICD9($P(BMCPREC,U))) Q
  1. I $D(BMCPRIM),$P(BMCPREC,U,5)'="P" Q
  1. I $D(BMCPRIM),BMCCC>1 Q
  1. S BMCTOT=BMCTOT+1
  1. S BMCDOS=$$AVDOS^BMCRLU(BMCVIEN,"N") ;BMC*4.0*9
  1. ;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
  1. ;S %=$P(^ICD9(BMCPOV,0),U,5) K BMCAPC I % S BMCAPC=%
  1. ;S %=$P($$ICDDX^ICDCODE(BMCPOV,0),U,6) K BMCAPC I % S BMCAPC=%
  1. S %=$P($$ICDDX^ICDEX(BMCPOV,BMCDOS,,"I"),U,6) K BMCAPC I % S BMCAPC=%
  1. F X=BMCA,BMCB D UTL
  1. Q
  1. ;
  1. SCREENS ;
  1. K BMCSKIP
  1. S BMCI=0 F S BMCI=$O(^BMCRTMP(BMCRPT,11,BMCI)) Q:BMCI'=+BMCI!($D(BMCSKIP)) D
  1. .I '$P(^BMCTSORT(BMCI,0),U,8) D SINGLE Q
  1. .D MULT
  1. .Q
  1. Q
  1. SINGLE ;
  1. K X,BMCSPEC S X="",BMCX=0
  1. X:$D(^BMCTSORT(BMCI,1)) ^(1)
  1. I X="" S BMCSKIP="" Q
  1. I '$D(BMCSPEC),'$D(^BMCRTMP(BMCRPT,11,BMCI,11,"B",X)) S BMCSKIP="" Q
  1. Q
  1. MULT ;
  1. K BMCFOUN,BMCSKIP,BMCSPEC,X S BMCX=0,X=""
  1. X:$D(^BMCTSORT(BMCI,1)) ^(1)
  1. I $O(X(""))="" S BMCSKIP="" Q
  1. 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
  1. I $D(BMCSPEC),$D(X) S BMCFOUN=1 Q
  1. S:'$D(BMCFOUN) BMCSKIP=""
  1. Q
  1. UTL I X=BMCB,'$D(BMCAPC) Q
  1. I '$D(@X) S @X=0
  1. S %=@X,%=%+1,@X=%
  1. Q
  1. ;
  1. SET F BMCPOV=0:0 S BMCPOV=$O(@BMCA) Q:'BMCPOV S %=^(BMCPOV),@BMCC@(9999999-%,BMCPOV)=""
  1. F BMCAPC=0:0 S BMCAPC=$O(@BMCB) Q:'BMCAPC S %=^(BMCAPC),@BMCE@(9999999-%,BMCAPC)=""
  1. 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
  1. 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
  1. S3 Q
  1. ;
  1. ;
  1. FF I IOST["P-" W:$D(IOF) @IOF Q
  1. 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="^"
  1. W:$D(IOF) @IOF
  1. Q
  1. ;
  1. EXIT ;EP
  1. K A,B,C,D,E,F,G,H,I,J,K,X,Y,Z,%
  1. 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
  1. K BMCQUIT,BMCAPC,BMCDATE,BMCPOV,BMCVIEN,BMCNOCK,BMCTOT,BMCPROV,BMCVTOT,BMCLINO,L,I,BMCCMA,BMCPOVN,BMCV,BMCTYPP,BMCSCP,BMCPRIM,BMCALL
  1. 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
  1. K BMCBT,BMCREF,BMCTYPR
  1. Q