IBDFUTL3 ;ALB/MAF - MAINTENANCE UTILITY CONT. ;4/24/95
;;3.0;AUTOMATED INFO COLLECTION SYS;**63,70**;APR 24, 1997;Build 46
;
;
;
REPLACE ; -- Replace invalid code with another valid code... it will be in
; the same place as the old invalid code.
N IBDFVALM,VALMY,IBBLK,IBDFSLC,IBDFSLC1,IBDFSLC2,IBFORM,IBGRP,IBLIST,DA,IBSEL,ORDER,IEN,IBDN,IBDX,IBD9,IBD10,IBDQUIT,IBDREP
N IBDN,IBDX,IBD9,IBD10,IBDINV,IBDSV
S IBDQUIT=0
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0)),"S") G REP:'$O(VALMY(0)) S IBDFVALM=0
D FULL^VALM1 S VALMBCK="R"
F IBDFVALM=0:0 S IBDFVALM=$O(VALMY(IBDFVALM)) Q:IBDFVALM']"" D Q:$G(IBDINV)=1
.I $G(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($G(^XTMP("CPTIDX",IBDFVALM))="*Deleted*") S IBDINV=1 W !,"Not a valid selection; selection has already been replaced or deleted." H 3 Q
.S (IBDFSEL,DA)=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",4) I DA]"" S IBDFSLC=$G(^IBE(357.3,DA,0)),IBDFSLC1=$G(^IBE(357.3,DA,1,1,0)),IBDFSLC2=$G(^IBE(357.3,DA,1,2,0)) D
..I $G(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($G(^XTMP("CPTIDX",IBDFVALM))="*Deleted*") S IBDINV=1 W !,"Not a valid selection; selection has already been replaced or deleted." H 3 Q
..S IBFORM=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",5)
..S IBGRP=$P(IBDFSLC,"^",4)
..S IBLIST=$P(IBDFSLC,"^",3)
..S ORDER=$P(IBDFSLC,"^",5)
..S IBBLK=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",6)
..S IBDREP=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^")
..S IBDSV(IBDREP)=IBDFVALM
Q:$G(IBDINV)=1
D REPLC(IBLIST,IBGRP,ORDER,.IBSEL,IBBLK,IBFORM,.IBDQUIT)
Q:IBDQUIT
I ^XTMP("IBDCPT",IBDREP,0)'["*******Replaced*******",^XTMP("IBDCPT",IBDREP,0)'=" " S ^XTMP("IBDCPT",IBDREP,0)=$P(^XTMP("IBDCPT",IBDREP,0),")")_") *******Replaced*******" D
.S ^XTMP("CPTIDX",IBDSV(IBDREP))="*Replaced*"
S IBDN="",(IBD9,IBD10)=0 F S IBDN=$O(^IBE(357.2,"C",IBBLK,IBDN)) Q:IBDN="" S IBDX=$P($G(^IBE(357.2,IBDN,0)),U,11) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
.I IBDX="DG SELECT ICD-9 DIAGNOSIS CODE" S IBD9=1
.I IBDX="DG SELECT ICD-10 DIAGNOSIS COD" S IBD10=1
;Now update history if ICD-9 or ICD-10 was present before or after the change
N IBDX
I IBD9 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
I IBD10 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
K IBDF,^TMP("UTIL",$J) D INIT^IBDFUTL S VALMBCK="R" Q
;
;
REPLC(IBLIST,IBGRP,ORDER,IBSEL,IBBLK,IBFORM,IBDQUIT) ;allows the user to add a selection to the selection group for replacement - returns 0 if it was done, 1 otherwise
N SUB,IBRTN,IBDSERCH
;
Q:'$$FORMDSCR^IBDFU1C(.IBFORM)
Q:$$BLKDESCR^IBDFU1B(.IBBLK) 1
Q:$$LSTDESCR^IBDFU1(.IBLIST) 1
S IBRTN=IBLIST("RTN")
D RTNDSCR^IBDFU1B(.IBRTN)
;N QUIT S QUIT=0
I IBRTN("ACTION")'=3 D NOGOOD^IBDF4 Q 1
S IBDSERCH=2 ;Lexicon search.
K @IBRTN("DATA_LOCATION")
I '$$DORTN^IBDFU1B(.IBRTN,IBDSERCH) D NOGOOD^IBDF4 Q 1
I $D(DUOUT)!($D(DTOUT))!('$D(@IBRTN("DATA_LOCATION"))) D:$D(IBSEL) KILL3573(IBSEL) S IBDQUIT=1 Q
D ADDREC^IBDF4(.IBDQUIT,ORDER,.IBSEL,$P($G(@IBRTN("DATA_LOCATION")),U)) ;edits and adds the selection
I IBDQUIT=1 D KILL3573(IBSEL)
K @IBRTN("DATA_LOCATION")
; -- If a selection has been chosen, the old node is killed off and
; the block/selection list is updated.
I IBDQUIT Q
S DA=IBDFSEL,DIK="^IBE(357.3," D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
Q
;To kill incomplete entries in ^IBE(357.3
KILL3573(IBDSEL) ;
N DA,DIK
S DA=IBDSEL,DIK="^IBE(357.3," D ^DIK K DIK ;D BLKCHNG^IBDF19(IBFORM,IBBLK)
Q
REP K IBDF D INIT^IBDFUTL S VALMBG=1,VALMBCK="R"
Q
REPLALL ;Replace all invalid code with another valid code, in same spot
; the same place as the old invalid code.
N IBDFVALM,VALMY,IBBLK,IBDFSLC,IBDFSLC1,IBDFSLC2,IBFORM,IBGRP,IBLIST,DA,IBSEL,ORDER,IEN,IBDN,IBDX,IBD9,IBD10,IBDQUIT
N IBDN,IBDX,IBD9,IBD10,IBDRPCAL,IBDFSEL,IBDSEL1,IBDTMP,IBDINV,Y
S IBDQUIT=0,IBDRPCAL=1
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0)),"S") G REP:'$O(VALMY(0)) S IBDFVALM=0
Q:$G(IBDINV)
D FULL^VALM1 S VALMBCK="R"
F IBDFVALM=0:0 S IBDFVALM=$O(VALMY(IBDFVALM)) Q:IBDFVALM']"" D Q:$G(IBDINV)=1
.I $G(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($G(^XTMP("CPTIDX",IBDFVALM))="*Deleted*") S IBDINV=1 W !,"Not a valid selection; selection has already been replaced or deleted." H 3 Q
.S (IBDFSEL,DA)=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",4) I DA]"" S IBDFSLC=$G(^IBE(357.3,DA,0)),IBDFSLC1=$G(^IBE(357.3,DA,1,1,0)),IBDFSLC2=$G(^IBE(357.3,DA,1,2,0)) D
..S IBFORM=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",5)
..S IBGRP=$P(IBDFSLC,"^",4)
..S IBLIST=$P(IBDFSLC,"^",3)
..S ORDER=$P(IBDFSLC,"^",5)
..S IBBLK=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",6)
..S IBDTMP=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^")
..S IBDSEL1(IBDFVALM)=""
Q:$G(IBDINV)=1
D REPLC(IBLIST,IBGRP,ORDER,.IBSEL,IBBLK,IBFORM,.IBDQUIT)
Q:IBDQUIT
I ^XTMP("IBDCPT",IBDTMP,0)'["*******Replaced*******",^XTMP("IBDCPT",IBDTMP,0)'=" " S ^XTMP("IBDCPT",IBDTMP,0)=$P(^XTMP("IBDCPT",IBDTMP,0),")")_") *******Replaced*******"
S IBDN="",(IBD9,IBD10)=0 F S IBDN=$O(^IBE(357.2,"C",IBBLK,IBDN)) Q:IBDN="" S IBDX=$P($G(^IBE(357.2,IBDN,0)),U,11) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
.I IBDX="DG SELECT ICD-9 DIAGNOSIS CODE" S IBD9=1
.I IBDX="DG SELECT ICD-10 DIAGNOSIS COD" S IBD10=1
;Now update history if ICD-9 or ICD-10 was present before or after the change
;I IBD10 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
F S DIR(0)="Y",DIR("A")="Would you like to add another replacement code to the original",Y="" D ^DIR Q:'Y D REPMULT
K IBDF,^TMP("UTIL",$J),^TMP("IBDANT",$J) D INIT^IBDFUTL S VALMBCK="R" Q
;
REPMULT ;Replace Mutilple codes for a single
N IBDX,IBDRPCAL,IBLIST,IBDORDER,IBDQT,SLCTN,IBFORM,IBDSERCH,IBDGRP,IBDYS,IBDOLD,IBDERR,IBDX1,IBDGRP1,IBDSUB,IBDSUB1,IBDSNEW,IBDSELN,IBDSBI,IBDNEW,IBDN1,IBDCODE,IBDATA,IBDATA1,X,IBDSLLT
S IBDQT=0
S IBDX=0 S IBDX=$O(^TMP("IBDANT",$J,IBDX)) Q:'IBDX!(IBDQT=1) S IBLIST=$P(^TMP("IBDANT",$J,IBDX),U,3),IBFORM=$P(^TMP("IBDANT",$J,IBDX),U),IBDGRP=$P(^TMP("IBDANT",$J,IBDX),U,4)
D LSTDESCR^IBDFU1(.IBLIST)
S IBRTN=IBLIST("RTN")
D RTNDSCR^IBDFU1B(.IBRTN)
S IBDSERCH=2 ;Lexicon search.
K @IBRTN("DATA_LOCATION")
I '$$DORTN^IBDFU1B(.IBRTN,IBDSERCH) D NOGOOD^IBDF4 Q
I $D(DUOUT)!($D(DTOUT))!('$D(@IBRTN("DATA_LOCATION"))) D:$D(IBSEL) KILL3573(IBSEL) S IBDQT=1 Q
S IBDORDER=$P(^TMP("IBDANT",$J,IBDX),U,5) F S IBDORDER=IBDORDER+.1 Q:'$D(^IBE(357.3,"APO",IBLIST,IBDGRP,IBDORDER))
D ADDREC^IBDF4(.IBDQUIT,IBDORDER,.IBSEL,$P($G(@IBRTN("DATA_LOCATION")),U)) ;edits and adds the selection
F S IBDX=$O(^TMP("IBDANT",$J,IBDX)) Q:'IBDX D
.S IBDGRP=$P(^TMP("IBDANT",$J,IBDX),U,4)
.S IBDSLLT=$P(^TMP("IBDANT",$J,IBDX),U,3)
.S IBDORDER=$P(^TMP("IBDANT",$J,IBDX),U,5) F S IBDORDER=IBDORDER+.1 Q:'$D(^IBE(357.3,"APO",IBDSLLT,IBDGRP,IBDORDER))
.S IBDYS=IBSEL_"," D GETS^DIQ(357.3,IBDYS,"**","NI","IBDOLD","IBDERR")
.K DIC,DD,DO,DINUM S DIC="^IBE(357.3,",X=$P(^IBE(357.3,IBSEL,0),"^",1),DIC(0)="FL",DLAYGO=357.3 D FILE^DICN S IBDNEW=+Y K DIC,DIE,DA
.S DIE="^IBE(357.3,",DA=IBDNEW S IBDATA=$G(IBDOLD(357.3,IBDYS,.02,"I")) I IBDATA'="" S DR=".02///"_IBDATA D ^DIE
.S DR=".03////"_IBDSLLT D ^DIE
.S DR=".04////"_IBDGRP D ^DIE
.S DR=".05///"_IBDORDER D ^DIE
.S IBDN=.05 F S IBDN=$O(IBDOLD(357.3,IBDYS,IBDN)) Q:'IBDN S IBDATA=IBDOLD(357.3,IBDYS,IBDN,"I") I IBDATA'="" I IBDN'=2.02 I IBDN'=4.02 S DR=IBDN_"///"_IBDATA D ^DIE
.S IBDATA=$G(IBDOLD(357.3,IBDYS,2.02,"I")) I IBDATA'="" S DR=2.02_"////"_IBDATA D ^DIE
.S IBDATA=$G(IBDOLD(357.3,IBDYS,4.02,"I")) I IBDATA'="" S DR=4.02_"////"_IBDATA D ^DIE
.S IBDSELN=IBSEL_"," D GETS^DIQ(357.3,IBDSELN,"**","N","IBDCODE","IBDERR")
.I $D(IBDCODE(357.31)) S IBDSUB="" F S IBDSUB=$O(IBDCODE(357.31,IBDSUB)) Q:IBDSUB="" S IBDSBI=IBDCODE(357.31,IBDSUB,.01) S DIC="^IBE(357.3,"_IBDNEW_",1,",X=IBDSBI,DA(1)=IBDNEW,DA=X,DIC(0)="FL",DLAYGO=357.31 D FILE^DICN S IBDSNEW=+Y D
..S IBDN1=.01,DIE="^IBE(357.3,"_DA(1)_",1,",DA(1)=IBDNEW,DA=IBDSNEW,IBDSUB1=.01 F S IBDSUB1=$O(IBDCODE(357.31,IBDSUB,IBDSUB1)) Q:IBDSUB1="" S IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1) I IBDATA1'="" S DR=IBDSUB1_"///^S X=IBDATA1" D ^DIE
.I $D(IBDCODE(357.33)) S IBDSUB="" F S IBDSUB=$O(IBDCODE(357.33,IBDSUB)) Q:IBDSUB="" S IBDSBI=IBDCODE(357.33,IBDSUB,.01) S DIC="^IBE(357.3,"_IBDNEW_",3,",X=IBDSBI,DA(1)=IBDNEW,DA=X,DIC(0)="FL",DLAYGO=357.33 D FILE^DICN S IBDSNEW=+Y D
..S IBDN1=.01,DIE="^IBE(357.3,"_DA(1)_",3,",DA(1)=IBDNEW,DA=IBDSNEW,IBDSUB1=.01 F S IBDSUB1=$O(IBDCODE(357.33,IBDSUB,IBDSUB1)) Q:IBDSUB1="" S IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1) I IBDATA1'="" S DR=IBDSUB1_"///^S X=IBDATA1" D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFUTL3 8601 printed Dec 13, 2024@02:53:51 Page 2
IBDFUTL3 ;ALB/MAF - MAINTENANCE UTILITY CONT. ;4/24/95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63,70**;APR 24, 1997;Build 46
+2 ;
+3 ;
+4 ;
REPLACE ; -- Replace invalid code with another valid code... it will be in
+1 ; the same place as the old invalid code.
+2 NEW IBDFVALM,VALMY,IBBLK,IBDFSLC,IBDFSLC1,IBDFSLC2,IBFORM,IBGRP,IBLIST,DA,IBSEL,ORDER,IEN,IBDN,IBDX,IBD9,IBD10,IBDQUIT,IBDREP
+3 NEW IBDN,IBDX,IBD9,IBD10,IBDINV,IBDSV
+4 SET IBDQUIT=0
+5 SET VALMBCK=""
+6 DO EN^VALM2($GET(XQORNOD(0)),"S")
if '$ORDER(VALMY(0))
GOTO REP
SET IBDFVALM=0
+7 DO FULL^VALM1
SET VALMBCK="R"
+8 FOR IBDFVALM=0:0
SET IBDFVALM=$ORDER(VALMY(IBDFVALM))
if IBDFVALM']""
QUIT
Begin DoDot:1
+9 IF $GET(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($GET(^XTMP("CPTIDX",IBDFVALM))="*Deleted*")
SET IBDINV=1
WRITE !,"Not a valid selection; selection has already been replaced or deleted."
HANG 3
QUIT
+10 SET (IBDFSEL,DA)=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",4)
IF DA]""
SET IBDFSLC=$GET(^IBE(357.3,DA,0))
SET IBDFSLC1=$GET(^IBE(357.3,DA,1,1,0))
SET IBDFSLC2=$GET(^IBE(357.3,DA,1,2,0))
Begin DoDot:2
+11 IF $GET(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($GET(^XTMP("CPTIDX",IBDFVALM))="*Deleted*")
SET IBDINV=1
WRITE !,"Not a valid selection; selection has already been replaced or deleted."
HANG 3
QUIT
+12 SET IBFORM=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",5)
+13 SET IBGRP=$PIECE(IBDFSLC,"^",4)
+14 SET IBLIST=$PIECE(IBDFSLC,"^",3)
+15 SET ORDER=$PIECE(IBDFSLC,"^",5)
+16 SET IBBLK=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",6)
+17 SET IBDREP=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^")
+18 SET IBDSV(IBDREP)=IBDFVALM
End DoDot:2
End DoDot:1
if $GET(IBDINV)=1
QUIT
+19 if $GET(IBDINV)=1
QUIT
+20 DO REPLC(IBLIST,IBGRP,ORDER,.IBSEL,IBBLK,IBFORM,.IBDQUIT)
+21 if IBDQUIT
QUIT
+22 IF ^XTMP("IBDCPT",IBDREP,0)'["*******Replaced*******"
IF ^XTMP("IBDCPT",IBDREP,0)'=" "
SET ^XTMP("IBDCPT",IBDREP,0)=$PIECE(^XTMP("IBDCPT",IBDREP,0),")")_") *******Replaced*******"
Begin DoDot:1
+23 SET ^XTMP("CPTIDX",IBDSV(IBDREP))="*Replaced*"
End DoDot:1
+24 SET IBDN=""
SET (IBD9,IBD10)=0
FOR
SET IBDN=$ORDER(^IBE(357.2,"C",IBBLK,IBDN))
if IBDN=""
QUIT
SET IBDX=$PIECE($GET(^IBE(357.2,IBDN,0)),U,11)
IF IBDX?1.N
SET IBDX=$EXTRACT($PIECE($GET(^IBE(357.6,IBDX,0)),U,1),1,30)
Begin DoDot:1
+25 IF IBDX="DG SELECT ICD-9 DIAGNOSIS CODE"
SET IBD9=1
+26 IF IBDX="DG SELECT ICD-10 DIAGNOSIS COD"
SET IBD10=1
End DoDot:1
+27 ;Now update history if ICD-9 or ICD-10 was present before or after the change
+28 NEW IBDX
+29 IF IBD9
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
+30 IF IBD10
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
+31 KILL IBDF,^TMP("UTIL",$JOB)
DO INIT^IBDFUTL
SET VALMBCK="R"
QUIT
+32 ;
+33 ;
REPLC(IBLIST,IBGRP,ORDER,IBSEL,IBBLK,IBFORM,IBDQUIT) ;allows the user to add a selection to the selection group for replacement - returns 0 if it was done, 1 otherwise
+1 NEW SUB,IBRTN,IBDSERCH
+2 ;
+3 if '$$FORMDSCR^IBDFU1C(.IBFORM)
QUIT
+4 if $$BLKDESCR^IBDFU1B(.IBBLK)
QUIT 1
+5 if $$LSTDESCR^IBDFU1(.IBLIST)
QUIT 1
+6 SET IBRTN=IBLIST("RTN")
+7 DO RTNDSCR^IBDFU1B(.IBRTN)
+8 ;N QUIT S QUIT=0
+9 IF IBRTN("ACTION")'=3
DO NOGOOD^IBDF4
QUIT 1
+10 ;Lexicon search.
SET IBDSERCH=2
+11 KILL @IBRTN("DATA_LOCATION")
+12 IF '$$DORTN^IBDFU1B(.IBRTN,IBDSERCH)
DO NOGOOD^IBDF4
QUIT 1
+13 IF $DATA(DUOUT)!($DATA(DTOUT))!('$DATA(@IBRTN("DATA_LOCATION")))
if $DATA(IBSEL)
DO KILL3573(IBSEL)
SET IBDQUIT=1
QUIT
+14 ;edits and adds the selection
DO ADDREC^IBDF4(.IBDQUIT,ORDER,.IBSEL,$PIECE($GET(@IBRTN("DATA_LOCATION")),U))
+15 IF IBDQUIT=1
DO KILL3573(IBSEL)
+16 KILL @IBRTN("DATA_LOCATION")
+17 ; -- If a selection has been chosen, the old node is killed off and
+18 ; the block/selection list is updated.
+19 IF IBDQUIT
QUIT
+20 SET DA=IBDFSEL
SET DIK="^IBE(357.3,"
DO ^DIK
KILL DIK
DO BLKCHNG^IBDF19(IBFORM,IBBLK)
+21 QUIT
+22 ;To kill incomplete entries in ^IBE(357.3
KILL3573(IBDSEL) ;
+1 NEW DA,DIK
+2 ;D BLKCHNG^IBDF19(IBFORM,IBBLK)
SET DA=IBDSEL
SET DIK="^IBE(357.3,"
DO ^DIK
KILL DIK
+3 QUIT
REP KILL IBDF
DO INIT^IBDFUTL
SET VALMBG=1
SET VALMBCK="R"
+1 QUIT
REPLALL ;Replace all invalid code with another valid code, in same spot
+1 ; the same place as the old invalid code.
+2 NEW IBDFVALM,VALMY,IBBLK,IBDFSLC,IBDFSLC1,IBDFSLC2,IBFORM,IBGRP,IBLIST,DA,IBSEL,ORDER,IEN,IBDN,IBDX,IBD9,IBD10,IBDQUIT
+3 NEW IBDN,IBDX,IBD9,IBD10,IBDRPCAL,IBDFSEL,IBDSEL1,IBDTMP,IBDINV,Y
+4 SET IBDQUIT=0
SET IBDRPCAL=1
+5 SET VALMBCK=""
+6 DO EN^VALM2($GET(XQORNOD(0)),"S")
if '$ORDER(VALMY(0))
GOTO REP
SET IBDFVALM=0
+7 if $GET(IBDINV)
QUIT
+8 DO FULL^VALM1
SET VALMBCK="R"
+9 FOR IBDFVALM=0:0
SET IBDFVALM=$ORDER(VALMY(IBDFVALM))
if IBDFVALM']""
QUIT
Begin DoDot:1
+10 IF $GET(^XTMP("CPTIDX",IBDFVALM))="*Replaced*"!($GET(^XTMP("CPTIDX",IBDFVALM))="*Deleted*")
SET IBDINV=1
WRITE !,"Not a valid selection; selection has already been replaced or deleted."
HANG 3
QUIT
+11 SET (IBDFSEL,DA)=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",4)
IF DA]""
SET IBDFSLC=$GET(^IBE(357.3,DA,0))
SET IBDFSLC1=$GET(^IBE(357.3,DA,1,1,0))
SET IBDFSLC2=$GET(^IBE(357.3,DA,1,2,0))
Begin DoDot:2
+12 SET IBFORM=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",5)
+13 SET IBGRP=$PIECE(IBDFSLC,"^",4)
+14 SET IBLIST=$PIECE(IBDFSLC,"^",3)
+15 SET ORDER=$PIECE(IBDFSLC,"^",5)
+16 SET IBBLK=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",6)
+17 SET IBDTMP=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^")
+18 SET IBDSEL1(IBDFVALM)=""
End DoDot:2
End DoDot:1
if $GET(IBDINV)=1
QUIT
+19 if $GET(IBDINV)=1
QUIT
+20 DO REPLC(IBLIST,IBGRP,ORDER,.IBSEL,IBBLK,IBFORM,.IBDQUIT)
+21 if IBDQUIT
QUIT
+22 IF ^XTMP("IBDCPT",IBDTMP,0)'["*******Replaced*******"
IF ^XTMP("IBDCPT",IBDTMP,0)'=" "
SET ^XTMP("IBDCPT",IBDTMP,0)=$PIECE(^XTMP("IBDCPT",IBDTMP,0),")")_") *******Replaced*******"
+23 SET IBDN=""
SET (IBD9,IBD10)=0
FOR
SET IBDN=$ORDER(^IBE(357.2,"C",IBBLK,IBDN))
if IBDN=""
QUIT
SET IBDX=$PIECE($GET(^IBE(357.2,IBDN,0)),U,11)
IF IBDX?1.N
SET IBDX=$EXTRACT($PIECE($GET(^IBE(357.6,IBDX,0)),U,1),1,30)
Begin DoDot:1
+24 IF IBDX="DG SELECT ICD-9 DIAGNOSIS CODE"
SET IBD9=1
+25 IF IBDX="DG SELECT ICD-10 DIAGNOSIS COD"
SET IBD10=1
End DoDot:1
+26 ;Now update history if ICD-9 or ICD-10 was present before or after the change
+27 ;I IBD10 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
+28 FOR
SET DIR(0)="Y"
SET DIR("A")="Would you like to add another replacement code to the original"
SET Y=""
DO ^DIR
if 'Y
QUIT
DO REPMULT
+29 KILL IBDF,^TMP("UTIL",$JOB),^TMP("IBDANT",$JOB)
DO INIT^IBDFUTL
SET VALMBCK="R"
QUIT
+30 ;
REPMULT ;Replace Mutilple codes for a single
+1 NEW IBDX,IBDRPCAL,IBLIST,IBDORDER,IBDQT,SLCTN,IBFORM,IBDSERCH,IBDGRP,IBDYS,IBDOLD,IBDERR,IBDX1,IBDGRP1,IBDSUB,IBDSUB1,IBDSNEW,IBDSELN,IBDSBI,IBDNEW,IBDN1,IBDCODE,IBDATA,IBDATA1,X,IBDSLLT
+2 SET IBDQT=0
+3 SET IBDX=0
SET IBDX=$ORDER(^TMP("IBDANT",$JOB,IBDX))
if 'IBDX!(IBDQT=1)
QUIT
SET IBLIST=$PIECE(^TMP("IBDANT",$JOB,IBDX),U,3)
SET IBFORM=$PIECE(^TMP("IBDANT",$JOB,IBDX),U)
SET IBDGRP=$PIECE(^TMP("IBDANT",$JOB,IBDX),U,4)
+4 DO LSTDESCR^IBDFU1(.IBLIST)
+5 SET IBRTN=IBLIST("RTN")
+6 DO RTNDSCR^IBDFU1B(.IBRTN)
+7 ;Lexicon search.
SET IBDSERCH=2
+8 KILL @IBRTN("DATA_LOCATION")
+9 IF '$$DORTN^IBDFU1B(.IBRTN,IBDSERCH)
DO NOGOOD^IBDF4
QUIT
+10 IF $DATA(DUOUT)!($DATA(DTOUT))!('$DATA(@IBRTN("DATA_LOCATION")))
if $DATA(IBSEL)
DO KILL3573(IBSEL)
SET IBDQT=1
QUIT
+11 SET IBDORDER=$PIECE(^TMP("IBDANT",$JOB,IBDX),U,5)
FOR
SET IBDORDER=IBDORDER+.1
if '$DATA(^IBE(357.3,"APO",IBLIST,IBDGRP,IBDORDER))
QUIT
+12 ;edits and adds the selection
DO ADDREC^IBDF4(.IBDQUIT,IBDORDER,.IBSEL,$PIECE($GET(@IBRTN("DATA_LOCATION")),U))
+13 FOR
SET IBDX=$ORDER(^TMP("IBDANT",$JOB,IBDX))
if 'IBDX
QUIT
Begin DoDot:1
+14 SET IBDGRP=$PIECE(^TMP("IBDANT",$JOB,IBDX),U,4)
+15 SET IBDSLLT=$PIECE(^TMP("IBDANT",$JOB,IBDX),U,3)
+16 SET IBDORDER=$PIECE(^TMP("IBDANT",$JOB,IBDX),U,5)
FOR
SET IBDORDER=IBDORDER+.1
if '$DATA(^IBE(357.3,"APO",IBDSLLT,IBDGRP,IBDORDER))
QUIT
+17 SET IBDYS=IBSEL_","
DO GETS^DIQ(357.3,IBDYS,"**","NI","IBDOLD","IBDERR")
+18 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.3,"
SET X=$PIECE(^IBE(357.3,IBSEL,0),"^",1)
SET DIC(0)="FL"
SET DLAYGO=357.3
DO FILE^DICN
SET IBDNEW=+Y
KILL DIC,DIE,DA
+19 SET DIE="^IBE(357.3,"
SET DA=IBDNEW
SET IBDATA=$GET(IBDOLD(357.3,IBDYS,.02,"I"))
IF IBDATA'=""
SET DR=".02///"_IBDATA
DO ^DIE
+20 SET DR=".03////"_IBDSLLT
DO ^DIE
+21 SET DR=".04////"_IBDGRP
DO ^DIE
+22 SET DR=".05///"_IBDORDER
DO ^DIE
+23 SET IBDN=.05
FOR
SET IBDN=$ORDER(IBDOLD(357.3,IBDYS,IBDN))
if 'IBDN
QUIT
SET IBDATA=IBDOLD(357.3,IBDYS,IBDN,"I")
IF IBDATA'=""
IF IBDN'=2.02
IF IBDN'=4.02
SET DR=IBDN_"///"_IBDATA
DO ^DIE
+24 SET IBDATA=$GET(IBDOLD(357.3,IBDYS,2.02,"I"))
IF IBDATA'=""
SET DR=2.02_"////"_IBDATA
DO ^DIE
+25 SET IBDATA=$GET(IBDOLD(357.3,IBDYS,4.02,"I"))
IF IBDATA'=""
SET DR=4.02_"////"_IBDATA
DO ^DIE
+26 SET IBDSELN=IBSEL_","
DO GETS^DIQ(357.3,IBDSELN,"**","N","IBDCODE","IBDERR")
+27 IF $DATA(IBDCODE(357.31))
SET IBDSUB=""
FOR
SET IBDSUB=$ORDER(IBDCODE(357.31,IBDSUB))
if IBDSUB=""
QUIT
SET IBDSBI=IBDCODE(357.31,IBDSUB,.01)
SET DIC="^IBE(357.3,"_IBDNEW_",1,"
SET X=IBDSBI
SET DA(1)=IBDNEW
SET DA=X
SET DIC(0)="FL"
SET DLAYGO=357.31
DO FILE^DICN
SET IBDSNEW=+Y
Begin DoDot:2
+28 SET IBDN1=.01
SET DIE="^IBE(357.3,"_DA(1)_",1,"
SET DA(1)=IBDNEW
SET DA=IBDSNEW
SET IBDSUB1=.01
FOR
SET IBDSUB1=$ORDER(IBDCODE(357.31,IBDSUB,IBDSUB1))
if IBDSUB1=""
QUIT
SET IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1)
IF IBDATA1'=""
SET DR=IBDSUB1_"///^S X=IBDATA1"
DO ^DIE
End DoDot:2
+29 IF $DATA(IBDCODE(357.33))
SET IBDSUB=""
FOR
SET IBDSUB=$ORDER(IBDCODE(357.33,IBDSUB))
if IBDSUB=""
QUIT
SET IBDSBI=IBDCODE(357.33,IBDSUB,.01)
SET DIC="^IBE(357.3,"_IBDNEW_",3,"
SET X=IBDSBI
SET DA(1)=IBDNEW
SET DA=X
SET DIC(0)="FL"
SET DLAYGO=357.33
DO FILE^DICN
SET IBDSNEW=+Y
Begin DoDot:2
+30 SET IBDN1=.01
SET DIE="^IBE(357.3,"_DA(1)_",3,"
SET DA(1)=IBDNEW
SET DA=IBDSNEW
SET IBDSUB1=.01
FOR
SET IBDSUB1=$ORDER(IBDCODE(357.33,IBDSUB,IBDSUB1))
if IBDSUB1=""
QUIT
SET IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1)
IF IBDATA1'=""
SET DR=IBDSUB1_"///^S X=IBDATA1"
DO ^DIE
End DoDot:2
End DoDot:1
+31 QUIT
