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
