IBDFUTL2 ;ALB/MAF - MAINTENANCE UTILITY CONT. ;4/24/95
;;3.0;AUTOMATED INFO COLLECTION SYS;**9,63,70**;APR 24, 1997;Build 46
;
;
;
ENDV ; -- Entire divisions were chosen, find all clinics (with encounter forms defined)
N IBCLN,IBDIV,NODE,DIVISION,ALL
; -- Make a list of the divisions chosen
S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("IBDF",$J,"D",IBDFGNM)) Q:IBDFGNM']"" S IBDIV=0 F S IBDIV=$O(^TMP("IBDF",$J,"D",IBDFGNM,IBDIV)) Q:'IBDIV S DIVISION(IBDIV,IBDFGNM)=""
;
; -- Loop through all the clinics finding ones in selected divisions
S IBCLN="" F S IBCLN=$O(^SC(IBCLN)) Q:IBCLN="" D
.S NODE=$G(^SC(IBCLN,0))
.S IBDIV=$P(NODE,"^",15)
.I IBDIV Q:'$D(DIVISION(IBDIV))
.; -- Check that location is a clinic
.Q:$P(NODE,"^",3)'="C"
.; -- It passed all the tests, put it on the list
.S IBDNAM=0 F IBDFDIV=0:0 S IBDFDIV=$O(DIVISION(IBDFDIV)) Q:'IBDFDIV I IBDFDIV=IBDIV F IBDNAME=0:0 S IBDNAM=$O(DIVISION(IBDFDIV,IBDNAM)) Q:IBDNAM']"" S ^TMP("IBDF",$J,"C",IBDNAM,$P(^SC(IBCLN,0),"^",1))=IBCLN
;
; -- Don't need list of divisions anymore
K ^TMP("IBDF",$J,"D")
Q
;
;
CLINICS ; -- Clinics that use the form
N IBDFFLG
S IBDFFLG=0 F IDX="C","D","E","F","G","H","I","J" D
.S SETUP="" F S SETUP=$O(^SD(409.95,IDX,IBDFORM1,SETUP)) Q:'SETUP D
..S CLINIC=$P($G(^SD(409.95,SETUP,0)),"^",1)
..Q:'CLINIC
..S NAME=$P($G(^SC(CLINIC,0)),"^",1)
..Q:NAME=""
..I IBDFFLG S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
..D:'IBDFFLG TMP1 S:IBDFFLG X="" S X=$$SETSTR^VALM1($E(NAME,1,20),X,66,14) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,37,29,IOINHI,IOINORM,0) S IBDFFLG=1
Q
;
;
TMP1 ; -- Text display set up of TMP array
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=$$SETSTR^VALM1(" ",X,1,80) D TMP^IBDFUTL1
S X="",X=$$SETSTR^VALM1("CLINICS USING THIS FORM ARE: ",X,37,29)
Q
;
;
I VALMCNT>0 N IBXFL S IBXFL=$S(VALMCNT+1/14?1.6N:1,VALMCNT+2/14?1.6N:2,VALMCNT+3/14?1.6N:3,VALMCNT+4/14?1.6N:4,1:0) I IBXFL D
.N IBXFL1
.F IBXFL1=1:1:IBXFL D
..S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
S IBDCNT1=IBDCNT1+1
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDF(IBDFNAME)=IBDCNT_"^"_IBDFORM1,^XTMP("IBDF",IBDFNAME)=IBDCNT_"^"_IBDFORM1
S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S IBDVAL=IBDFNAME
S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
S IBDCNT1=IBDCNT1-1
Q
;
;
JUMP ; -- Jump action to display a specific clinic group on the screen.
D FULL^VALM1
I $D(XQORNOD(0)),$P(XQORNOD(0),"^",4)]"" S X=$P(XQORNOD(0),"^",4) S X=$P(X,"=",2) I X]"" D:X?1.6N JSEL S DIC=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="QEZ" D ^DIC K DIC G:Y<0 JMP S Y=+Y D JUMP1 Q
JMP S DIC=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="AEMN",DIC("A")="Select "_$S($D(VAUTF):"Form",$D(VAUTG):"Clinic Group",1:"Clinic")_" you wish to move to: "
S:$D(VAUTC) DIC("S")="I $P(^SC(+Y,0),U,3)=""C""" D ^DIC K DIC
I X["^" S VALMBG=1,VALMBCK="R" Q
;
;
JUMP1 I Y<0 G JUMP
N IBDFCAT
S IBDFCAT=$S($D(VAUTF):$P(^IBE(357,+Y,0),"^",1),$D(VAUTG):$P(^IBD(357.99,+Y,0),"^",1),1:$P(^SC(+Y,0),"^",1))
I '$D(IBDF(IBDFCAT)) W !!,"There is no data listed for this Clinic Group" G JMP
S VALMBG=+IBDF(IBDFCAT) S VALMBCK="R" Q
Q
;
;
JSEL ; -- Convert number selected to name
S IBDVALM=X I $D(^TMP("CGIDX",$J,IBDVALM)) S X=$P(^TMP("CGIDX",$J,IBDVALM),"^",2),X=$P(^IBD(357.99,X,0),"^",1)
Q
;
;
CHGLST ; -- Code to change list display
D FULL^VALM1
S IBDFDIS1=IBDFDIS,IBDFINT1=IBDFINT,IBDFACT1=IBDFACT
D EXIT1^IBDFUTL,OUT^IBDFUTL
Q
;
;
DELETE ; -- Delete invalid code from the selection list/block
N IBDFVALM,VALMY,IBBLK,IBFORM,DA,IBDN,IBDX,IBD9,IBD10,IBDIEN,IBDINV,IBDTMP1
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0))) 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 DA=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",4) I DA]"" S IBFORM=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",5),IBBLK=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",6) D
..S DIK="^IBE(357.3,",DA=DA,IBDIEN(DA)="" D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
..S IBDTMP1=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^")
..S ^XTMP("IBDCPT",IBDTMP1,0)=$P(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Deleted*******",^XTMP("IBDCPT","IDX",IBDTMP1)="",^XTMP("CPTIDX",IBDFVALM)="*Deleted*"
Q:$G(IBDINV)=1
K IBDF,^TMP("UTIL",$J)
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)
; -- Redo list
REP K IBDF D INIT^IBDFUTL S VALMBG=1,VALMBCK="R"
Q
DLTALL ; -- Delete invalid code from the selection list/block
N IBDFVALM,VALMY,IBBLK,IBFORM,DA,IBDN,IBDX,IBD9,IBD10,IBDIEN,IBDICD,IBDY,IBDTMP1,IBDINV
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0))) 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 DA=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",4) I DA]"" D
..S IBDICD=$P($G(^XTMP("CPTIDX",IBDFVALM)),"^",2) S IBDY=0 F S IBDY=$O(^XTMP("CPTIDX",IBDY)) Q:'IBDY I $P($G(^XTMP("CPTIDX",IBDY)),"^",2)=IBDICD D
...S IBFORM=$P($G(^XTMP("CPTIDX",IBDY)),"^",5),IBBLK=$P($G(^XTMP("CPTIDX",IBDY)),"^",6),IBDTMP1=$P($G(^XTMP("CPTIDX",IBDY)),"^")
...S DIK="^IBE(357.3,",DA=$P($G(^XTMP("CPTIDX",IBDY)),"^",4),IBDIEN(DA)="" D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
...S ^XTMP("IBDCPT",IBDTMP1,0)=$P(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Deleted*******",^XTMP("IBDCPT","IDX",IBDTMP1)="",^XTMP("CPTIDX",IBDY)="*Deleted*"
Q:$G(IBDINV)=1
K IBDF,^TMP("UTIL",$J)
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 D INIT^IBDFUTL S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFUTL2 7290 printed Apr 09, 2024@21:56:44 Page 2
IBDFUTL2 ;ALB/MAF - MAINTENANCE UTILITY CONT. ;4/24/95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,63,70**;APR 24, 1997;Build 46
+2 ;
+3 ;
+4 ;
ENDV ; -- Entire divisions were chosen, find all clinics (with encounter forms defined)
+1 NEW IBCLN,IBDIV,NODE,DIVISION,ALL
+2 ; -- Make a list of the divisions chosen
+3 SET IBDFGNM=0
FOR IBDFGN=0:0
SET IBDFGNM=$ORDER(^TMP("IBDF",$JOB,"D",IBDFGNM))
if IBDFGNM']""
QUIT
SET IBDIV=0
FOR
SET IBDIV=$ORDER(^TMP("IBDF",$JOB,"D",IBDFGNM,IBDIV))
if 'IBDIV
QUIT
SET DIVISION(IBDIV,IBDFGNM)=""
+4 ;
+5 ; -- Loop through all the clinics finding ones in selected divisions
+6 SET IBCLN=""
FOR
SET IBCLN=$ORDER(^SC(IBCLN))
if IBCLN=""
QUIT
Begin DoDot:1
+7 SET NODE=$GET(^SC(IBCLN,0))
+8 SET IBDIV=$PIECE(NODE,"^",15)
+9 IF IBDIV
if '$DATA(DIVISION(IBDIV))
QUIT
+10 ; -- Check that location is a clinic
+11 if $PIECE(NODE,"^",3)'="C"
QUIT
+12 ; -- It passed all the tests, put it on the list
+13 SET IBDNAM=0
FOR IBDFDIV=0:0
SET IBDFDIV=$ORDER(DIVISION(IBDFDIV))
if 'IBDFDIV
QUIT
IF IBDFDIV=IBDIV
FOR IBDNAME=0:0
SET IBDNAM=$ORDER(DIVISION(IBDFDIV,IBDNAM))
if IBDNAM']""
QUIT
SET ^TMP("IBDF",$JOB,"C",IBDNAM,$PIECE(^SC(IBCLN,0),"^",1))=IBCLN
End DoDot:1
+14 ;
+15 ; -- Don't need list of divisions anymore
+16 KILL ^TMP("IBDF",$JOB,"D")
+17 QUIT
+18 ;
+19 ;
CLINICS ; -- Clinics that use the form
+1 NEW IBDFFLG
+2 SET IBDFFLG=0
FOR IDX="C","D","E","F","G","H","I","J"
Begin DoDot:1
+3 SET SETUP=""
FOR
SET SETUP=$ORDER(^SD(409.95,IDX,IBDFORM1,SETUP))
if 'SETUP
QUIT
Begin DoDot:2
+4 SET CLINIC=$PIECE($GET(^SD(409.95,SETUP,0)),"^",1)
+5 if 'CLINIC
QUIT
+6 SET NAME=$PIECE($GET(^SC(CLINIC,0)),"^",1)
+7 if NAME=""
QUIT
+8 IF IBDFFLG
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+9 if 'IBDFFLG
DO TMP1
if IBDFFLG
SET X=""
SET X=$$SETSTR^VALM1($EXTRACT(NAME,1,20),X,66,14)
DO TMP^IBDFUTL1
DO CNTRL^VALM10(VALMCNT,37,29,IOINHI,IOINORM,0)
SET IBDFFLG=1
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
+12 ;
TMP1 ; -- Text display set up of TMP array
+1 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+2 SET X=$$SETSTR^VALM1(" ",X,1,80)
DO TMP^IBDFUTL1
+3 SET X=""
SET X=$$SETSTR^VALM1("CLINICS USING THIS FORM ARE: ",X,37,29)
+4 QUIT
+5 ;
+6 ;
+1 IF VALMCNT>0
NEW IBXFL
SET IBXFL=$SELECT(VALMCNT+1/14?1.6N:1,VALMCNT+2/14?1.6N:2,VALMCNT+3/14?1.6N:3,VALMCNT+4/14?1.6N:4,1:0)
IF IBXFL
Begin DoDot:1
+2 NEW IBXFL1
+3 FOR IBXFL1=1:1:IBXFL
Begin DoDot:2
+4 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
SET X=$$SETSTR^VALM1(" ",X,1,3)
DO TMP^IBDFUTL1
End DoDot:2
End DoDot:1
+5 SET IBDCNT1=IBDCNT1+1
+6 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+7 SET X=""
+8 SET IBDF(IBDFNAME)=IBDCNT_"^"_IBDFORM1
SET ^XTMP("IBDF",IBDFNAME)=IBDCNT_"^"_IBDFORM1
+9 SET X=$$SETSTR^VALM1(" ",X,1,3)
DO TMP^IBDFUTL1
+10 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+11 SET IBDVAL=IBDFNAME
+12 SET IBDVAL1=$LENGTH(IBDVAL)
SET IBDVAL1=(80-IBDVAL1)/2
SET IBDVAL1=IBDVAL1\1
SET X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
+13 SET X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25)
DO TMP^IBDFUTL1
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
+14 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+15 SET X=$$SETSTR^VALM1(" ",X,1,3)
DO TMP^IBDFUTL1
+16 SET IBDCNT1=IBDCNT1-1
+17 QUIT
+18 ;
+19 ;
JUMP ; -- Jump action to display a specific clinic group on the screen.
+1 DO FULL^VALM1
+2 IF $DATA(XQORNOD(0))
IF $PIECE(XQORNOD(0),"^",4)]""
SET X=$PIECE(XQORNOD(0),"^",4)
SET X=$PIECE(X,"=",2)
IF X]""
if X?1.6N
DO JSEL
SET DIC=$SELECT($DATA(VAUTF):"^IBE(357,",$DATA(VAUTG):"^IBD(357.99,",1:"^SC(")
SET DIC(0)="QEZ"
DO ^DIC
KILL DIC
if Y<0
GOTO JMP
SET Y=+Y
DO JUMP1
QUIT
JMP SET DIC=$SELECT($DATA(VAUTF):"^IBE(357,",$DATA(VAUTG):"^IBD(357.99,",1:"^SC(")
SET DIC(0)="AEMN"
SET DIC("A")="Select "_$SELECT($DATA(VAUTF):"Form",$DATA(VAUTG):"Clinic Group",1:"Clinic")_" you wish to move to: "
+1 if $DATA(VAUTC)
SET DIC("S")="I $P(^SC(+Y,0),U,3)=""C"""
DO ^DIC
KILL DIC
+2 IF X["^"
SET VALMBG=1
SET VALMBCK="R"
QUIT
+3 ;
+4 ;
JUMP1 IF Y<0
GOTO JUMP
+1 NEW IBDFCAT
+2 SET IBDFCAT=$SELECT($DATA(VAUTF):$PIECE(^IBE(357,+Y,0),"^",1),$DATA(VAUTG):$PIECE(^IBD(357.99,+Y,0),"^",1),1:$PIECE(^SC(+Y,0),"^",1))
+3 IF '$DATA(IBDF(IBDFCAT))
WRITE !!,"There is no data listed for this Clinic Group"
GOTO JMP
+4 SET VALMBG=+IBDF(IBDFCAT)
SET VALMBCK="R"
QUIT
+5 QUIT
+6 ;
+7 ;
JSEL ; -- Convert number selected to name
+1 SET IBDVALM=X
IF $DATA(^TMP("CGIDX",$JOB,IBDVALM))
SET X=$PIECE(^TMP("CGIDX",$JOB,IBDVALM),"^",2)
SET X=$PIECE(^IBD(357.99,X,0),"^",1)
+2 QUIT
+3 ;
+4 ;
CHGLST ; -- Code to change list display
+1 DO FULL^VALM1
+2 SET IBDFDIS1=IBDFDIS
SET IBDFINT1=IBDFINT
SET IBDFACT1=IBDFACT
+3 DO EXIT1^IBDFUTL
DO OUT^IBDFUTL
+4 QUIT
+5 ;
+6 ;
DELETE ; -- Delete invalid code from the selection list/block
+1 NEW IBDFVALM,VALMY,IBBLK,IBFORM,DA,IBDN,IBDX,IBD9,IBD10,IBDIEN,IBDINV,IBDTMP1
+2 SET VALMBCK=""
+3 DO EN^VALM2($GET(XQORNOD(0)))
if '$ORDER(VALMY(0))
GOTO REP
SET IBDFVALM=0
+4 DO FULL^VALM1
SET VALMBCK="R"
+5 FOR IBDFVALM=0:0
SET IBDFVALM=$ORDER(VALMY(IBDFVALM))
if IBDFVALM']""
QUIT
Begin DoDot:1
+6 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
+7 SET DA=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",4)
IF DA]""
SET IBFORM=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",5)
SET IBBLK=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",6)
Begin DoDot:2
+8 SET DIK="^IBE(357.3,"
SET DA=DA
SET IBDIEN(DA)=""
DO ^DIK
KILL DIK
DO BLKCHNG^IBDF19(IBFORM,IBBLK)
+9 SET IBDTMP1=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^")
+10 SET ^XTMP("IBDCPT",IBDTMP1,0)=$PIECE(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Deleted*******"
SET ^XTMP("IBDCPT","IDX",IBDTMP1)=""
SET ^XTMP("CPTIDX",IBDFVALM)="*Deleted*"
End DoDot:2
End DoDot:1
if $GET(IBDINV)=1
QUIT
+11 if $GET(IBDINV)=1
QUIT
+12 KILL IBDF,^TMP("UTIL",$JOB)
+13 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
+14 IF IBDX="DG SELECT ICD-9 DIAGNOSIS CODE"
SET IBD9=1
+15 IF IBDX="DG SELECT ICD-10 DIAGNOSIS COD"
SET IBD10=1
End DoDot:1
+16 ;Now update history if ICD-9 or ICD-10 was present before or after the change
+17 NEW IBDX
+18 IF IBD9
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
+19 IF IBD10
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
+20 ; -- Redo list
REP KILL IBDF
DO INIT^IBDFUTL
SET VALMBG=1
SET VALMBCK="R"
+1 QUIT
DLTALL ; -- Delete invalid code from the selection list/block
+1 NEW IBDFVALM,VALMY,IBBLK,IBFORM,DA,IBDN,IBDX,IBD9,IBD10,IBDIEN,IBDICD,IBDY,IBDTMP1,IBDINV
+2 SET VALMBCK=""
+3 DO EN^VALM2($GET(XQORNOD(0)))
if '$ORDER(VALMY(0))
GOTO REP
SET IBDFVALM=0
+4 DO FULL^VALM1
SET VALMBCK="R"
+5 FOR IBDFVALM=0:0
SET IBDFVALM=$ORDER(VALMY(IBDFVALM))
if IBDFVALM']""
QUIT
Begin DoDot:1
+6 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
+7 SET DA=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",4)
IF DA]""
Begin DoDot:2
+8 SET IBDICD=$PIECE($GET(^XTMP("CPTIDX",IBDFVALM)),"^",2)
SET IBDY=0
FOR
SET IBDY=$ORDER(^XTMP("CPTIDX",IBDY))
if 'IBDY
QUIT
IF $PIECE($GET(^XTMP("CPTIDX",IBDY)),"^",2)=IBDICD
Begin DoDot:3
+9 SET IBFORM=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^",5)
SET IBBLK=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^",6)
SET IBDTMP1=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^")
+10 SET DIK="^IBE(357.3,"
SET DA=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^",4)
SET IBDIEN(DA)=""
DO ^DIK
KILL DIK
DO BLKCHNG^IBDF19(IBFORM,IBBLK)
+11 SET ^XTMP("IBDCPT",IBDTMP1,0)=$PIECE(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Deleted*******"
SET ^XTMP("IBDCPT","IDX",IBDTMP1)=""
SET ^XTMP("CPTIDX",IBDY)="*Deleted*"
End DoDot:3
End DoDot:2
End DoDot:1
if $GET(IBDINV)=1
QUIT
+12 if $GET(IBDINV)=1
QUIT
+13 KILL IBDF,^TMP("UTIL",$JOB)
+14 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
+15 IF IBDX="DG SELECT ICD-9 DIAGNOSIS CODE"
SET IBD9=1
+16 IF IBDX="DG SELECT ICD-10 DIAGNOSIS COD"
SET IBD10=1
End DoDot:1
+17 ;Now update history if ICD-9 or ICD-10 was present before or after the change
+18 NEW IBDX
+19 IF IBD9
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
+20 IF IBD10
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
+21 KILL IBDF
DO INIT^IBDFUTL
SET VALMBCK="R"
+22 QUIT
