Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFUTL

IBDFUTL.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;ICRs
  1. ; Reference to LS^ICDEX supported by ICR #5747
  1. ; Reference to CSI^ICDEX supported by ICR #5747
  1. ;
  1. 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
  1. N IBDLR,IBDFDIS,IBDFINT,IBDDUZ,IBDN,IBDIA,IBDST,IBDFACT,IBDSTR,IBDAI,IBDF
  1. 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
  1. I '$D(^XTMP("IBDRPT",0))!('$D(^XTMP("IBDRPT",1)))!('$D(^XTMP("IBDRPT",2))) W !,"The Maintenance Utility must be run." D OUT Q
  1. S IBDLR=$P($G(^XTMP("IBDRPT",0)),U,2) I IBDLR D
  1. .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")
  1. .S IBDIA=$S($P(^XTMP("IBDRPT",1),U,4)=1:"ACTIVE",$P(^XTMP("IBDRPT",1),U,4)=2:"INACTIVE",1:"")
  1. .W ! F IBDSTR=1:1:80 W "*"
  1. .W !,"The current report on file was run by ",$$GET1^DIQ(200,IBDDUZ,.01)," on ",$$FMTE^XLFDT(IBDLR),"."
  1. .W !,"It is for ",IBDAI," and sorted by ",$S(IBDFDIS="CLIN":"CLINIC",1:IBDFDIS)
  1. .W !,"The report contains ",IBDIA," codes."
  1. .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
  1. ..S IBDST=0 F S IBDST=$O(^XTMP("IBDRPT",2,IBDST)) Q:'IBDST W !,^XTMP("IBDRPT",2,IBDST)
  1. .W ! F IBDSTR=1:1:80 W "*"
  1. .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
  1. .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
  1. .W !,"The Maintenance Utility will not be run." Q
  1. Q
  1. ;
  1. ; -- Set up variables for display by clinic/form/group
  1. 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"
  1. S DIR("B")="CLINICS"
  1. ;S DIR(0)="SBM^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS"
  1. S DIR(0)="SA^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS"
  1. S DIR("A")="Sort by [C]linics, [G]roups, [F]orms: " D ^DIR
  1. K DIR I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
  1. I $D(DIRUT)&$D(IBDF1) G QUIT
  1. S X=$S("Gg"[X:2,"Ff"[X:3,"Ss"[X:4,1:1)
  1. ;I X="?" D ZSET1,HELP1 G OUT
  1. S IBDFSRT=$E(X) ;D IN^DGHELP W ! I %=-1 D ZSET1,HELP1 G OUT
  1. S IBDFDIS=$S(IBDFSRT=1:"CLIN",IBDFSRT=2:"GROUP",IBDFSRT=3:"FORM",1:"QUIT")
  1. D @(IBDFDIS) S:Y=-1 IBDFNCNG=1 G:Y=-1 QUIT
  1. ;
  1. ;
  1. OUT1 ; -- Ask for what type of package interface
  1. N IBDTEMPY,IBDQUIT,IBDFINT,IBDCOUNT,IBDAUTO,IBDX,IBDQUI2,ZTRTN,ZTDESC,ZTSAVE,IBDQUE
  1. S DIC="^IBE(357.6,",DIC(0)="AEMN"
  1. S DIC("S")="I $P(^(0),U,6)=3,$P(^(0),U,9)=1,$G(^(11))'="""""
  1. S DIC("A")="Select Type of Code to Display: " D ^DIC K DIC G QUIT:Y<0
  1. S IBDFINT=+Y
  1. ;
  1. S IBDFACT=2 ;default of Inactive
  1. S X=$E($G(^IBE(357.6,IBDFINT,11)),7,9)
  1. ;
  1. ; -- for cpt and icd codes, let them choose active or inactive
  1. I X="CPT"!(X="VST")!(X="ICD") D
  1. .S DIR("B")="ACTIVE"
  1. .;S DIR(0)="SBM^A:ACTIVE;I:INACTIVE"
  1. .S DIR(0)="SA^A:ACTIVE;I:INACTIVE"
  1. .S DIR("A")="Display codes [A]ctive, [I]nactive: "
  1. .D ^DIR K DIR
  1. .Q:$D(DIRUT)
  1. .S X=$S("Ii"[$E(X,1):2,1:1)
  1. .S IBDFACT=$E(X)
  1. I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
  1. I $D(DIRUT)&$D(IBDF1) G QUIT
  1. ;IBD*3.0*70 - set up XTMP global with Report Info
  1. K ^XTMP("IBDRPT"),^XTMP("CPTIDX"),^XTMP("IBDCPT"),^XTMP("IBDF")
  1. 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
  1. S ^XTMP("CPTIDX",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility CPTIDX global"
  1. S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
  1. S ^XTMP("IBDF",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDF global"
  1. 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
  1. ;cannot use this option before ICD-10 impelemenation
  1. ;
  1. 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
  1. . F D Q:IBDQUI2'="A"
  1. .. W !!,"ICD-10 codes cannot be selected for this option before ICD-10 activation.",!
  1. .. S DIR(0)="FAO",DIR("A")="Press RETURN to continue..." D ^DIR K DIR
  1. .. S IBDQUI2=$$ACTPRMT^IBDUTICD()
  1. ;
  1. I $D(IBDF1) D
  1. .K VAUTP F IBI=0:0 S IBI=$O(VAUTJ(IBI)) Q:IBI']"" S VAUTP(IBI)=$G(VAUTJ(IBI))
  1. ;
  1. ;
  1. ;
  1. I IBDFACT=1 D
  1. .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC="^ICPT(",IBDFCODE="CPT "
  1. .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" S DIC="^ICD9(",IBDFCODE="ICD-9 "
  1. .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC="^IBE(357.69,",IBDFCODE="Type of Visit "
  1. .;
  1. .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"
  1. .;
  1. .;Change variable IBDFCODE to "ICD-9" or "ICD-10"
  1. .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" D ;
  1. ..S IBDFCODE=$$GETCODSY(IBDFINT)
  1. ..S DIC="^ICD9("
  1. .;
  1. .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"
  1. .;
  1. .;ICD-9 only
  1. .I $G(DIC)]"",$G(IBDFCODE)["ICD-9" D Q
  1. ..N IBDICD9D ;ICD9 date
  1. ..S IBDICD9D=$$IMPDATE^IBDUTICD(1)
  1. ..S DIC("S")="I $$LS^ICDEX(80,+Y,IBDICD9D)>0,$$CSI^ICDEX(80,+Y)=1"
  1. ..D EN1^IBDVAUT1("VAUTJ",2,IBDFCODE_"code",1)
  1. .;ICD-10 only
  1. .I $G(DIC)]"",$G(IBDFCODE)["ICD-10" S VAUTVB="VAUTJ",IBDTEMPY=Y D ICD10 S Y=IBDTEMPY Q
  1. .;
  1. .;CPT and VST only
  1. .I $G(DIC)]"" S VAUTVB="VAUTJ",VAUTNI=2,VAUTSTR=IBDFCODE_"code" S VAUTNALL=1 D FIRST^VAUTOMA
  1. ;
  1. I IBDFACT=2 D
  1. .S IBDFCODE=$$GETCODSY(IBDFINT)
  1. I (Y<0)&$D(IBDF1) D K VAUTP G QUIT
  1. .F IBI=0:0 S IBI=$O(VAUTP(IBI)) Q:IBI']"" S VAUTJ(IBI)=$G(VAUTP(IBI))
  1. I IBDFACT=1,Y<0,'$D(IBDF1) G EXIT
  1. I IBDFACT=1,$G(IBDQUIT) G EXIT
  1. ;
  1. ;Allow Report to be Queued - IBD*3.0*70
  1. L -^XTMP("IBDRPT")
  1. S DIR(0)="Y",DIR("A")="Would you like to queue this report and run it in the background",DIR("B")="Yes" D ^DIR
  1. I Y S IBDQUE=1,ZTRTN="OUT2^IBDFUTL",ZTDESC="Maintenance Utility background job",ZTSAVE("*")="",ZTIO="NULL" D ^%ZTLOAD Q
  1. OUT2 ;Tasked entry point
  1. L +^XTMP("IBDRPT"):$G(DILOCKTM,5) Q:'$T
  1. I $G(IBDQUE) S VALMEVL=$S($D(VALMEVL):VALMEVL+1,1:0) D INIT S VALMBCK="R",VALMBG=1 Q
  1. I '$D(IBDF1) K XQORS,VALMEVL D EN^VALM("IBDF UTIL PRIMARY SCREEN")
  1. I $D(IBDF1) D HDR,KILL,INIT S VALMBCK="R",VALMBG=1
  1. Q
  1. ;
  1. HDR ; -- header code
  1. I IBDFACT=1 D
  1. .S VALMHDR(1)="This screen lists Active codes on Encounter Forms."
  1. I IBDFACT'=1 D
  1. .S VALMHDR(1)="This screen lists Inactive codes on Encounter Forms."
  1. Q
  1. ;
  1. ; -- Set up list
  1. INIT D FULL^VALM1 S (IBDCNT,IBDCNT1,VALMCNT)=0
  1. N IBDX
  1. D KILL^VALM10()
  1. I '$O(^XTMP("IBDCPT",0)) S IBDFCNT1=0 D @(IBDFDIS_"1^IBDFUTL1")
  1. I '$O(^XTMP("IBDCPT",0)) D NUL
  1. 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
  1. .S ^TMP("IBDCPT1",$J,VALMCNT,0)=^XTMP("IBDCPT",IBDX,0) M ^TMP("IBDCPT1",$J,"IDX",VALMCNT)=^XTMP("IBDCPT","IDX",IBDX)
  1. I $D(^TMP("IBDCPT1",$J)) K ^XTMP("IBDCPT") M ^XTMP("IBDCPT")=^TMP("IBDCPT1",$J) K ^TMP("IBDCPT1",$J)
  1. I '$D(^XTMP("IBDCPT",0)) S ^XTMP("IBDCPT",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Maintenance utility IBDCPT global"
  1. Q
  1. ;
  1. ; -- Ask for clinics one/many/all
  1. 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
  1. Q
  1. ;
  1. ; -- Ask for forms one/many/all
  1. FORM S VAUTVB="VAUTF",DIC="^IBE(357,",VAUTSTR="Form",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 IBDFL=1 Q:IBDFL
  1. Q
  1. ;
  1. ; -- Ask for clinic groups one/many/all
  1. GROUP S VAUTVB="VAUTG",DIC="^IBD(357.99,",VAUTSTR="Clinic Group",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 IBDFL=1 Q:IBDFL
  1. Q
  1. ;
  1. ; -- Ask for divisions one/many/all
  1. DIV S IBDFL=0 D DIVISION^VAUTOMA
  1. S:Y=-1 IBDFL=1 Q:IBDFL
  1. Q
  1. ; -- Help for display choices
  1. HELP1 W !!,"Choose a number or first initial :" F K=2:1:4 W !?15,$P(Z,"^",K)
  1. W ! Q
  1. ;
  1. ; -- Listing of selections
  1. ZSET1 S Z="^1 [C]LINICS (Individual)^2 [G]ROUPS (CLINIC)^3 [F]ORMS^" Q
  1. ;
  1. ;
  1. QUIT ; -- Kill variables and reset to last display if no change has been taken place.
  1. I $D(IBDF1) S IBDFDIS=IBDFDIS1,IBDFINT=IBDFINT1,IBDFACT=IBDFACT1
  1. I '$D(IBDF1) G EXIT
  1. D KILL,INIT K IBDFNCNG S VALMBCK="R",VALMBG=1
  1. Q
  1. ;
  1. ;
  1. KILL ; -- Kill extra array variables
  1. N IBDFXX
  1. S IBDFXX=$S(IBDFDIS="FORM":"VAUTF",IBDFDIS="GROUP":"VAUTG",1:"VAUTC")
  1. I IBDFXX="VAUTF" K VAUTG,VAUTC,^TMP("CLN",$J),^TMP("CLN1",$J),^TMP("GRP",$J),^TMP("GRP1",$J)
  1. I IBDFXX="VAUTC" K VAUTG,VAUTF,^TMP("FRM",$J),^TMP("FRM1",$J),^TMP("GRP1",$J)
  1. I IBDFXX="VAUTG" K VAUTC,VAUTF,^TMP("FRM",$J),^TMP("FRM1",$J),^TMP("CLN",$J),^TMP("CLN1",$J)
  1. Q
  1. ;
  1. ;
  1. EXIT ; -- Code executed at action exit
  1. K IBDFDIS,IBDFINT,VAUTC,VAUTF,VAUTG,VAUTJ,VAUTP,IBDFINT1,IBDFDIS1,^TMP("CLN",$J),IBDFCODE,IBI,IBDFACT1
  1. 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
  1. K IBDFX,IBDORM,IBDVAL,IBDVAL1,IBDFCNT1,Z,IBDFRNM,IBDFX1,IBDFX2,IBDFX3
  1. K IBCLN,IBDFCLN,IBDFCLNM,IBDFDIV,IBDFGIFN,IBDFGN,IBDFGNM,IBDIV,IBDNAM,IBDNAME,IEN,^TMP("IBDF",$J),^TMP("UTIL",$J),DIVISION,IBDF,IBDFACT,VAUTNALL
  1. K ^TMP("IBDFUTL_SELECTED",$J),^TMP("IBDFUTL_TEMP",$J),^TMP("IBDFUTL_WCSEARCH",$J)
  1. L -^XTMP("IBDRPT")
  1. Q
  1. ;
  1. HLP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. ;
  1. EXP ; -- expand code
  1. Q
  1. NUL ; -- NULL MESSAGE
  1. 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
  1. Q
  1. ;--------- new code for ICD-10
  1. ICD10 ; Wildcard search for ICD-10 codes
  1. ;
  1. N %,DIR,IBDANS,IBDGOBAK,IBDTEXT,IBDWORD,IBDY,Y
  1. W !
  1. S IBDCOUNT=$G(IBDCOUNT)+1
  1. S IBDTEXT=$S(IBDCOUNT>1:"another "_IBDFCODE,1:IBDFCODE)
  1. S (IBDQUIT,IBDGOBAK)=0
  1. S IBDAUTO=$G(IBDAUTO)
  1. S DIR("A")="Select "_IBDTEXT_"code"
  1. S DIR(0)="FO^3:8"
  1. S DIR("?")="Enter 3 to 8 characters or '??' for more help"
  1. S DIR("??")="^D HELP^IBDFN4A"
  1. D ^DIR K DIR
  1. I Y=""!($G(DTOUT))!(Y="^") D Q
  1. .I '$D(^TMP("IBDFUTL_TEMP",$J)),'IBDAUTO S IBDQUIT=1
  1. S IBDANS=$P(Y,U)
  1. ;Do wildcard search.
  1. K ^TMP("IBDFUTL_WCSEARCH",$J)
  1. S IBDAUTO=1
  1. S IBDY=$$CODELIST^IBDUTICD("10D",IBDANS,"IBDFUTL_WCSEARCH",DT,"",1)
  1. I +IBDY<1 D
  1. .S IBDWORD=$P($P(IBDY,U,2)," ")
  1. .S IBDWORD=$TR($E(IBDWORD,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(IBDWORD,2,99) ;Capitalize first character of text message.
  1. .S $P(IBDY,U,2)=IBDWORD_" "_$P(IBDY," ",2,99)
  1. .W !!,$P(IBDY,U,2)_"."
  1. I +IBDY<1 S:IBDCOUNT=1 IBDCOUNT=0 S IBDAUTO=0 G ICD10
  1. I $P(IBDY,U,2)=0 D G ICD10
  1. .W !!,"No data found for selected search, please enter partial code'*' for"
  1. .W !,"additional selections e.g. E11* ."
  1. .S:IBDCOUNT=1 IBDCOUNT=0 S IBDAUTO=0
  1. I +IBDY'<1 D ;
  1. .S %=1
  1. .I $P(IBDY,U,2)>1 D
  1. ..W !!,"There are "_$P(IBDY,U,2)_" ICD-10-CM diagnosis codes that begin with "_IBDANS_". Do you wish to"
  1. ..W !,"automatically see all of these diagnosis codes on this list"
  1. ..S %=2 D YN^DICN
  1. .I $G(DTOUT)!(%=-1) S IBDQUIT=1 Q
  1. .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
  1. .I %=2 S IBDGOBAK=1 Q
  1. .D WCSEARCH(IBDAUTO,.IBDQUIT)
  1. I IBDGOBAK S IBDCOUNT=0 G ICD10
  1. I IBDQUIT Q
  1. I '$D(^TMP("IBDFUTL_TEMP",$J)),'IBDAUTO S IBDCOUNT=0
  1. K ^TMP("IBDFUTL_SELECTED",$J)
  1. G ICD10
  1. Q
  1. ;
  1. ;Loop through wildcard search.
  1. WCSEARCH(IBDAUTO,IBDQUIT) ;
  1. ;
  1. N IBDBEGN,IBDCNT,IBDCODE,IBDCONTU,IBDNDEX,IBDNOE,IBDSEL,IBDX
  1. W !
  1. S (IBDNDEX,IBDCNT,IBDQUIT,IBDBEGN,IBDNO)=0
  1. S IBDCONTU=1
  1. F S IBDNDEX=$O(^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX)) Q:IBDNDEX=""!(IBDQUIT)!('IBDCONTU)!(IBDNO) D ;
  1. .S IBDNOE=^TMP("IBDFUTL_WCSEARCH",$J,0) ;Number of entries in wildcard search.
  1. .S IBDCODE=^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX,1)
  1. .S IBDIEN=+$P(IBDCODE,U) ;+ to resolve both direct and variable pointers
  1. .S IBDCODE=$P(IBDCODE,U,2)
  1. .S IBDX=$P($$GETIDX^IBDFN4("10D",IBDCODE,DT),U,2)
  1. .S IBDCNT=IBDCNT+1
  1. .I IBDCNT=1 S IBDBEGN=1 I IBDNOE>5,'IBDAUTO W @IOF
  1. .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.
  1. ..S ^TMP("IBDFUTL_TEMP",$J,IBDIEN)=IBDCODE ;Needed for validation check in SET^IBDFUTL1
  1. ..I IBDNOE=1 D OKPROMPT(1,IBDCODE,IBDX,.IBDQUIT,.IBDNO) ;W !?4,IBDCODE,?15,IBDX
  1. .;User chose to select which ICD-10 codes he/she wants to add to form.
  1. .;Set ^TMP global for ICD selections.
  1. .S ^TMP("IBDFUTL_SELECTED",$J,IBDCNT)=IBDIEN_U_IBDCODE_U_IBDX
  1. .W !,IBDCNT_".",?4,IBDCODE,?15,IBDX ;Display wildcard selected ICD codes
  1. .I IBDCNT#22=0 D Q ;Display every 22 ICD codes to user.
  1. ..D SELECT(IBDBEGN,IBDCNT,.IBDQUIT,.IBDNDEX,.IBDSEL,.IBDCONTU)
  1. ..S IBDBEGN=IBDCNT+1
  1. ..;I IBDSEL="",$O(^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX))'="",'IBDQUIT,IBDCONTU W @IOF
  1. I IBDAUTO!(IBDQUIT)!('IBDCONTU) Q
  1. D SELECT(IBDBEGN,IBDCNT,.IBDQUIT,IBDNDEX,.IBDSEL,.IBDCONTU) ;Less than 22 ICD codes displayed.
  1. Q
  1. ;
  1. ;Allow user to select a range of ICD codes.
  1. SELECT(IBDBEGN,IBDCNT,IBDQUIT,IBDNDEX,IBDSEL,IBDCONTU) ;
  1. N IBDCODE,IBDI,IBDNEXT,IBDNODE,IBDSELN,IBDSKIP,IBDTEXT,IBDTEMP,IBDTEMPY,IBDX
  1. S IBDSKIP=0
  1. S IBDSEL=$G(IBDSEL)
  1. I IBDNDEX'="" S IBDNEXT=$O(^TMP("IBDFUTL_WCSEARCH",$J,IBDNDEX))
  1. K Y
  1. S DIR("A")="Select ICD-10 DIAGNOSIS CODE or '?' for more help"
  1. S DIR("?")="press <RETURN> for more or '^' to exit."
  1. S DIR("?",1)="Enter a single number from the list or range (e.g., 1,3,5 or 2-4,8) or"
  1. I IBDBEGN'=IBDCNT S DIR(0)="LO^"_IBDBEGN_":"_IBDCNT D ^DIR K DIR
  1. I $D(DTOUT),'$D(^TMP("IBDFUTL_TEMP")) S IBDQUIT=1 Q
  1. I $D(DTOUT),$D(^TMP("IBDFUTL_TEMP")) S IBDCONTU=0 Q
  1. I Y="",$G(IBDNEXT) W @IOF Q
  1. I Y="^" S IBDSKIP=1 ;User chose to exit out of selection list. Skip next question.
  1. S IBDTEMPY=Y
  1. I Y'="^",Y'="" S IBDTEMP=Y
  1. K Y
  1. I $G(IBDNEXT),'IBDSKIP D
  1. .S DIR("A")="Save selections and continue to (# of remaining items) in list"
  1. .S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR
  1. .I Y,$D(IBDNEXT) W @IOF
  1. .I Y=0 S IBDTEMP=""
  1. S Y=$G(Y)
  1. I $D(DTOUT) S IBDQUIT=1 Q
  1. I Y="^"!(Y=0) D
  1. .I IBDSEL="" S IBDCONTU=0
  1. Q:'IBDCONTU
  1. I IBDTEMPY="^",IBDSEL="" S IBDCONTU=0 Q
  1. I Y'="^",$G(IBDTEMP)'="" S IBDSEL=$G(IBDSEL)_IBDTEMP I $G(IBDNEXT) Q
  1. I IBDSEL="" Q
  1. S IBDTEXT=$S($L(IBDSEL,",")=2:"this diagnosis",1:"these diagnoses")
  1. W !,"Do you really want to select "_IBDTEXT
  1. S %=2 D YN^DICN
  1. I $G(DTOUT)!(%=2)!(%=-1) S IBDCONTU=0 Q
  1. W !
  1. F IBDI=1:1 Q:$P(IBDSEL,",",IBDI)="" D
  1. .S IBDSELN=$P(IBDSEL,",",IBDI)
  1. .S IBDNODE=^TMP("IBDFUTL_SELECTED",$J,IBDSELN)
  1. .S IBDIEN=$P(IBDNODE,U)
  1. .S IBDCODE=$P(IBDNODE,U,2)
  1. .S IBDX=$P(IBDNODE,U,3)
  1. .S ^TMP("IBDFUTL_TEMP",$J,IBDIEN)=IBDCODE ;Needed for validation check in SET^IBDFUTL1
  1. S IBDCONTU=0
  1. Q
  1. ;Ask user with 'OK? Yes' prompt
  1. OKPROMPT(IBDONE,IBDCODE,IBDX,IBDQUIT,IBDNO) ;
  1. N DIR,IBDI
  1. I '$D(IBDONE) S IBDONE=0
  1. S DIR("A")="OK? (Yes/No) "
  1. F IBDI=1:1:4 D
  1. .I IBDONE D
  1. ..I IBDI=1 S DIR("A",1)="One code found."
  1. ..I IBDI=2 S DIR("A",2)=" "
  1. ..I IBDI=3 S DIR("A",3)=IBDCODE_" "_IBDX
  1. ..I IBDI=4 S DIR("A",4)=" "
  1. .I 'IBDONE D
  1. ..I IBDI=1 S DIR("A",1)=" "
  1. ..I IBDI=2 S DIR("A",2)=IBDCODE_" "_IBDX
  1. ..I IBDI=3 S DIR("A",3)=" "
  1. S DIR(0)="YAO",DIR("B")="Yes" D ^DIR K DIR
  1. W !
  1. I $D(DUOUT)!($D(DTOUT)) S IBDQUIT=1 Q
  1. I Y=0 S IBDNO=1 W !,"Code unselected from list."
  1. Q
  1. ;
  1. ;determine coding system
  1. ; return ICD-9 or ICD-10 or null
  1. GETCODSY(IBDFINT) ;
  1. 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:"")
  1. ;IBDFUTL
  1. SETSRT(IBDFDIS) ;IBD*3.0*70 - Set VA variables
  1. S:IBDFDIS="CLIN" VAUTC=^XTMP("IBDRPT",2)
  1. S:IBDFDIS="GROUP" VAUTG=^XTMP("IBDRPT",2)
  1. S:IBDFDIS="FORM" VAUTF=^XTMP("IBDRPT",2)
  1. Q
  1. SETIBDF(IBDF) ;Set up IBDF array from ^XTMP("IBDF") global, IBD*3.0*70
  1. N IBDX
  1. S IBDX=0 F S IBDX=$O(^XTMP("IBDF",IBDX)) Q:IBDX="" S IBDF(IBDX)=^XTMP("IBDF",IBDX)
  1. Q