BMCFUNC.m

BMCFUNC ; IHS/PHXAO/TMJ - FIX UNCODED DX ;

 ;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101

 ;BMC*4.0*8 CSV added a space to the .9999 code now checking for ".9999 "

 ;BMC*4.0*9 REWROTE FOR ICD-10 CHANGES

 ;

POV ;EP

 ;BMC*4.0*9 IHS.OIT.FCJ MODIFIED NXT SECTION TO CHECK FOR BOTH ICD9 AND ICD10 UNCODED DX CODE

 ;S BMCFILE=90001.01,BMCTEMP="[BMC FUD POV]" D GETCODE G PROCESS

 S BMCFILE=90001.01,BMCCONT=1

 F I=1:1:3 S BMC999=$S(I=1:$P($G(^APCCCTRL(DUZ(2),0)),U,5),I=2:$O(^ICD9("AB",".9999 ","")),I=3:$O(^ICD9("AB","ZZZ.999 ","")),1:"") D:BMC999'="" PROCESS Q:'BMCCONT

 W !!,"All done with the ",$P(^DIC(BMCFILE,0),U)," file",!

 D XIT

 Q

 ;

GETCODE ;

 ;I $P($G(^APCCCTRL(DUZ(2),0)),U,5)="" D SETDEF Q

 ;S BMC999=$P(^APCCCTRL(DUZ(2),0),U,5)

 ;Q

SETDEF ;SET DEFAULT OF .9999

 ;BMC*4.0*8 change ".9999" to ".9999 "

 ;S BMC999=$O(^ICD9("AB",.9999,""))

 ;S BMC999=$O(^ICD9("AB",".9999 ",""))

 ;Q

XIT ;

 K BMCFILE,BMCDFN,BMCVDG,BMCVIGR,BMCCONT,BMCTEMP,BMC999,BMCG,BMCL,BMCHRN,BMCDOB,BMCRIEN,AUPNSEX,AUPNPAT,AUPNDOB,AUPNDAYS,BMCEIN,AUPNDOD,BMCCAT

 K LEXVDT,DIC,BMCDX10,BMCDXCPT,BMCDXPR,BMCICD,BMCICD1,BMCLEX

 Q

PROCESS ;

 I BMC999="" W !!,"ERROR -- UNCODED DX IS NOT IN ICD DIAGNOSIS FILE, NOTIFY YOUR SUPERVISOR" G XIT

 S BMCEIN="",BMCDFN="",U="^"

 I '$D(^DIC(BMCFILE)) W !!,"FILE DOES NOT EXIST -- NOTIFY YOUR SUPERVISOR" G XIT

 S BMCVDG=$P(^DIC(BMCFILE,0),U) I BMCVDG="" W !,"ERROR IN ^DIC -- NOTIFY PROGRAMMER" G XIT

 S BMCVDG=^DIC(BMCFILE,0,"GL")

 S BMCG=BMCVDG_"""B"",BMC999)"

 I I=2,'$D(@BMCG) Q  ;BMC*4.0*9

 I '$D(@BMCG) W ?10,!!,"***There are no Uncoded DX codes to change.***" H 3 Q

 S BMCVIGR=BMCVDG_"""B"",BMC999,BMCDFN)"

 W !!,"Searching the ",$P(^DIC(BMCFILE,0),U)," File",!

 S BMCDFN=0,BMCCONT=1 F BMCL=0:0 S BMCDFN=$O(@BMCVIGR) Q:BMCDFN'=+BMCDFN  D CONT Q:'BMCCONT  D BMCDIE

 ;W !!,"All done with the ",$P(^DIC(BMCFILE,0),U)," file",!

 Q

CONT ;

 W !!

 S DIR("A")="Continue",DIR("B")="Y",DIR(0)="Y" D ^DIR

 I $D(DIRUT) S X="N"

 S:"Nn"[X BMCCONT=""

 W !

 K DIR,DIRUT,DUOUT,DTOUT,DIROUT

 Q

BMCDIE ;

 S BMCQ=0  ;BMC*4.0*9

 S BMCG=BMCVDG_"BMCDFN,0)" S Y=$P(@BMCG,U,2),BMCRIEN=$P(@BMCG,U,3) I Y=""!(BMCRIEN="") W !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING" Q

 D ^AUPNPAT

 I $L(BMCFILE)>7,AUPNDOB]"" S X2=AUPNDOB,X1=$P(^BMCREF(BMCRIEN,0),U)\1 D ^%DTC S AUPNDAYS=X ; re-set days of age to visit date-dob

 S Y=AUPNDOB X ^DD("DD") S BMCDOB=Y

 S BMCHRN="" I $D(^AUPNPAT(AUPNPAT,41,DUZ(2),0)) S BMCHRN=$P(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)

 W !,"NAME: ",$P(^DPT(AUPNPAT,0),U),"  DOB: ",BMCDOB,"  SEX: ",AUPNSEX,"  HRN: ",$S(BMCHRN]"":BMCHRN,1:"NONE")

 W !,"Referral: ",$P(^BMCREF(BMCRIEN,0),U,2),"  DX NAR: ",$P($G(^BMCREF(BMCRIEN,12)),U)

 ;I $L(BMCFILE)>7 S BMCCAT=$P(^BMCREF(BMCRIEN,0),U,7) W !,"DATE OF VISIT: " S Y=$P(^AUPNVSIT(BMCRIEN,0),U) D DT^DIO2 S Y=""

 ;

 ;BMC*4.0*9 Use Lexicon instead of input templates

 ;S DA=BMCDFN,DIE=BMCVDG,DR=BMCTEMP D ^DIE K DA,DIE,DR

 S BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N")

 I BMCDOS<$$IMPDATE^LEXU("10D") S (BMCICD,BMCICD1)="ICD"

 E  S (BMCICD,BMCICD1)="10D"

 S BMCLEX=+($$CSYS^LEXU(BMCICD))             ;Get Coding System

 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

 K DIC

 S X=$P($$CODEN^ICDEX($G(Y(+BMCLEX)),80),"~")  ;POINTER TO ICD

 I +Y<0 W !,"Unable to add DX code." S BMCQ=1 Q

 S DA=BMCDFN,DR=".01////"_X_";.02////"_DFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"

 S DIE=BMCVDG

 D DIE^BMCFMC

 K BMCDX,DIC,DIE,DR,DA,X,LEXQ,LEXVDT,ICDV,BMCLEX,BMCICD,BMCICD1

 ;BMC*4.0*9 END OF CHANGES

 ;

 ;I $L(BMCFILE)>7 S AUPNVSIT=BMCRIEN D MOD^AUPNVSIT

 ;Stuff Todays's Date in field .27 Date Last Modified in BMCREF(

 ;

 S DA=BMCRIEN,DIE="^BMCREF(",DR=".27////"_DT D ^DIE K DA,DIE,DIU,DIV,DR

 ;

 Q

BMCFUNC   ; IHS/PHXAO/TMJ - FIX UNCODED DX ;

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101

 +2       ;BMC*4.0*8 CSV added a space to the .9999 code now checking for ".9999 "

 +3       ;BMC*4.0*9 REWROTE FOR ICD-10 CHANGES

 +4       ;

POV       ;EP

 +1       ;BMC*4.0*9 IHS.OIT.FCJ MODIFIED NXT SECTION TO CHECK FOR BOTH ICD9 AND ICD10 UNCODED DX CODE

 +2       ;S BMCFILE=90001.01,BMCTEMP="[BMC FUD POV]" D GETCODE G PROCESS

 +3        SET BMCFILE=90001.01

           SET BMCCONT=1

 +4        FOR I=1:1:3

               SET BMC999=$SELECT(I=1:$PIECE($GET(^APCCCTRL(DUZ(2),0)),U,5),I=2:$ORDER(^ICD9("AB",".9999 ","")),I=3:$ORDER(^ICD9("AB","ZZZ.999 ","")),1:"")

               IF BMC999'=""

                   DO PROCESS

               IF 'BMCCONT

                   QUIT 

 +5        WRITE !!,"All done with the ",$PIECE(^DIC(BMCFILE,0),U)," file",!

 +6        DO XIT

 +7        QUIT 

 +8       ;

GETCODE   ;

 +1       ;I $P($G(^APCCCTRL(DUZ(2),0)),U,5)="" D SETDEF Q

 +2       ;S BMC999=$P(^APCCCTRL(DUZ(2),0),U,5)

 +3       ;Q

SETDEF    ;SET DEFAULT OF .9999

 +1       ;BMC*4.0*8 change ".9999" to ".9999 "

 +2       ;S BMC999=$O(^ICD9("AB",.9999,""))

 +3       ;S BMC999=$O(^ICD9("AB",".9999 ",""))

 +4       ;Q

XIT       ;

 +1        KILL BMCFILE,BMCDFN,BMCVDG,BMCVIGR,BMCCONT,BMCTEMP,BMC999,BMCG,BMCL,BMCHRN,BMCDOB,BMCRIEN,AUPNSEX,AUPNPAT,AUPNDOB,AUPNDAYS,BMCEIN,AUPNDOD,BMCCAT

 +2        KILL LEXVDT,DIC,BMCDX10,BMCDXCPT,BMCDXPR,BMCICD,BMCICD1,BMCLEX

 +3        QUIT 

PROCESS   ;

 +1        IF BMC999=""

               WRITE !!,"ERROR -- UNCODED DX IS NOT IN ICD DIAGNOSIS FILE, NOTIFY YOUR SUPERVISOR"

               GOTO XIT

 +2        SET BMCEIN=""

           SET BMCDFN=""

           SET U="^"

 +3        IF '$DATA(^DIC(BMCFILE))

               WRITE !!,"FILE DOES NOT EXIST -- NOTIFY YOUR SUPERVISOR"

               GOTO XIT

 +4        SET BMCVDG=$PIECE(^DIC(BMCFILE,0),U)

           IF BMCVDG=""

               WRITE !,"ERROR IN ^DIC -- NOTIFY PROGRAMMER"

               GOTO XIT

 +5        SET BMCVDG=^DIC(BMCFILE,0,"GL")

 +6        SET BMCG=BMCVDG_"""B"",BMC999)"

 +7       ;BMC*4.0*9

           IF I=2

               IF '$DATA(@BMCG)

                   QUIT 

 +8        IF '$DATA(@BMCG)

               WRITE ?10,!!,"***There are no Uncoded DX codes to change.***"

               HANG 3

               QUIT 

 +9        SET BMCVIGR=BMCVDG_"""B"",BMC999,BMCDFN)"

 +10       WRITE !!,"Searching the ",$PIECE(^DIC(BMCFILE,0),U)," File",!

 +11       SET BMCDFN=0

           SET BMCCONT=1

           FOR BMCL=0:0

               SET BMCDFN=$ORDER(@BMCVIGR)

               IF BMCDFN'=+BMCDFN

                   QUIT 

               DO CONT

               IF 'BMCCONT

                   QUIT 

               DO BMCDIE

 +12      ;W !!,"All done with the ",$P(^DIC(BMCFILE,0),U)," file",!

 +13       QUIT 

CONT      ;

 +1        WRITE !!

 +2        SET DIR("A")="Continue"

           SET DIR("B")="Y"

           SET DIR(0)="Y"

           DO ^DIR

 +3        IF $DATA(DIRUT)

               SET X="N"

 +4        IF "Nn"[X

               SET BMCCONT=""

 +5        WRITE !

 +6        KILL DIR,DIRUT,DUOUT,DTOUT,DIROUT

 +7        QUIT 

BMCDIE    ;

 +1       ;BMC*4.0*9

           SET BMCQ=0

 +2        SET BMCG=BMCVDG_"BMCDFN,0)"

           SET Y=$PIECE(@BMCG,U,2)

           SET BMCRIEN=$PIECE(@BMCG,U,3)

           IF Y=""!(BMCRIEN="")

               WRITE !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING"

               QUIT 

 +3        DO ^AUPNPAT

 +4       ; re-set days of age to visit date-dob

           IF $LENGTH(BMCFILE)>7

               IF AUPNDOB]""

                   SET X2=AUPNDOB

                   SET X1=$PIECE(^BMCREF(BMCRIEN,0),U)\1

                   DO ^%DTC

                   SET AUPNDAYS=X

 +5        SET Y=AUPNDOB

           XECUTE ^DD("DD")

           SET BMCDOB=Y

 +6        SET BMCHRN=""

           IF $DATA(^AUPNPAT(AUPNPAT,41,DUZ(2),0))

               SET BMCHRN=$PIECE(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)

 +7        WRITE !,"NAME: ",$PIECE(^DPT(AUPNPAT,0),U),"  DOB: ",BMCDOB,"  SEX: ",AUPNSEX,"  HRN: ",$SELECT(BMCHRN]"":BMCHRN,1:"NONE")

 +8        WRITE !,"Referral: ",$PIECE(^BMCREF(BMCRIEN,0),U,2),"  DX NAR: ",$PIECE($GET(^BMCREF(BMCRIEN,12)),U)

 +9       ;I $L(BMCFILE)>7 S BMCCAT=$P(^BMCREF(BMCRIEN,0),U,7) W !,"DATE OF VISIT: " S Y=$P(^AUPNVSIT(BMCRIEN,0),U) D DT^DIO2 S Y=""

 +10      ;

 +11      ;BMC*4.0*9 Use Lexicon instead of input templates

 +12      ;S DA=BMCDFN,DIE=BMCVDG,DR=BMCTEMP D ^DIE K DA,DIE,DR

 +13       SET BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N")

 +14       IF BMCDOS<$$IMPDATE^LEXU("10D")

               SET (BMCICD,BMCICD1)="ICD"

 +15      IF '$TEST

               SET (BMCICD,BMCICD1)="10D"

 +16      ;Get Coding System

           SET BMCLEX=+($$CSYS^LEXU(BMCICD))

 +17       DO CONFIG^LEXSET(BMCICD,BMCICD1,BMCDOS)

 +18       WRITE !!

           SET DIC("A")="Enter ICD DX code: "

           KILL X

           DO ^LEXA1

 +19       IF +Y<0

               SET BMCQ=1

               QUIT 

 +20       KILL DIC

 +21      ;POINTER TO ICD

           SET X=$PIECE($$CODEN^ICDEX($GET(Y(+BMCLEX)),80),"~")

 +22       IF +Y<0

               WRITE !,"Unable to add DX code."

               SET BMCQ=1

               QUIT 

 +23       SET DA=BMCDFN

           SET DR=".01////"_X_";.02////"_DFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"

 +24       SET DIE=BMCVDG

 +25       DO DIE^BMCFMC

 +26       KILL BMCDX,DIC,DIE,DR,DA,X,LEXQ,LEXVDT,ICDV,BMCLEX,BMCICD,BMCICD1

 +27      ;BMC*4.0*9 END OF CHANGES

 +28      ;

 +29      ;I $L(BMCFILE)>7 S AUPNVSIT=BMCRIEN D MOD^AUPNVSIT

 +30      ;Stuff Todays's Date in field .27 Date Last Modified in BMCREF(

 +31      ;

 +32       SET DA=BMCRIEN

           SET DIE="^BMCREF("

           SET DR=".27////"_DT

           DO ^DIE

           KILL DA,DIE,DIU,DIV,DR

 +33      ;

 +34       QUIT