BMCMOD1 ;IHS/OIT/FCJ - MODIFY A REFERRAL 2 OF 2;
;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;
DISPDX ;ENTRY POINT
I '$O(^BMCDX("AD",BMCRIEN,0)) S BMCNONE=1 Q
W !
S (X,BMCC)=0 F S X=$O(^BMCDX("AD",BMCRIEN,X)) Q:X'=+X S BMCC=BMCC+1,BMCRDX(BMCC)=X D
.;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES;BMC*4.0*9 CHNG CSV TO ICD10 CALLS
.;W !?2,BMCC,") ",$P(^ICD9($P(^BMCDX(X,0),U),0),U)
.;W !?2,BMCC,") ",$P($$ICDDX^ICDCODE($P(^BMCDX(X,0),U),0),U,2)
.;W ?12,$S($P(^BMCDX(X,0),U,6):$P(^AUTNPOV($P(^BMCDX(X,0),U,6),0),U,1,50),1:$E($P(^ICD9($P(^BMCDX(X,0),U),0),U,3),1,50)),?65,"(",$S($P(^BMCDX(X,0),U,4)="P":"Provisional",$P(^BMCDX(X,0),U,4)="F":"Final",1:"??"),")"
.;W ?12,$S($P(^BMCDX(X,0),U,6):$P(^AUTNPOV($P(^BMCDX(X,0),U,6),0),U,1,50),1:$E($P($$ICDDX^ICDCODE($P(^BMCDX(X,0),U),0),U,4),1,50)),?65,"(",$S($P(^BMCDX(X,0),U,4)="P":"Provisional",$P(^BMCDX(X,0),U,4)="F":"Final",1:"??"),")"
.W !?2,BMCC,") ",$P($$ICDDX^ICDEX($P(^BMCDX(X,0),U),BMCDOS,,"I"),U,2)
.W ?15,$S($P(^BMCDX(X,0),U,6):$P(^AUTNPOV($P(^BMCDX(X,0),U,6),0),U,1,50),1:$$SD^ICDEX(80,$P(^BMCDX(X,0),U),BMCDOS,,50)),?65,"(",$S($P(^BMCDX(X,0),U,4)="P":"Provisional",$P(^BMCDX(X,0),U,4)="F":"Final",1:"??"),")"
Q
;
DISPPROC ;ENTRY POINT
I '$O(^BMCPX("AD",BMCRIEN,0)) S BMCNONE=1 Q
W !
S (X,BMCC)=0 F S X=$O(^BMCPX("AD",BMCRIEN,X)) Q:X'=+X S BMCC=BMCC+1,BMCRDX(BMCC)=X D
.;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES
.;W !?2,BMCC,") ",$P(^ICPT($P(^BMCPX(X,0),U),0),U)
.W !?2,BMCC,") ",$P($$CPT^ICPTCOD($P(^BMCPX(X,0),U),0),U,2)
.;W ?12,$S($P(^BMCPX(X,0),U,6):$P(^AUTNPOV($P(^BMCPX(X,0),U,6),0),U,1,50),1:$E($P(^ICPT($P(^BMCPX(X,0),U),0),U,2),1,50)),?65,"(",$S($P(^BMCPX(X,0),U,4)="P":"Provisional",$P(^BMCPX(X,0),U,4)="F":"Final",1:"??"),")"
.W ?12,$S($P(^BMCPX(X,0),U,6):$P(^AUTNPOV($P(^BMCPX(X,0),U,6),0),U,1,50),1:$E($P($$CPT^ICPTCOD($P(^BMCPX(X,0),U),0),U,3),1,50)),?65,"(",$S($P(^BMCPX(X,0),U,4)="P":"Provisional",$P(^BMCPX(X,0),U,4)="F":"Final",1:"??"),")"
Q
;
DISPCOM ;EP;CASE COMMENT
;IHS/ITSC/FCJ TEST FOR COMMENT TYPE
S (BMCTMP,BMCTMP1)=0 I $D(^BMCCOM("AD",BMCRIEN)) D
.F S BMCTMP=$O(^BMCCOM("AD",BMCRIEN,BMCTMP)) Q:BMCTMP'?1N.N D Q:BMCTMP1=1
..I $P(^BMCCOM(BMCTMP,0),U,5)=BMCCTYP S BMCTMP1=1
I BMCTMP1=0 S BMCNONE=1 Q
W !
S (BMCX,BMCC)=0 F S BMCX=$O(^BMCCOM("AD",BMCRIEN,BMCX)) Q:BMCX'=+BMCX D
.Q:$P(^BMCCOM(BMCX,0),U,5)'=BMCCTYP
.S BMCC=BMCC+1,BMCRDX(BMCC)=BMCX
.W !?2,BMCC,") " S Y=$P(^BMCCOM(BMCX,0),U) D DD^%DT W Y
.W ?25,$P(^VA(200,$P(^BMCCOM(BMCX,0),U,4),0),U) ;4.0 IHS/OIT/FCJ PRT REVR
.K ^UTILITY($J,"W") S DIWL=1,DIWR=60
.S BMCY=0 F S BMCY=$O(^BMCCOM(BMCX,1,BMCY)) Q:BMCY'=+BMCY D
..S DIWL=1,DIWR=60
..S X=^BMCCOM(BMCX,1,BMCY,0) D ^DIWP
.S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z W !?10,^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W")
Q
;
ADDDX ;EP-BMCMOD;BMC*4.0*9-ADD DX CALL
I BMCDOS<$$IMPDATE^LEXU("10D") S (BMCICD,BMCICD1)="ICD"
E S (BMCICD,BMCICD1)="10D"
S BMCLEX=+($$CSYS^LEXU(BMCICD)) ;Get Coding System
S BMCQ=0 F D Q:BMCQ
. D CONFIG^LEXSET(BMCICD,BMCICD1,BMCDOS)
. W !! S DIC("A")="Enter ICD DX code: " K X D ^LEXA1
. I +Y<0 S BMCQ=1 Q
. S X=$P($$CODEN^ICDEX($G(Y(+BMCLEX)),80),"~")
. I +X<1 W !!,"INVALID CODE cannot add." Q
. K DIC,Y
. S DIC(0)="L",DIC="^BMCDX(",DLAYGO=90001.01 D FILE^DICN
. I +Y<0 W !,"Unable to add DX code." S BMCQ=1 Q
. S DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04;.05;.06"
. S DIE="^BMCDX("
. D DIE^BMCFMC
. K BMCLOOK
. W !
K DLAYGO,BMCDX,DIC,DIE,DR,DA,X,LEXQ,LEXVDT,ICDV,BMCLEX
Q
;
ADDPX ;EP-BMCMOD;BMC*4.0*9-ADD PX CALL
S DIC="^ICPT(",DIC(0)="AMEQ",DIC("A")="Enter RCIS CPT Procedure code: "
S DIC("S")="I '$P(^(0),U,4)"
D ^DIC
I Y=-1 S BMCQ=1 K DIC Q
S DIC(0)="L",DIC="^BMCPX(",DLAYGO=90001.02 D FILE^DICN
I +Y<0 W !,"Unable to add CPT Procedure code." S BMCQ=1 Q
S DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"
S DIE="^BMCPX("
D DIE^BMCFMC
K DLAYGO,BMCDX,DIC,DIE,DR,DA,X
Q
;
BMCMOD1 ;IHS/OIT/FCJ - MODIFY A REFERRAL 2 OF 2;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
+2 ;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+3 ;
DISPDX ;ENTRY POINT
+1 IF '$ORDER(^BMCDX("AD",BMCRIEN,0))
SET BMCNONE=1
QUIT
+2 WRITE !
+3 SET (X,BMCC)=0
FOR
SET X=$ORDER(^BMCDX("AD",BMCRIEN,X))
IF X'=+X
QUIT
SET BMCC=BMCC+1
SET BMCRDX(BMCC)=X
Begin DoDot:1
+4 ;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES;BMC*4.0*9 CHNG CSV TO ICD10 CALLS
+5 ;W !?2,BMCC,") ",$P(^ICD9($P(^BMCDX(X,0),U),0),U)
+6 ;W !?2,BMCC,") ",$P($$ICDDX^ICDCODE($P(^BMCDX(X,0),U),0),U,2)
+7 ;W ?12,$S($P(^BMCDX(X,0),U,6):$P(^AUTNPOV($P(^BMCDX(X,0),U,6),0),U,1,50),1:$E($P(^ICD9($P(^BMCDX(X,0),U),0),U,3),1,50)),?65,"(",$S($P(^BMCDX(X,0),U,4)="P":"Provisional",$P(^BMCDX(X,0),U,4)="F":"Final",1:"??"),")"
+8 ;W ?12,$S($P(^BMCDX(X,0),U,6):$P(^AUTNPOV($P(^BMCDX(X,0),U,6),0),U,1,50),1:$E($P($$ICDDX^ICDCODE($P(^BMCDX(X,0),U),0),U,4),1,50)),?65,"(",$S($P(^BMCDX(X,0),U,4)="P":"Provisional",$P(^BMCDX(X,0),U,4)="F":"Final",1:"??"),")"
+9 WRITE !?2,BMCC,") ",$PIECE($$ICDDX^ICDEX($PIECE(^BMCDX(X,0),U),BMCDOS,,"I"),U,2)
+10 WRITE ?15,$SELECT($PIECE(^BMCDX(X,0),U,6):$PIECE(^AUTNPOV($PIECE(^BMCDX(X,0),U,6),0),U,1,50),1:$$SD^ICDEX(80,$PIECE(^BMCDX(X,0),U),BMCDOS,,50)),?65,"(",$SELECT($PIECE(^BMCDX(X,0),U,4)="P":"Provisional",$PIECE(^BMCDX(X,0),U,4)="F":"Final
",1:"??"),")"
End DoDot:1
+11 QUIT
+12 ;
DISPPROC ;ENTRY POINT
+1 IF '$ORDER(^BMCPX("AD",BMCRIEN,0))
SET BMCNONE=1
QUIT
+2 WRITE !
+3 SET (X,BMCC)=0
FOR
SET X=$ORDER(^BMCPX("AD",BMCRIEN,X))
IF X'=+X
QUIT
SET BMCC=BMCC+1
SET BMCRDX(BMCC)=X
Begin DoDot:1
+4 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES
+5 ;W !?2,BMCC,") ",$P(^ICPT($P(^BMCPX(X,0),U),0),U)
+6 WRITE !?2,BMCC,") ",$PIECE($$CPT^ICPTCOD($PIECE(^BMCPX(X,0),U),0),U,2)
+7 ;W ?12,$S($P(^BMCPX(X,0),U,6):$P(^AUTNPOV($P(^BMCPX(X,0),U,6),0),U,1,50),1:$E($P(^ICPT($P(^BMCPX(X,0),U),0),U,2),1,50)),?65,"(",$S($P(^BMCPX(X,0),U,4)="P":"Provisional",$P(^BMCPX(X,0),U,4)="F":"Final",1:"??"),")"
+8 WRITE ?12,$SELECT($PIECE(^BMCPX(X,0),U,6):$PIECE(^AUTNPOV($PIECE(^BMCPX(X,0),U,6),0),U,1,50),1:$EXTRACT($PIECE($$CPT^ICPTCOD($PIECE(^BMCPX(X,0),U),0),U,3),1,50)),?65,"(",...
... $SELECT($PIECE(^BMCPX(X,0),U,4)="P":"Provisional",$PIECE(^BMCPX(X,0),U,4)="F":"Final",1:"??"),")"
End DoDot:1
+9 QUIT
+10 ;
DISPCOM ;EP;CASE COMMENT
+1 ;IHS/ITSC/FCJ TEST FOR COMMENT TYPE
+2 SET (BMCTMP,BMCTMP1)=0
IF $DATA(^BMCCOM("AD",BMCRIEN))
Begin DoDot:1
+3 FOR
SET BMCTMP=$ORDER(^BMCCOM("AD",BMCRIEN,BMCTMP))
IF BMCTMP'?1N.N
QUIT
Begin DoDot:2
+4 IF $PIECE(^BMCCOM(BMCTMP,0),U,5)=BMCCTYP
SET BMCTMP1=1
End DoDot:2
IF BMCTMP1=1
QUIT
End DoDot:1
+5 IF BMCTMP1=0
SET BMCNONE=1
QUIT
+6 WRITE !
+7 SET (BMCX,BMCC)=0
FOR
SET BMCX=$ORDER(^BMCCOM("AD",BMCRIEN,BMCX))
IF BMCX'=+BMCX
QUIT
Begin DoDot:1
+8 IF $PIECE(^BMCCOM(BMCX,0),U,5)'=BMCCTYP
QUIT
+9 SET BMCC=BMCC+1
SET BMCRDX(BMCC)=BMCX
+10 WRITE !?2,BMCC,") "
SET Y=$PIECE(^BMCCOM(BMCX,0),U)
DO DD^%DT
WRITE Y
+11 ;4.0 IHS/OIT/FCJ PRT REVR
WRITE ?25,$PIECE(^VA(200,$PIECE(^BMCCOM(BMCX,0),U,4),0),U)
+12 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=60
+13 SET BMCY=0
FOR
SET BMCY=$ORDER(^BMCCOM(BMCX,1,BMCY))
IF BMCY'=+BMCY
QUIT
Begin DoDot:2
+14 SET DIWL=1
SET DIWR=60
+15 SET X=^BMCCOM(BMCX,1,BMCY,0)
DO ^DIWP
End DoDot:2
+16 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
WRITE !?10,^UTILITY($JOB,"W",DIWL,Z,0)
End DoDot:1
+17 KILL DIWL,DIWR,DIWF,Z
+18 KILL ^UTILITY($JOB,"W")
+19 QUIT
+20 ;
ADDDX ;EP-BMCMOD;BMC*4.0*9-ADD DX CALL
+1 IF BMCDOS<$$IMPDATE^LEXU("10D")
SET (BMCICD,BMCICD1)="ICD"
+2 IF '$TEST
SET (BMCICD,BMCICD1)="10D"
+3 ;Get Coding System
SET BMCLEX=+($$CSYS^LEXU(BMCICD))
+4 SET BMCQ=0
FOR
Begin DoDot:1
+5 DO CONFIG^LEXSET(BMCICD,BMCICD1,BMCDOS)
+6 WRITE !!
SET DIC("A")="Enter ICD DX code: "
KILL X
DO ^LEXA1
+7 IF +Y<0
SET BMCQ=1
QUIT
+8 SET X=$PIECE($$CODEN^ICDEX($GET(Y(+BMCLEX)),80),"~")
+9 IF +X<1
WRITE !!,"INVALID CODE cannot add."
QUIT
+10 KILL DIC,Y
+11 SET DIC(0)="L"
SET DIC="^BMCDX("
SET DLAYGO=90001.01
DO FILE^DICN
+12 IF +Y<0
WRITE !,"Unable to add DX code."
SET BMCQ=1
QUIT
+13 SET DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04;.05;.06"
+14 SET DIE="^BMCDX("
+15 DO DIE^BMCFMC
+16 KILL BMCLOOK
+17 WRITE !
End DoDot:1
IF BMCQ
QUIT
+18 KILL DLAYGO,BMCDX,DIC,DIE,DR,DA,X,LEXQ,LEXVDT,ICDV,BMCLEX
+19 QUIT
+20 ;
ADDPX ;EP-BMCMOD;BMC*4.0*9-ADD PX CALL
+1 SET DIC="^ICPT("
SET DIC(0)="AMEQ"
SET DIC("A")="Enter RCIS CPT Procedure code: "
+2 SET DIC("S")="I '$P(^(0),U,4)"
+3 DO ^DIC
+4 IF Y=-1
SET BMCQ=1
KILL DIC
QUIT
+5 SET DIC(0)="L"
SET DIC="^BMCPX("
SET DLAYGO=90001.02
DO FILE^DICN
+6 IF +Y<0
WRITE !,"Unable to add CPT Procedure code."
SET BMCQ=1
QUIT
+7 SET DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"
+8 SET DIE="^BMCPX("
+9 DO DIE^BMCFMC
+10 KILL DLAYGO,BMCDX,DIC,DIE,DR,DA,X
+11 QUIT
+12 ;
