- IBDFUTL ;ALB/MAF - Maintenance Utility Routine ;04/20/95
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,32,51,63,70**;APR 24, 1997;Build 46
- ;
- ;ICRs
- ; Reference to LS^ICDEX supported by ICR #5747
- ; Reference to CSI^ICDEX supported by ICR #5747
- ;
- EN ;IBD*3.0*70 - New Maintenance Utility Option Entry Point
- ;Check if ^XTMP global exists. If so, Give user the option to use the last report or run a new one
- N IBDLR,IBDFDIS,IBDFINT,IBDDUZ,IBDN,IBDIA,IBDST,IBDFACT,IBDSTR,IBDAI,IBDF
- L +^XTMP("IBDRPT"):$G(DILOCKTM,5) I '$T W !!,"The Maintenance Utility is locked by another user or currently running in the background. Please try again later.",! Q
- I '$D(^XTMP("IBDRPT",0))!('$D(^XTMP("IBDRPT",1)))!('$D(^XTMP("IBDRPT",2))) W !,"The Maintenance Utility must be run." D OUT Q
- S IBDLR=$P($G(^XTMP("IBDRPT",0)),U,2) I IBDLR D
- .S IBDFDIS=$P(^XTMP("IBDRPT",1),U,2),IBDFINT=$P(^XTMP("IBDRPT",1),U,3),IBDAI=$P(^IBE(357.6,IBDFINT,0),U),IBDDUZ=$P(^XTMP("IBDRPT",1),U),IBDN=$S(^XTMP("IBDRPT",2):"all",1:"select")
- .S IBDIA=$S($P(^XTMP("IBDRPT",1),U,4)=1:"ACTIVE",$P(^XTMP("IBDRPT",1),U,4)=2:"INACTIVE",1:"")
- .W ! F IBDSTR=1:1:80 W "*"
- .W !,"The current report on file was run by ",$$GET1^DIQ(200,IBDDUZ,.01)," on ",$$FMTE^XLFDT(IBDLR),"."
- .W !,"It is for ",IBDAI," and sorted by ",$S(IBDFDIS="CLIN":"CLINIC",1:IBDFDIS)
- .W !,"The report contains ",IBDIA," codes."
- .W:IBDN'="" !,"The report is for ",$S(IBDN="all":"all "_$S(IBDFDIS="CLIN":"CLINIC",1:IBDFDIS)_"S.",1:"the following "_$S(IBDFDIS="CLIN":"CLINIC",1:IBDFDIS)_"S.") I IBDN'="all" D
- ..S IBDST=0 F S IBDST=$O(^XTMP("IBDRPT",2,IBDST)) Q:'IBDST W !,^XTMP("IBDRPT",2,IBDST)
- .W ! F IBDSTR=1:1:80 W "*"
- .S DIR(0)="Y",DIR("A")="Would you like to view this report",DIR("B")="Yes" D ^DIR I Y K XQORS,VALMEVL D SETIBDF(.IBDF) S IBDFACT=$P(^XTMP("IBDRPT",1),U,4) D SETSRT(IBDFDIS) D EN^VALM("IBDF UTIL PRIMARY SCREEN") Q
- .Q:$D(DIRUT) S DIR(0)="Y",DIR("A")="This will delete the current report and run a new one. Are you sure" D ^DIR I Y D OUT Q
- .W !,"The Maintenance Utility will not be run." Q
- Q
- ;
- ; -- Set up variables for display by clinic/form/group
- OUT S IBDFL=0 ;W !!,"Display output by: CLINICS// " D ZSET1 S X="" R X:DTIME G QUIT:X="^"!('$T) I X=""!("Cc"[X) S X="1"
- S DIR("B")="CLINICS"
- ;S DIR(0)="SBM^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS"
- S DIR(0)="SA^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS"
- S DIR("A")="Sort by [C]linics, [G]roups, [F]orms: " D ^DIR
- K DIR I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
- I $D(DIRUT)&$D(IBDF1) G QUIT
- S X=$S("Gg"[X:2,"Ff"[X:3,"Ss"[X:4,1:1)
- ;I X="?" D ZSET1,HELP1 G OUT
- S IBDFSRT=$E(X) ;D IN^DGHELP W ! I %=-1 D ZSET1,HELP1 G OUT
- S IBDFDIS=$S(IBDFSRT=1:"CLIN",IBDFSRT=2:"GROUP",IBDFSRT=3:"FORM",1:"QUIT")
- D @(IBDFDIS) S:Y=-1 IBDFNCNG=1 G:Y=-1 QUIT
- ;
- ;
- OUT1 ; -- Ask for what type of package interface
- N IBDTEMPY,IBDQUIT,IBDFINT,IBDCOUNT,IBDAUTO,IBDX,IBDQUI2,ZTRTN,ZTDESC,ZTSAVE,IBDQUE
- S DIC="^IBE(357.6,",DIC(0)="AEMN"
- S DIC("S")="I $P(^(0),U,6)=3,$P(^(0),U,9)=1,$G(^(11))'="""""
- S DIC("A")="Select Type of Code to Display: " D ^DIC K DIC G QUIT:Y<0
- S IBDFINT=+Y
- ;
- S IBDFACT=2 ;default of Inactive
- S X=$E($G(^IBE(357.6,IBDFINT,11)),7,9)
- ;
- ; -- for cpt and icd codes, let them choose active or inactive
- I X="CPT"!(X="VST")!(X="ICD") D
- .S DIR("B")="ACTIVE"
- .;S DIR(0)="SBM^A:ACTIVE;I:INACTIVE"
- .S DIR(0)="SA^A:ACTIVE;I:INACTIVE"
- .S DIR("A")="Display codes [A]ctive, [I]nactive: "
- .D ^DIR K DIR
- .Q:$D(DIRUT)
- .S X=$S("Ii"[$E(X,1):2,1:1)
- .S IBDFACT=$E(X)
- I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
- I $D(DIRUT)&$D(IBDF1) G QUIT
- ;IBD*3.0*70 - set up XTMP global with Report Info
- K ^XTMP("IBDRPT"),^XTMP("CPTIDX"),^XTMP("IBDCPT"),^XTMP("IBDF")
- S ^XTMP("IBDRPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility rpt global",^XTMP("IBDRPT",1)=DUZ_U_IBDFDIS_U_IBDFINT_U_IBDFACT
- S ^XTMP("CPTIDX",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility CPTIDX global"
- S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
- S ^XTMP("IBDF",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDF global"
- S IBDTYP=$S($D(VAUTC):"VAUTC",$D(VAUTF):"VAUTF",$D(VAUTG):"VAUTG",1:"") S ^XTMP("IBDRPT",2)=@IBDTYP I ^XTMP("IBDRPT",2)=0 M ^XTMP("IBDRPT",2)=@IBDTYP
- ;cannot use this option before ICD-10 impelemenation
- ;
- I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD",DT<$$IMPDATE^IBDUTICD(30),$$GETCODSY(IBDFINT)["ICD-10",IBDFACT=1 D G:IBDQUI2<0 EXIT S:IBDQUI2="I" IBDFACT=2
- . F D Q:IBDQUI2'="A"
- .. W !!,"ICD-10 codes cannot be selected for this option before ICD-10 activation.",!
- .. S DIR(0)="FAO",DIR("A")="Press RETURN to continue..." D ^DIR K DIR
- .. S IBDQUI2=$$ACTPRMT^IBDUTICD()
- ;
- I $D(IBDF1) D
- .K VAUTP F IBI=0:0 S IBI=$O(VAUTJ(IBI)) Q:IBI']"" S VAUTP(IBI)=$G(VAUTJ(IBI))
- ;
- ;
- ;
- I IBDFACT=1 D
- .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC="^ICPT(",IBDFCODE="CPT "
- .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" S DIC="^ICD9(",IBDFCODE="ICD-9 "
- .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC="^IBE(357.69,",IBDFCODE="Type of Visit "
- .;
- .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC="^ICPT(",IBDFCODE="CPT ",DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- .;
- .;Change variable IBDFCODE to "ICD-9" or "ICD-10"
- .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" D ;
- ..S IBDFCODE=$$GETCODSY(IBDFINT)
- ..S DIC="^ICD9("
- .;
- .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC="^IBE(357.69,",IBDFCODE="Type of Visit ",DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- .;
- .;ICD-9 only
- .I $G(DIC)]"",$G(IBDFCODE)["ICD-9" D Q
- ..N IBDICD9D ;ICD9 date
- ..S IBDICD9D=$$IMPDATE^IBDUTICD(1)
- ..S DIC("S")="I $$LS^ICDEX(80,+Y,IBDICD9D)>0,$$CSI^ICDEX(80,+Y)=1"
- ..D EN1^IBDVAUT1("VAUTJ",2,IBDFCODE_"code",1)
- .;ICD-10 only
- .I $G(DIC)]"",$G(IBDFCODE)["ICD-10" S VAUTVB="VAUTJ",IBDTEMPY=Y D ICD10 S Y=IBDTEMPY Q
- .;
- .;CPT and VST only
- .I $G(DIC)]"" S VAUTVB="VAUTJ",VAUTNI=2,VAUTSTR=IBDFCODE_"code" S VAUTNALL=1 D FIRST^VAUTOMA
- ;
- I IBDFACT=2 D
- .S IBDFCODE=$$GETCODSY(IBDFINT)
- I (Y<0)&$D(IBDF1) D K VAUTP G QUIT
- .F IBI=0:0 S IBI=$O(VAUTP(IBI)) Q:IBI']"" S VAUTJ(IBI)=$G(VAUTP(IBI))
- I IBDFACT=1,Y<0,'$D(IBDF1) G EXIT
- I IBDFACT=1,$G(IBDQUIT) G EXIT
- ;
- ;Allow Report to be Queued - IBD*3.0*70
- L -^XTMP("IBDRPT")
- S DIR(0)="Y",DIR("A")="Would you like to queue this report and run it in the background",DIR("B")="Yes" D ^DIR
- I Y S IBDQUE=1,ZTRTN="OUT2^IBDFUTL",ZTDESC="Maintenance Utility background job",ZTSAVE("*")="",ZTIO="NULL" D ^%ZTLOAD Q
- OUT2 ;Tasked entry point
- L +^XTMP("IBDRPT"):$G(DILOCKTM,5) Q:'$T
- I $G(IBDQUE) S VALMEVL=$S($D(VALMEVL):VALMEVL+1,1:0) D INIT S VALMBCK="R",VALMBG=1 Q
- I '$D(IBDF1) K XQORS,VALMEVL D EN^VALM("IBDF UTIL PRIMARY SCREEN")
- I $D(IBDF1) D HDR,KILL,INIT S VALMBCK="R",VALMBG=1
- Q
- ;
- HDR ; -- header code
- I IBDFACT=1 D
- .S VALMHDR(1)="This screen lists Active codes on Encounter Forms."
- I IBDFACT'=1 D
- .S VALMHDR(1)="This screen lists Inactive codes on Encounter Forms."
- Q
- ;
- ; -- Set up list
- INIT D FULL^VALM1 S (IBDCNT,IBDCNT1,VALMCNT)=0
- N IBDX
- D KILL^VALM10()
- I '$O(^XTMP("IBDCPT",0)) S IBDFCNT1=0 D @(IBDFDIS_"1^IBDFUTL1")
- I '$O(^XTMP("IBDCPT",0)) D NUL
- I $O(^XTMP("IBDCPT",0)),'$G(VALMCNT) K ^TMP("IBDCPT1",$J) S VALMCNT=0,IBDX=0 F S IBDX=$O(^XTMP("IBDCPT",IBDX)) Q:'IBDX S VALMCNT=VALMCNT+1 D
- .S ^TMP("IBDCPT1",$J,VALMCNT,0)=^XTMP("IBDCPT",IBDX,0) M ^TMP("IBDCPT1",$J,"IDX",VALMCNT)=^XTMP("IBDCPT","IDX",IBDX)
- I $D(^TMP("IBDCPT1",$J)) K ^XTMP("IBDCPT") M ^XTMP("IBDCPT")=^TMP("IBDCPT1",$J) K ^TMP("IBDCPT1",$J)
- I '$D(^XTMP("IBDCPT",0)) S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
- Q
- ;
- ; -- Ask for clinics one/many/all
- CLIN S VAUTVB="VAUTC",DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""",VAUTSTR="Clinic",VAUTNI=2 D FIRST^VAUTOMA K DIC S:Y=-1 IBDFL=1 Q:IBDFL
- Q
- ;
- ; -- Ask for forms one/many/all
- FORM S VAUTVB="VAUTF",DIC="^IBE(357,",VAUTSTR="Form",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 IBDFL=1 Q:IBDFL
- Q
- ;
- ; -- Ask for clinic groups one/many/all
- GROUP S VAUTVB="VAUTG",DIC="^IBD(357.99,",VAUTSTR="Clinic Group",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 IBDFL=1 Q:IBDFL
- Q
- ;
- ; -- Ask for divisions one/many/all
- DIV S IBDFL=0 D DIVISION^VAUTOMA
- S:Y=-1 IBDFL=1 Q:IBDFL
- Q
- ; -- Help for display choices
- HELP1 W !!,"Choose a number or first initial :" F K=2:1:4 W !?15,$P(Z,"^",K)
- W ! Q
- ;
- ; -- Listing of selections
- ZSET1 S Z="^1 [C]LINICS (Individual)^2 [G]ROUPS (CLINIC)^3 [F]ORMS^" Q
- ;
- ;
- QUIT ; -- Kill variables and reset to last display if no change has been taken place.
- I $D(IBDF1) S IBDFDIS=IBDFDIS1,IBDFINT=IBDFINT1,IBDFACT=IBDFACT1
- I '$D(IBDF1) G EXIT
- D KILL,INIT K IBDFNCNG S VALMBCK="R",VALMBG=1
- Q
- ;
- ;
- KILL ; -- Kill extra array variables
- N IBDFXX
- S IBDFXX=$S(IBDFDIS="FORM":"VAUTF",IBDFDIS="GROUP":"VAUTG",1:"VAUTC")
- I IBDFXX="VAUTF" K VAUTG,VAUTC,^TMP("CLN",$J),^TMP("CLN1",$J),^TMP("GRP",$J),^TMP("GRP1",$J)
- I IBDFXX="VAUTC" K VAUTG,VAUTF,^TMP("FRM",$J),^TMP("FRM1",$J),^TMP("GRP1",$J)
- I IBDFXX="VAUTG" K VAUTC,VAUTF,^TMP("FRM",$J),^TMP("FRM1",$J),^TMP("CLN",$J),^TMP("CLN1",$J)
- Q
- ;
- ;
- EXIT ; -- Code executed at action exit
- K IBDFDIS,IBDFINT,VAUTC,VAUTF,VAUTG,VAUTJ,VAUTP,IBDFINT1,IBDFDIS1,^TMP("CLN",$J),IBDFCODE,IBI,IBDFACT1
- EXIT1 K DIC,IBDBLK,IBDCLN,IBDCLNM,IBDCNODE,IBDCNT,IBDCNT1,IBDF,IBDFBK,IBDFCIFN,IBDFCLIN,IBDFL,IBDFLG,IBDFN,IBDFNAME,IBDFNM,IBDFNODE,IBDFORM1,IBDFRM,IBDFSEL,IBDFSRT,IBDFTMP,IBDFVAL
- K IBDFX,IBDORM,IBDVAL,IBDVAL1,IBDFCNT1,Z,IBDFRNM,IBDFX1,IBDFX2,IBDFX3
- K IBCLN,IBDFCLN,IBDFCLNM,IBDFDIV,IBDFGIFN,IBDFGN,IBDFGNM,IBDIV,IBDNAM,IBDNAME,IEN,^TMP("IBDF",$J),^TMP("UTIL",$J),DIVISION,IBDF,IBDFACT,VAUTNALL
- K ^TMP("IBDFUTL_SELECTED",$J),^TMP("IBDFUTL_TEMP",$J),^TMP("IBDFUTL_WCSEARCH",$J)
- L -^XTMP("IBDRPT")
- Q
- ;
- HLP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- ;
- EXP ; -- expand code
- Q
- NUL ; -- NULL MESSAGE
- S ^XTMP("IBDCPT",1,0)=" ",^XTMP("IBDCPT",2,0)="There are no "_$S(IBDFACT=1:"active",1:"inactive")_" codes on any forms.",^XTMP("CPTIDX",1)=1,^XTMP("CPTIDX",2)=2
- Q
- ;--------- new code for ICD-10
- ICD10 ; Wildcard search for ICD-10 codes
- ;
- N %,DIR,IBDANS,IBDGOBAK,IBDTEXT,IBDWORD,IBDY,Y
- W !
- S IBDCOUNT=$G(IBDCOUNT)+1
- S IBDTEXT=$S(IBDCOUNT>1:"another "_IBDFCODE,1:IBDFCODE)
- S (IBDQUIT,IBDGOBAK)=0
- S IBDAUTO=$G(IBDAUTO)
- S DIR("A")="Select "_IBDTEXT_"code"
- S DIR(0)="FO^3:8"
- S DIR("?")="Enter 3 to 8 characters or '??' for more help"
- S DIR("??")="^D HELP^IBDFN4A"
- D ^DIR K DIR
- I Y=""!($G(DTOUT))!(Y="^") D Q
- .I '$D(^TMP("IBDFUTL_TEMP",$J)),'IBDAUTO S IBDQUIT=1
- S IBDANS=$P(Y,U)
- ;Do wildcard search.
- K ^TMP("IBDFUTL_WCSEARCH",$J)
- S IBDAUTO=1
- S IBDY=$$CODELIST^IBDUTICD("10D",IBDANS,"IBDFUTL_WCSEARCH",DT,"",1)
- I +IBDY<1 D
- .S IBDWORD=$P($P(IBDY,U,2)," ")
- .S IBDWORD=$TR($E(IBDWORD,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(IBDWORD,2,99) ;Capitalize first character of text message.
- .S $P(IBDY,U,2)=IBDWORD_" "_$P(IBDY," ",2,99)
- .W !!,$P(IBDY,U,2)_"."
- I +IBDY<1 S:IBDCOUNT=1 IBDCOUNT=0 S IBDAUTO=0 G ICD10
- I $P(IBDY,U,2)=0 D G ICD10
- .W !!,"No data found for selected search, please enter partial code'*' for"
- .W !,"additional selections e.g. E11* ."
- .S:IBDCOUNT=1 IBDCOUNT=0 S IBDAUTO=0
- I +IBDY'<1 D ;
- .S %=1
- .I $P(IBDY,U,2)>1 D
- ..W !!,"There are "_$P(IBDY,U,2)_" ICD-10-CM diagnosis codes that begin with "_IBDANS_". Do you wish to"
- ..W !,"automatically see all of these diagnosis codes on this list"
- ..S %=2 D YN^DICN
- .I $G(DTOUT)!(%=-1) S IBDQUIT=1 Q
- .I %=2 S IBDAUTO=0 K % W !!,"Continue to select from the (# of items in list) ICD-10 diagnoses" S %=2 D YN^DICN I $G(DTOUT)!(%=-1) S IBDQUIT=1 Q
- .I %=2 S IBDGOBAK=1 Q
- .D WCSEARCH(IBDAUTO,.IBDQUIT)
- I IBDGOBAK S IBDCOUNT=0 G ICD10
- I IBDQUIT Q
- I '$D(^TMP("IBDFUTL_TEMP",$J)),'IBDAUTO S IBDCOUNT=0
- K ^TMP("IBDFUTL_SELECTED",$J)
- G ICD10
- Q
- ;
- ;Loop through wildcard search.
- WCSEARCH(IBDAUTO,IBDQUIT) ;
- ;
- N IBDBEGN,IBDCNT,IBDCODE,IBDCONTU,IBDNDEX,IBDNOE,IBDSEL,IBDX
- W !
- S (IBDNDEX,IBDCNT,IBDQUIT,IBDBEGN,IBDNO)=0
- S IBDCONTU=1
- F S IBDNDEX=$O(^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX)) Q:IBDNDEX=""!(IBDQUIT)!('IBDCONTU)!(IBDNO) D ;
- .S IBDNOE=^TMP("IBDFUTL_WCSEARCH",$J,0) ;Number of entries in wildcard search.
- .S IBDCODE=^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX,1)
- .S IBDIEN=+$P(IBDCODE,U) ;+ to resolve both direct and variable pointers
- .S IBDCODE=$P(IBDCODE,U,2)
- .S IBDX=$P($$GETIDX^IBDFN4("10D",IBDCODE,DT),U,2)
- .S IBDCNT=IBDCNT+1
- .I IBDCNT=1 S IBDBEGN=1 I IBDNOE>5,'IBDAUTO W @IOF
- .I IBDAUTO D Q ;User chose to automatically add ICD-10 codes or user only chose 1 ICD code so SELECT tag is by-passed.
- ..S ^TMP("IBDFUTL_TEMP",$J,IBDIEN)=IBDCODE ;Needed for validation check in SET^IBDFUTL1
- ..I IBDNOE=1 D OKPROMPT(1,IBDCODE,IBDX,.IBDQUIT,.IBDNO) ;W !?4,IBDCODE,?15,IBDX
- .;User chose to select which ICD-10 codes he/she wants to add to form.
- .;Set ^TMP global for ICD selections.
- .S ^TMP("IBDFUTL_SELECTED",$J,IBDCNT)=IBDIEN_U_IBDCODE_U_IBDX
- .W !,IBDCNT_".",?4,IBDCODE,?15,IBDX ;Display wildcard selected ICD codes
- .I IBDCNT#22=0 D Q ;Display every 22 ICD codes to user.
- ..D SELECT(IBDBEGN,IBDCNT,.IBDQUIT,.IBDNDEX,.IBDSEL,.IBDCONTU)
- ..S IBDBEGN=IBDCNT+1
- ..;I IBDSEL="",$O(^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX))'="",'IBDQUIT,IBDCONTU W @IOF
- I IBDAUTO!(IBDQUIT)!('IBDCONTU) Q
- D SELECT(IBDBEGN,IBDCNT,.IBDQUIT,IBDNDEX,.IBDSEL,.IBDCONTU) ;Less than 22 ICD codes displayed.
- Q
- ;
- ;Allow user to select a range of ICD codes.
- SELECT(IBDBEGN,IBDCNT,IBDQUIT,IBDNDEX,IBDSEL,IBDCONTU) ;
- N IBDCODE,IBDI,IBDNEXT,IBDNODE,IBDSELN,IBDSKIP,IBDTEXT,IBDTEMP,IBDTEMPY,IBDX
- S IBDSKIP=0
- S IBDSEL=$G(IBDSEL)
- I IBDNDEX'="" S IBDNEXT=$O(^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX))
- K Y
- S DIR("A")="Select ICD-10 DIAGNOSIS CODE or '?' for more help"
- S DIR("?")="press <RETURN> for more or '^' to exit."
- S DIR("?",1)="Enter a single number from the list or range (e.g., 1,3,5 or 2-4,8) or"
- I IBDBEGN'=IBDCNT S DIR(0)="LO^"_IBDBEGN_":"_IBDCNT D ^DIR K DIR
- I $D(DTOUT),'$D(^TMP("IBDFUTL_TEMP")) S IBDQUIT=1 Q
- I $D(DTOUT),$D(^TMP("IBDFUTL_TEMP")) S IBDCONTU=0 Q
- I Y="",$G(IBDNEXT) W @IOF Q
- I Y="^" S IBDSKIP=1 ;User chose to exit out of selection list. Skip next question.
- S IBDTEMPY=Y
- I Y'="^",Y'="" S IBDTEMP=Y
- K Y
- I $G(IBDNEXT),'IBDSKIP D
- .S DIR("A")="Save selections and continue to (# of remaining items) in list"
- .S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR
- .I Y,$D(IBDNEXT) W @IOF
- .I Y=0 S IBDTEMP=""
- S Y=$G(Y)
- I $D(DTOUT) S IBDQUIT=1 Q
- I Y="^"!(Y=0) D
- .I IBDSEL="" S IBDCONTU=0
- Q:'IBDCONTU
- I IBDTEMPY="^",IBDSEL="" S IBDCONTU=0 Q
- I Y'="^",$G(IBDTEMP)'="" S IBDSEL=$G(IBDSEL)_IBDTEMP I $G(IBDNEXT) Q
- I IBDSEL="" Q
- S IBDTEXT=$S($L(IBDSEL,",")=2:"this diagnosis",1:"these diagnoses")
- W !,"Do you really want to select "_IBDTEXT
- S %=2 D YN^DICN
- I $G(DTOUT)!(%=2)!(%=-1) S IBDCONTU=0 Q
- W !
- F IBDI=1:1 Q:$P(IBDSEL,",",IBDI)="" D
- .S IBDSELN=$P(IBDSEL,",",IBDI)
- .S IBDNODE=^TMP("IBDFUTL_SELECTED",$J,IBDSELN)
- .S IBDIEN=$P(IBDNODE,U)
- .S IBDCODE=$P(IBDNODE,U,2)
- .S IBDX=$P(IBDNODE,U,3)
- .S ^TMP("IBDFUTL_TEMP",$J,IBDIEN)=IBDCODE ;Needed for validation check in SET^IBDFUTL1
- S IBDCONTU=0
- Q
- ;Ask user with 'OK? Yes' prompt
- OKPROMPT(IBDONE,IBDCODE,IBDX,IBDQUIT,IBDNO) ;
- N DIR,IBDI
- I '$D(IBDONE) S IBDONE=0
- S DIR("A")="OK? (Yes/No) "
- F IBDI=1:1:4 D
- .I IBDONE D
- ..I IBDI=1 S DIR("A",1)="One code found."
- ..I IBDI=2 S DIR("A",2)=" "
- ..I IBDI=3 S DIR("A",3)=IBDCODE_" "_IBDX
- ..I IBDI=4 S DIR("A",4)=" "
- .I 'IBDONE D
- ..I IBDI=1 S DIR("A",1)=" "
- ..I IBDI=2 S DIR("A",2)=IBDCODE_" "_IBDX
- ..I IBDI=3 S DIR("A",3)=" "
- S DIR(0)="YAO",DIR("B")="Yes" D ^DIR K DIR
- W !
- I $D(DUOUT)!($D(DTOUT)) S IBDQUIT=1 Q
- I Y=0 S IBDNO=1 W !,"Code unselected from list."
- Q
- ;
- ;determine coding system
- ; return ICD-9 or ICD-10 or null
- GETCODSY(IBDFINT) ;
- Q $S($P($G(^IBE(357.6,IBDFINT,0)),"^")["ICD-9":"ICD-9 ",$P($G(^IBE(357.6,IBDFINT,0)),"^")["ICD-10":"ICD-10 ",1:"")
- ;IBDFUTL
- SETSRT(IBDFDIS) ;IBD*3.0*70 - Set VA variables
- S:IBDFDIS="CLIN" VAUTC=^XTMP("IBDRPT",2)
- S:IBDFDIS="GROUP" VAUTG=^XTMP("IBDRPT",2)
- S:IBDFDIS="FORM" VAUTF=^XTMP("IBDRPT",2)
- Q
- SETIBDF(IBDF) ;Set up IBDF array from ^XTMP("IBDF") global, IBD*3.0*70
- N IBDX
- S IBDX=0 F S IBDX=$O(^XTMP("IBDF",IBDX)) Q:IBDX="" S IBDF(IBDX)=^XTMP("IBDF",IBDX)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFUTL 16460 printed Feb 19, 2025@00:20:13 Page 2
- IBDFUTL ;ALB/MAF - Maintenance Utility Routine ;04/20/95
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,32,51,63,70**;APR 24, 1997;Build 46
- +2 ;
- +3 ;ICRs
- +4 ; Reference to LS^ICDEX supported by ICR #5747
- +5 ; Reference to CSI^ICDEX supported by ICR #5747
- +6 ;
- EN ;IBD*3.0*70 - New Maintenance Utility Option Entry Point
- +1 ;Check if ^XTMP global exists. If so, Give user the option to use the last report or run a new one
- +2 NEW IBDLR,IBDFDIS,IBDFINT,IBDDUZ,IBDN,IBDIA,IBDST,IBDFACT,IBDSTR,IBDAI,IBDF
- +3 LOCK +^XTMP("IBDRPT"):$GET(DILOCKTM,5)
- IF '$TEST
- WRITE !!,"The Maintenance Utility is locked by another user or currently running in the background. Please try again later.",!
- QUIT
- +4 IF '$DATA(^XTMP("IBDRPT",0))!('$DATA(^XTMP("IBDRPT",1)))!('$DATA(^XTMP("IBDRPT",2)))
- WRITE !,"The Maintenance Utility must be run."
- DO OUT
- QUIT
- +5 SET IBDLR=$PIECE($GET(^XTMP("IBDRPT",0)),U,2)
- IF IBDLR
- Begin DoDot:1
- +6 SET IBDFDIS=$PIECE(^XTMP("IBDRPT",1),U,2)
- SET IBDFINT=$PIECE(^XTMP("IBDRPT",1),U,3)
- SET IBDAI=$PIECE(^IBE(357.6,IBDFINT,0),U)
- SET IBDDUZ=$PIECE(^XTMP("IBDRPT",1),U)
- SET IBDN=$SELECT(^XTMP("IBDRPT",2):"all",1:"select")
- +7 SET IBDIA=$SELECT($PIECE(^XTMP("IBDRPT",1),U,4)=1:"ACTIVE",$PIECE(^XTMP("IBDRPT",1),U,4)=2:"INACTIVE",1:"")
- +8 WRITE !
- FOR IBDSTR=1:1:80
- WRITE "*"
- +9 WRITE !,"The current report on file was run by ",$$GET1^DIQ(200,IBDDUZ,.01)," on ",$$FMTE^XLFDT(IBDLR),"."
- +10 WRITE !,"It is for ",IBDAI," and sorted by ",$SELECT(IBDFDIS="CLIN":"CLINIC",1:IBDFDIS)
- +11 WRITE !,"The report contains ",IBDIA," codes."
- +12 if IBDN'=""
- WRITE !,"The report is for ",$SELECT(IBDN="all":"all "_$SELECT(IBDFDIS="CLIN":"CLINIC",1:IBDFDIS)_"S.",1:"the following "_$SELECT(IBDFDIS="CLIN":"CLINIC",1:IBDFDIS)_"S.")
- IF IBDN'="all"
- Begin DoDot:2
- +13 SET IBDST=0
- FOR
- SET IBDST=$ORDER(^XTMP("IBDRPT",2,IBDST))
- if 'IBDST
- QUIT
- WRITE !,^XTMP("IBDRPT",2,IBDST)
- End DoDot:2
- +14 WRITE !
- FOR IBDSTR=1:1:80
- WRITE "*"
- +15 SET DIR(0)="Y"
- SET DIR("A")="Would you like to view this report"
- SET DIR("B")="Yes"
- DO ^DIR
- IF Y
- KILL XQORS,VALMEVL
- DO SETIBDF(.IBDF)
- SET IBDFACT=$PIECE(^XTMP("IBDRPT",1),U,4)
- DO SETSRT(IBDFDIS)
- DO EN^VALM("IBDF UTIL PRIMARY SCREEN")
- QUIT
- +16 if $DATA(DIRUT)
- QUIT
- SET DIR(0)="Y"
- SET DIR("A")="This will delete the current report and run a new one. Are you sure"
- DO ^DIR
- IF Y
- DO OUT
- QUIT
- +17 WRITE !,"The Maintenance Utility will not be run."
- QUIT
- End DoDot:1
- +18 QUIT
- +19 ;
- +20 ; -- Set up variables for display by clinic/form/group
- OUT ;W !!,"Display output by: CLINICS// " D ZSET1 S X="" R X:DTIME G QUIT:X="^"!('$T) I X=""!("Cc"[X) S X="1"
- SET IBDFL=0
- +1 SET DIR("B")="CLINICS"
- +2 ;S DIR(0)="SBM^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS"
- +3 SET DIR(0)="SA^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS"
- +4 SET DIR("A")="Sort by [C]linics, [G]roups, [F]orms: "
- DO ^DIR
- +5 KILL DIR
- IF $DATA(DIRUT)&('$DATA(IBDF1))!(Y<0)
- GOTO EXIT
- +6 IF $DATA(DIRUT)&$DATA(IBDF1)
- GOTO QUIT
- +7 SET X=$SELECT("Gg"[X:2,"Ff"[X:3,"Ss"[X:4,1:1)
- +8 ;I X="?" D ZSET1,HELP1 G OUT
- +9 ;D IN^DGHELP W ! I %=-1 D ZSET1,HELP1 G OUT
- SET IBDFSRT=$EXTRACT(X)
- +10 SET IBDFDIS=$SELECT(IBDFSRT=1:"CLIN",IBDFSRT=2:"GROUP",IBDFSRT=3:"FORM",1:"QUIT")
- +11 DO @(IBDFDIS)
- if Y=-1
- SET IBDFNCNG=1
- if Y=-1
- GOTO QUIT
- +12 ;
- +13 ;
- OUT1 ; -- Ask for what type of package interface
- +1 NEW IBDTEMPY,IBDQUIT,IBDFINT,IBDCOUNT,IBDAUTO,IBDX,IBDQUI2,ZTRTN,ZTDESC,ZTSAVE,IBDQUE
- +2 SET DIC="^IBE(357.6,"
- SET DIC(0)="AEMN"
- +3 SET DIC("S")="I $P(^(0),U,6)=3,$P(^(0),U,9)=1,$G(^(11))'="""""
- +4 SET DIC("A")="Select Type of Code to Display: "
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO QUIT
- +5 SET IBDFINT=+Y
- +6 ;
- +7 ;default of Inactive
- SET IBDFACT=2
- +8 SET X=$EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)
- +9 ;
- +10 ; -- for cpt and icd codes, let them choose active or inactive
- +11 IF X="CPT"!(X="VST")!(X="ICD")
- Begin DoDot:1
- +12 SET DIR("B")="ACTIVE"
- +13 ;S DIR(0)="SBM^A:ACTIVE;I:INACTIVE"
- +14 SET DIR(0)="SA^A:ACTIVE;I:INACTIVE"
- +15 SET DIR("A")="Display codes [A]ctive, [I]nactive: "
- +16 DO ^DIR
- KILL DIR
- +17 if $DATA(DIRUT)
- QUIT
- +18 SET X=$SELECT("Ii"[$EXTRACT(X,1):2,1:1)
- +19 SET IBDFACT=$EXTRACT(X)
- End DoDot:1
- +20 IF $DATA(DIRUT)&('$DATA(IBDF1))!(Y<0)
- GOTO EXIT
- +21 IF $DATA(DIRUT)&$DATA(IBDF1)
- GOTO QUIT
- +22 ;IBD*3.0*70 - set up XTMP global with Report Info
- +23 KILL ^XTMP("IBDRPT"),^XTMP("CPTIDX"),^XTMP("IBDCPT"),^XTMP("IBDF")
- +24 SET ^XTMP("IBDRPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility rpt global"
- SET ^XTMP("IBDRPT",1)=DUZ_U_IBDFDIS_U_IBDFINT_U_IBDFACT
- +25 SET ^XTMP("CPTIDX",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility CPTIDX global"
- +26 SET ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
- +27 SET ^XTMP("IBDF",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDF global"
- +28 SET IBDTYP=$SELECT($DATA(VAUTC):"VAUTC",$DATA(VAUTF):"VAUTF",$DATA(VAUTG):"VAUTG",1:"")
- SET ^XTMP("IBDRPT",2)=@IBDTYP
- IF ^XTMP("IBDRPT",2)=0
- MERGE ^XTMP("IBDRPT",2)=@IBDTYP
- +29 ;cannot use this option before ICD-10 impelemenation
- +30 ;
- +31 IF $EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)="ICD"
- IF DT<$$IMPDATE^IBDUTICD(30)
- IF $$GETCODSY(IBDFINT)["ICD-10"
- IF IBDFACT=1
- Begin DoDot:1
- +32 FOR
- Begin DoDot:2
- +33 WRITE !!,"ICD-10 codes cannot be selected for this option before ICD-10 activation.",!
- +34 SET DIR(0)="FAO"
- SET DIR("A")="Press RETURN to continue..."
- DO ^DIR
- KILL DIR
- +35 SET IBDQUI2=$$ACTPRMT^IBDUTICD()
- End DoDot:2
- if IBDQUI2'="A"
- QUIT
- End DoDot:1
- if IBDQUI2<0
- GOTO EXIT
- if IBDQUI2="I"
- SET IBDFACT=2
- +36 ;
- +37 IF $DATA(IBDF1)
- Begin DoDot:1
- +38 KILL VAUTP
- FOR IBI=0:0
- SET IBI=$ORDER(VAUTJ(IBI))
- if IBI']""
- QUIT
- SET VAUTP(IBI)=$GET(VAUTJ(IBI))
- End DoDot:1
- +39 ;
- +40 ;
- +41 ;
- +42 IF IBDFACT=1
- Begin DoDot:1
- +43 ;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC="^ICPT(",IBDFCODE="CPT "
- +44 ;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" S DIC="^ICD9(",IBDFCODE="ICD-9 "
- +45 ;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC="^IBE(357.69,",IBDFCODE="Type of Visit "
- +46 ;
- +47 IF $EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)="CPT"
- SET DIC="^ICPT("
- SET IBDFCODE="CPT "
- SET DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- +48 ;
- +49 ;Change variable IBDFCODE to "ICD-9" or "ICD-10"
- +50 ;
- IF $EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)="ICD"
- Begin DoDot:2
- +51 SET IBDFCODE=$$GETCODSY(IBDFINT)
- +52 SET DIC="^ICD9("
- End DoDot:2
- +53 ;
- +54 IF $EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)="VST"
- SET DIC="^IBE(357.69,"
- SET IBDFCODE="Type of Visit "
- SET DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- +55 ;
- +56 ;ICD-9 only
- +57 IF $GET(DIC)]""
- IF $GET(IBDFCODE)["ICD-9"
- Begin DoDot:2
- +58 ;ICD9 date
- NEW IBDICD9D
- +59 SET IBDICD9D=$$IMPDATE^IBDUTICD(1)
- +60 SET DIC("S")="I $$LS^ICDEX(80,+Y,IBDICD9D)>0,$$CSI^ICDEX(80,+Y)=1"
- +61 DO EN1^IBDVAUT1("VAUTJ",2,IBDFCODE_"code",1)
- End DoDot:2
- QUIT
- +62 ;ICD-10 only
- +63 IF $GET(DIC)]""
- IF $GET(IBDFCODE)["ICD-10"
- SET VAUTVB="VAUTJ"
- SET IBDTEMPY=Y
- DO ICD10
- SET Y=IBDTEMPY
- QUIT
- +64 ;
- +65 ;CPT and VST only
- +66 IF $GET(DIC)]""
- SET VAUTVB="VAUTJ"
- SET VAUTNI=2
- SET VAUTSTR=IBDFCODE_"code"
- SET VAUTNALL=1
- DO FIRST^VAUTOMA
- End DoDot:1
- +67 ;
- +68 IF IBDFACT=2
- Begin DoDot:1
- +69 SET IBDFCODE=$$GETCODSY(IBDFINT)
- End DoDot:1
- +70 IF (Y<0)&$DATA(IBDF1)
- Begin DoDot:1
- +71 FOR IBI=0:0
- SET IBI=$ORDER(VAUTP(IBI))
- if IBI']""
- QUIT
- SET VAUTJ(IBI)=$GET(VAUTP(IBI))
- End DoDot:1
- KILL VAUTP
- GOTO QUIT
- +72 IF IBDFACT=1
- IF Y<0
- IF '$DATA(IBDF1)
- GOTO EXIT
- +73 IF IBDFACT=1
- IF $GET(IBDQUIT)
- GOTO EXIT
- +74 ;
- +75 ;Allow Report to be Queued - IBD*3.0*70
- +76 LOCK -^XTMP("IBDRPT")
- +77 SET DIR(0)="Y"
- SET DIR("A")="Would you like to queue this report and run it in the background"
- SET DIR("B")="Yes"
- DO ^DIR
- +78 IF Y
- SET IBDQUE=1
- SET ZTRTN="OUT2^IBDFUTL"
- SET ZTDESC="Maintenance Utility background job"
- SET ZTSAVE("*")=""
- SET ZTIO="NULL"
- DO ^%ZTLOAD
- QUIT
- OUT2 ;Tasked entry point
- +1 LOCK +^XTMP("IBDRPT"):$GET(DILOCKTM,5)
- if '$TEST
- QUIT
- +2 IF $GET(IBDQUE)
- SET VALMEVL=$SELECT($DATA(VALMEVL):VALMEVL+1,1:0)
- DO INIT
- SET VALMBCK="R"
- SET VALMBG=1
- QUIT
- +3 IF '$DATA(IBDF1)
- KILL XQORS,VALMEVL
- DO EN^VALM("IBDF UTIL PRIMARY SCREEN")
- +4 IF $DATA(IBDF1)
- DO HDR
- DO KILL
- DO INIT
- SET VALMBCK="R"
- SET VALMBG=1
- +5 QUIT
- +6 ;
- HDR ; -- header code
- +1 IF IBDFACT=1
- Begin DoDot:1
- +2 SET VALMHDR(1)="This screen lists Active codes on Encounter Forms."
- End DoDot:1
- +3 IF IBDFACT'=1
- Begin DoDot:1
- +4 SET VALMHDR(1)="This screen lists Inactive codes on Encounter Forms."
- End DoDot:1
- +5 QUIT
- +6 ;
- +7 ; -- Set up list
- INIT DO FULL^VALM1
- SET (IBDCNT,IBDCNT1,VALMCNT)=0
- +1 NEW IBDX
- +2 DO KILL^VALM10()
- +3 IF '$ORDER(^XTMP("IBDCPT",0))
- SET IBDFCNT1=0
- DO @(IBDFDIS_"1^IBDFUTL1")
- +4 IF '$ORDER(^XTMP("IBDCPT",0))
- DO NUL
- +5 IF $ORDER(^XTMP("IBDCPT",0))
- IF '$GET(VALMCNT)
- KILL ^TMP("IBDCPT1",$JOB)
- SET VALMCNT=0
- SET IBDX=0
- FOR
- SET IBDX=$ORDER(^XTMP("IBDCPT",IBDX))
- if 'IBDX
- QUIT
- SET VALMCNT=VALMCNT+1
- Begin DoDot:1
- +6 SET ^TMP("IBDCPT1",$JOB,VALMCNT,0)=^XTMP("IBDCPT",IBDX,0)
- MERGE ^TMP("IBDCPT1",$JOB,"IDX",VALMCNT)=^XTMP("IBDCPT","IDX",IBDX)
- End DoDot:1
- +7 IF $DATA(^TMP("IBDCPT1",$JOB))
- KILL ^XTMP("IBDCPT")
- MERGE ^XTMP("IBDCPT")=^TMP("IBDCPT1",$JOB)
- KILL ^TMP("IBDCPT1",$JOB)
- +8 IF '$DATA(^XTMP("IBDCPT",0))
- SET ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
- +9 QUIT
- +10 ;
- +11 ; -- Ask for clinics one/many/all
- CLIN SET VAUTVB="VAUTC"
- SET DIC="^SC("
- SET DIC("S")="I $P(^(0),U,3)=""C"""
- SET VAUTSTR="Clinic"
- SET VAUTNI=2
- DO FIRST^VAUTOMA
- KILL DIC
- if Y=-1
- SET IBDFL=1
- if IBDFL
- QUIT
- +1 QUIT
- +2 ;
- +3 ; -- Ask for forms one/many/all
- FORM SET VAUTVB="VAUTF"
- SET DIC="^IBE(357,"
- SET VAUTSTR="Form"
- SET VAUTNI=2
- DO FIRST^VAUTOMA
- if Y=-1
- SET IBDFL=1
- if IBDFL
- QUIT
- +1 QUIT
- +2 ;
- +3 ; -- Ask for clinic groups one/many/all
- GROUP SET VAUTVB="VAUTG"
- SET DIC="^IBD(357.99,"
- SET VAUTSTR="Clinic Group"
- SET VAUTNI=2
- DO FIRST^VAUTOMA
- if Y=-1
- SET IBDFL=1
- if IBDFL
- QUIT
- +1 QUIT
- +2 ;
- +3 ; -- Ask for divisions one/many/all
- DIV SET IBDFL=0
- DO DIVISION^VAUTOMA
- +1 if Y=-1
- SET IBDFL=1
- if IBDFL
- QUIT
- +2 QUIT
- +3 ; -- Help for display choices
- HELP1 WRITE !!,"Choose a number or first initial :"
- FOR K=2:1:4
- WRITE !?15,$PIECE(Z,"^",K)
- +1 WRITE !
- QUIT
- +2 ;
- +3 ; -- Listing of selections
- ZSET1 SET Z="^1 [C]LINICS (Individual)^2 [G]ROUPS (CLINIC)^3 [F]ORMS^"
- QUIT
- +1 ;
- +2 ;
- QUIT ; -- Kill variables and reset to last display if no change has been taken place.
- +1 IF $DATA(IBDF1)
- SET IBDFDIS=IBDFDIS1
- SET IBDFINT=IBDFINT1
- SET IBDFACT=IBDFACT1
- +2 IF '$DATA(IBDF1)
- GOTO EXIT
- +3 DO KILL
- DO INIT
- KILL IBDFNCNG
- SET VALMBCK="R"
- SET VALMBG=1
- +4 QUIT
- +5 ;
- +6 ;
- KILL ; -- Kill extra array variables
- +1 NEW IBDFXX
- +2 SET IBDFXX=$SELECT(IBDFDIS="FORM":"VAUTF",IBDFDIS="GROUP":"VAUTG",1:"VAUTC")
- +3 IF IBDFXX="VAUTF"
- KILL VAUTG,VAUTC,^TMP("CLN",$JOB),^TMP("CLN1",$JOB),^TMP("GRP",$JOB),^TMP("GRP1",$JOB)
- +4 IF IBDFXX="VAUTC"
- KILL VAUTG,VAUTF,^TMP("FRM",$JOB),^TMP("FRM1",$JOB),^TMP("GRP1",$JOB)
- +5 IF IBDFXX="VAUTG"
- KILL VAUTC,VAUTF,^TMP("FRM",$JOB),^TMP("FRM1",$JOB),^TMP("CLN",$JOB),^TMP("CLN1",$JOB)
- +6 QUIT
- +7 ;
- +8 ;
- EXIT ; -- Code executed at action exit
- +1 KILL IBDFDIS,IBDFINT,VAUTC,VAUTF,VAUTG,VAUTJ,VAUTP,IBDFINT1,IBDFDIS1,^TMP("CLN",$JOB),IBDFCODE,IBI,IBDFACT1
- EXIT1 KILL DIC,IBDBLK,IBDCLN,IBDCLNM,IBDCNODE,IBDCNT,IBDCNT1,IBDF,IBDFBK,IBDFCIFN,IBDFCLIN,IBDFL,IBDFLG,IBDFN,IBDFNAME,IBDFNM,IBDFNODE,IBDFORM1,IBDFRM,IBDFSEL,IBDFSRT,IBDFTMP,IBDFVAL
- +1 KILL IBDFX,IBDORM,IBDVAL,IBDVAL1,IBDFCNT1,Z,IBDFRNM,IBDFX1,IBDFX2,IBDFX3
- +2 KILL IBCLN,IBDFCLN,IBDFCLNM,IBDFDIV,IBDFGIFN,IBDFGN,IBDFGNM,IBDIV,IBDNAM,IBDNAME,IEN,^TMP("IBDF",$JOB),^TMP("UTIL",$JOB),DIVISION,IBDF,IBDFACT,VAUTNALL
- +3 KILL ^TMP("IBDFUTL_SELECTED",$JOB),^TMP("IBDFUTL_TEMP",$JOB),^TMP("IBDFUTL_WCSEARCH",$JOB)
- +4 LOCK -^XTMP("IBDRPT")
- +5 QUIT
- +6 ;
- HLP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- +4 ;
- EXP ; -- expand code
- +1 QUIT
- NUL ; -- NULL MESSAGE
- +1 SET ^XTMP("IBDCPT",1,0)=" "
- SET ^XTMP("IBDCPT",2,0)="There are no "_$SELECT(IBDFACT=1:"active",1:"inactive")_" codes on any forms."
- SET ^XTMP("CPTIDX",1)=1
- SET ^XTMP("CPTIDX",2)=2
- +2 QUIT
- +3 ;--------- new code for ICD-10
- ICD10 ; Wildcard search for ICD-10 codes
- +1 ;
- +2 NEW %,DIR,IBDANS,IBDGOBAK,IBDTEXT,IBDWORD,IBDY,Y
- +3 WRITE !
- +4 SET IBDCOUNT=$GET(IBDCOUNT)+1
- +5 SET IBDTEXT=$SELECT(IBDCOUNT>1:"another "_IBDFCODE,1:IBDFCODE)
- +6 SET (IBDQUIT,IBDGOBAK)=0
- +7 SET IBDAUTO=$GET(IBDAUTO)
- +8 SET DIR("A")="Select "_IBDTEXT_"code"
- +9 SET DIR(0)="FO^3:8"
- +10 SET DIR("?")="Enter 3 to 8 characters or '??' for more help"
- +11 SET DIR("??")="^D HELP^IBDFN4A"
- +12 DO ^DIR
- KILL DIR
- +13 IF Y=""!($GET(DTOUT))!(Y="^")
- Begin DoDot:1
- +14 IF '$DATA(^TMP("IBDFUTL_TEMP",$JOB))
- IF 'IBDAUTO
- SET IBDQUIT=1
- End DoDot:1
- QUIT
- +15 SET IBDANS=$PIECE(Y,U)
- +16 ;Do wildcard search.
- +17 KILL ^TMP("IBDFUTL_WCSEARCH",$JOB)
- +18 SET IBDAUTO=1
- +19 SET IBDY=$$CODELIST^IBDUTICD("10D",IBDANS,"IBDFUTL_WCSEARCH",DT,"",1)
- +20 IF +IBDY<1
- Begin DoDot:1
- +21 SET IBDWORD=$PIECE($PIECE(IBDY,U,2)," ")
- +22 ;Capitalize first character of text message.
- SET IBDWORD=$TRANSLATE($EXTRACT(IBDWORD,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(IBDWORD,2,99)
- +23 SET $PIECE(IBDY,U,2)=IBDWORD_" "_$PIECE(IBDY," ",2,99)
- +24 WRITE !!,$PIECE(IBDY,U,2)_"."
- End DoDot:1
- +25 IF +IBDY<1
- if IBDCOUNT=1
- SET IBDCOUNT=0
- SET IBDAUTO=0
- GOTO ICD10
- +26 IF $PIECE(IBDY,U,2)=0
- Begin DoDot:1
- +27 WRITE !!,"No data found for selected search, please enter partial code'*' for"
- +28 WRITE !,"additional selections e.g. E11* ."
- +29 if IBDCOUNT=1
- SET IBDCOUNT=0
- SET IBDAUTO=0
- End DoDot:1
- GOTO ICD10
- +30 ;
- IF +IBDY'<1
- Begin DoDot:1
- +31 SET %=1
- +32 IF $PIECE(IBDY,U,2)>1
- Begin DoDot:2
- +33 WRITE !!,"There are "_$PIECE(IBDY,U,2)_" ICD-10-CM diagnosis codes that begin with "_IBDANS_". Do you wish to"
- +34 WRITE !,"automatically see all of these diagnosis codes on this list"
- +35 SET %=2
- DO YN^DICN
- End DoDot:2
- +36 IF $GET(DTOUT)!(%=-1)
- SET IBDQUIT=1
- QUIT
- +37 IF %=2
- SET IBDAUTO=0
- KILL %
- WRITE !!,"Continue to select from the (# of items in list) ICD-10 diagnoses"
- SET %=2
- DO YN^DICN
- IF $GET(DTOUT)!(%=-1)
- SET IBDQUIT=1
- QUIT
- +38 IF %=2
- SET IBDGOBAK=1
- QUIT
- +39 DO WCSEARCH(IBDAUTO,.IBDQUIT)
- End DoDot:1
- +40 IF IBDGOBAK
- SET IBDCOUNT=0
- GOTO ICD10
- +41 IF IBDQUIT
- QUIT
- +42 IF '$DATA(^TMP("IBDFUTL_TEMP",$JOB))
- IF 'IBDAUTO
- SET IBDCOUNT=0
- +43 KILL ^TMP("IBDFUTL_SELECTED",$JOB)
- +44 GOTO ICD10
- +45 QUIT
- +46 ;
- +47 ;Loop through wildcard search.
- WCSEARCH(IBDAUTO,IBDQUIT) ;
- +1 ;
- +2 NEW IBDBEGN,IBDCNT,IBDCODE,IBDCONTU,IBDNDEX,IBDNOE,IBDSEL,IBDX
- +3 WRITE !
- +4 SET (IBDNDEX,IBDCNT,IBDQUIT,IBDBEGN,IBDNO)=0
- +5 SET IBDCONTU=1
- +6 ;
- FOR
- SET IBDNDEX=$ORDER(^TMP("IBDFUTL_WCSEARCH",$JOB,IBDNDEX))
- if IBDNDEX=""!(IBDQUIT)!('IBDCONTU)!(IBDNO)
- QUIT
- Begin DoDot:1
- +7 ;Number of entries in wildcard search.
- SET IBDNOE=^TMP("IBDFUTL_WCSEARCH",$JOB,0)
- +8 SET IBDCODE=^TMP("IBDFUTL_WCSEARCH",$JOB,IBDNDEX,1)
- +9 ;+ to resolve both direct and variable pointers
- SET IBDIEN=+$PIECE(IBDCODE,U)
- +10 SET IBDCODE=$PIECE(IBDCODE,U,2)
- +11 SET IBDX=$PIECE($$GETIDX^IBDFN4("10D",IBDCODE,DT),U,2)
- +12 SET IBDCNT=IBDCNT+1
- +13 IF IBDCNT=1
- SET IBDBEGN=1
- IF IBDNOE>5
- IF 'IBDAUTO
- WRITE @IOF
- +14 ;User chose to automatically add ICD-10 codes or user only chose 1 ICD code so SELECT tag is by-passed.
- IF IBDAUTO
- Begin DoDot:2
- +15 ;Needed for validation check in SET^IBDFUTL1
- SET ^TMP("IBDFUTL_TEMP",$JOB,IBDIEN)=IBDCODE
- +16 ;W !?4,IBDCODE,?15,IBDX
- IF IBDNOE=1
- DO OKPROMPT(1,IBDCODE,IBDX,.IBDQUIT,.IBDNO)
- End DoDot:2
- QUIT
- +17 ;User chose to select which ICD-10 codes he/she wants to add to form.
- +18 ;Set ^TMP global for ICD selections.
- +19 SET ^TMP("IBDFUTL_SELECTED",$JOB,IBDCNT)=IBDIEN_U_IBDCODE_U_IBDX
- +20 ;Display wildcard selected ICD codes
- WRITE !,IBDCNT_".",?4,IBDCODE,?15,IBDX
- +21 ;Display every 22 ICD codes to user.
- IF IBDCNT#22=0
- Begin DoDot:2
- +22 DO SELECT(IBDBEGN,IBDCNT,.IBDQUIT,.IBDNDEX,.IBDSEL,.IBDCONTU)
- +23 SET IBDBEGN=IBDCNT+1
- +24 ;I IBDSEL="",$O(^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX))'="",'IBDQUIT,IBDCONTU W @IOF
- End DoDot:2
- QUIT
- End DoDot:1
- +25 IF IBDAUTO!(IBDQUIT)!('IBDCONTU)
- QUIT
- +26 ;Less than 22 ICD codes displayed.
- DO SELECT(IBDBEGN,IBDCNT,.IBDQUIT,IBDNDEX,.IBDSEL,.IBDCONTU)
- +27 QUIT
- +28 ;
- +29 ;Allow user to select a range of ICD codes.
- SELECT(IBDBEGN,IBDCNT,IBDQUIT,IBDNDEX,IBDSEL,IBDCONTU) ;
- +1 NEW IBDCODE,IBDI,IBDNEXT,IBDNODE,IBDSELN,IBDSKIP,IBDTEXT,IBDTEMP,IBDTEMPY,IBDX
- +2 SET IBDSKIP=0
- +3 SET IBDSEL=$GET(IBDSEL)
- +4 IF IBDNDEX'=""
- SET IBDNEXT=$ORDER(^TMP("IBDFUTL_WCSEARCH",$JOB,IBDNDEX))
- +5 KILL Y
- +6 SET DIR("A")="Select ICD-10 DIAGNOSIS CODE or '?' for more help"
- +7 SET DIR("?")="press <RETURN> for more or '^' to exit."
- +8 SET DIR("?",1)="Enter a single number from the list or range (e.g., 1,3,5 or 2-4,8) or"
- +9 IF IBDBEGN'=IBDCNT
- SET DIR(0)="LO^"_IBDBEGN_":"_IBDCNT
- DO ^DIR
- KILL DIR
- +10 IF $DATA(DTOUT)
- IF '$DATA(^TMP("IBDFUTL_TEMP"))
- SET IBDQUIT=1
- QUIT
- +11 IF $DATA(DTOUT)
- IF $DATA(^TMP("IBDFUTL_TEMP"))
- SET IBDCONTU=0
- QUIT
- +12 IF Y=""
- IF $GET(IBDNEXT)
- WRITE @IOF
- QUIT
- +13 ;User chose to exit out of selection list. Skip next question.
- IF Y="^"
- SET IBDSKIP=1
- +14 SET IBDTEMPY=Y
- +15 IF Y'="^"
- IF Y'=""
- SET IBDTEMP=Y
- +16 KILL Y
- +17 IF $GET(IBDNEXT)
- IF 'IBDSKIP
- Begin DoDot:1
- +18 SET DIR("A")="Save selections and continue to (# of remaining items) in list"
- +19 SET DIR(0)="Y"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- +20 IF Y
- IF $DATA(IBDNEXT)
- WRITE @IOF
- +21 IF Y=0
- SET IBDTEMP=""
- End DoDot:1
- +22 SET Y=$GET(Y)
- +23 IF $DATA(DTOUT)
- SET IBDQUIT=1
- QUIT
- +24 IF Y="^"!(Y=0)
- Begin DoDot:1
- +25 IF IBDSEL=""
- SET IBDCONTU=0
- End DoDot:1
- +26 if 'IBDCONTU
- QUIT
- +27 IF IBDTEMPY="^"
- IF IBDSEL=""
- SET IBDCONTU=0
- QUIT
- +28 IF Y'="^"
- IF $GET(IBDTEMP)'=""
- SET IBDSEL=$GET(IBDSEL)_IBDTEMP
- IF $GET(IBDNEXT)
- QUIT
- +29 IF IBDSEL=""
- QUIT
- +30 SET IBDTEXT=$SELECT($LENGTH(IBDSEL,",")=2:"this diagnosis",1:"these diagnoses")
- +31 WRITE !,"Do you really want to select "_IBDTEXT
- +32 SET %=2
- DO YN^DICN
- +33 IF $GET(DTOUT)!(%=2)!(%=-1)
- SET IBDCONTU=0
- QUIT
- +34 WRITE !
- +35 FOR IBDI=1:1
- if $PIECE(IBDSEL,",",IBDI)=""
- QUIT
- Begin DoDot:1
- +36 SET IBDSELN=$PIECE(IBDSEL,",",IBDI)
- +37 SET IBDNODE=^TMP("IBDFUTL_SELECTED",$JOB,IBDSELN)
- +38 SET IBDIEN=$PIECE(IBDNODE,U)
- +39 SET IBDCODE=$PIECE(IBDNODE,U,2)
- +40 SET IBDX=$PIECE(IBDNODE,U,3)
- +41 ;Needed for validation check in SET^IBDFUTL1
- SET ^TMP("IBDFUTL_TEMP",$JOB,IBDIEN)=IBDCODE
- End DoDot:1
- +42 SET IBDCONTU=0
- +43 QUIT
- +44 ;Ask user with 'OK? Yes' prompt
- OKPROMPT(IBDONE,IBDCODE,IBDX,IBDQUIT,IBDNO) ;
- +1 NEW DIR,IBDI
- +2 IF '$DATA(IBDONE)
- SET IBDONE=0
- +3 SET DIR("A")="OK? (Yes/No) "
- +4 FOR IBDI=1:1:4
- Begin DoDot:1
- +5 IF IBDONE
- Begin DoDot:2
- +6 IF IBDI=1
- SET DIR("A",1)="One code found."
- +7 IF IBDI=2
- SET DIR("A",2)=" "
- +8 IF IBDI=3
- SET DIR("A",3)=IBDCODE_" "_IBDX
- +9 IF IBDI=4
- SET DIR("A",4)=" "
- End DoDot:2
- +10 IF 'IBDONE
- Begin DoDot:2
- +11 IF IBDI=1
- SET DIR("A",1)=" "
- +12 IF IBDI=2
- SET DIR("A",2)=IBDCODE_" "_IBDX
- +13 IF IBDI=3
- SET DIR("A",3)=" "
- End DoDot:2
- End DoDot:1
- +14 SET DIR(0)="YAO"
- SET DIR("B")="Yes"
- DO ^DIR
- KILL DIR
- +15 WRITE !
- +16 IF $DATA(DUOUT)!($DATA(DTOUT))
- SET IBDQUIT=1
- QUIT
- +17 IF Y=0
- SET IBDNO=1
- WRITE !,"Code unselected from list."
- +18 QUIT
- +19 ;
- +20 ;determine coding system
- +21 ; return ICD-9 or ICD-10 or null
- GETCODSY(IBDFINT) ;
- +1 QUIT $SELECT($PIECE($GET(^IBE(357.6,IBDFINT,0)),"^")["ICD-9":"ICD-9 ",$PIECE($GET(^IBE(357.6,IBDFINT,0)),"^")["ICD-10":"ICD-10 ",1:"")
- +2 ;IBDFUTL
- SETSRT(IBDFDIS) ;IBD*3.0*70 - Set VA variables
- +1 if IBDFDIS="CLIN"
- SET VAUTC=^XTMP("IBDRPT",2)
- +2 if IBDFDIS="GROUP"
- SET VAUTG=^XTMP("IBDRPT",2)
- +3 if IBDFDIS="FORM"
- SET VAUTF=^XTMP("IBDRPT",2)
- +4 QUIT
- SETIBDF(IBDF) ;Set up IBDF array from ^XTMP("IBDF") global, IBD*3.0*70
- +1 NEW IBDX
- +2 SET IBDX=0
- FOR
- SET IBDX=$ORDER(^XTMP("IBDF",IBDX))
- if IBDX=""
- QUIT
- SET IBDF(IBDX)=^XTMP("IBDF",IBDX)
- +3 QUIT