Routine: BMCMOD1

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:"??"),")"

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:"??"),")"

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")

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

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

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      ;

BMCMOD1.m