- 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 Feb 19, 2025@00:20:15 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