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
