- IBDFN4 ;ALB/CJM - ENCOUNTER FORM - (entry points for selection routines) ;5/21/93
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,51,64,63**;APR 24, 1997;Build 80
- ;
- ;
- CPT ;select ambulatory procedures
- N NAME,CODE,SCREEN,IBDESCR,IBDESCLG,QUIT
- S QUIT=0
- S SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;List only active codes
- K DIC S DIC=81,DIC(0)="AEMQZ",DIC("S")=SCREEN
- I $D(^ICPT) D ^DIC K DIC I +Y>0 D
- .;;change to api cpt;dhh
- .S CODE=$P(Y(0),U)
- .S CODE=$$CPT^ICPTCOD(CODE)
- .I +CODE=-1 K @IBARY Q
- .S NAME=$P(CODE,"^",3)
- .S IBDESCLG=$$CPTD^ICPTCOD(+CODE,.IBCPTD)
- .S IBDESCR=$G(IBCPTD(1))_" "_$G(IBCPTD(2))
- .S @IBARY=$P(CODE,"^",2)_"^"_NAME_"^"_IBDESCR
- E K @IBARY ;kill either if file doesn't exist or nothing chosen
- Q
- CPTSCRN ;This code is probably not called, but will modify to be safe.
- S SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- ;
- ;don't ask the user about categories - it doesn't work well
- S @IBARY@("SCREEN")=SCREEN
- Q
- ;
- ICD9 ;select ICD-9 codes
- N IBDX,CODE,SCREEN,IBDESCR,QUIT
- S QUIT=0
- S SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1" ;List only active codes
- I $G(DIC("A"))="" S DIC("A")="SELECT ICD-9 DIAGNOSIS CODE NUMBER: "
- S DIC=80,DIC(0)="AEMQZI",DIC("S")=SCREEN
- D ^DIC K DIC I +Y>0 D
- .S CODE=$P(Y(0),U),IBDX=$$GETIDX("ICD9",CODE,DT),IBDESCR=$$GETDSCR("ICD9",CODE,DT) ;(#10) DESCRIPTION in the old ICD9 DD
- .S IBDX=$P(IBDX,U,2)
- .S @IBARY=CODE_"^"_IBDX_"^"_IBDESCR
- E K @IBARY ;kill if either file doesn't exist or nothing chosen - this is how to let the encounter form utilities know nothing was selected
- Q
- ICD9SCRN ;This code is probably not called, but will modify to be safe.
- S SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1"
- ;
- S @IBARY@("SCREEN")=SCREEN
- Q
- NULL ;returns NOTHING for selection
- S @IBARY=""
- Q
- ;
- VSIT ; -- Select only visit cpt codes
- N NAME,CODE,IBDESCR,QUIT,DIC,X,Y,IBHDR,IBTXT
- S QUIT=0
- ;
- ;;S DIC="^IBE(357.69,",DIC(0)="AEMQZ",DIC("S")="I '$P(^(0),U,4)"
- S DIC="^IBE(357.69,",DIC(0)="AEMQZ"
- S DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;List only active codes
- D ^DIC K DIC I +Y>0 D
- .;;----change to api cpt;dhh
- .S CODE=$P(Y(0),U),IBHDR=$P(Y(0),U,2),IBTXT=$P(Y(0),U,3)
- .S NODE=$$CPT^ICPTCOD(CODE)
- .I +NODE=-1 S IBSNM="" Q
- .S IBSNM=$P(NODE,U,3)
- .S @IBARY=CODE_"^"_IBTXT_"^"_IBHDR_"^"_IBSNM
- E K @IBARY ;kill if nothing chosen
- Q
- ;
- PRVDR ;for selecting provider
- D GETPRO^IBDF18B(IBCLINIC,IBARY)
- Q
- ;
- IBPFID ;for printing the form # assigned by form tracking
- S @IBARY=$G(IBPFID)
- Q
- ;
- PCPR ; -- get primary care provider for a patient
- S @IBARY=$P($$OUTPTPR^SDUTL3(DFN,DT),"^",2)
- Q
- ;
- PCTM ; -- get primary care team for a patient
- S @IBARY=$P($$OUTPTTM^SDUTL3(DFN,DT),"^",2)
- Q
- ;
- SCCOND ; -- display sc conditions
- Q:'$G(DFN)
- D DIS^DGRPDB
- W !
- Q
- ;
- ;
- CPTMOD ;- Select active CPT Modifiers
- ;- (used in selecting CPT Modifier(s) when creating the CPT Modifier
- ; Display ToolKit Block)
- ;
- N CODE,DIC,NAME,SCREEN
- Q:$G(IBARY)=""
- ;
- ;- Screen out inactive CPT modifiers
- ;;S SCREEN="I '$P(^(0),U,5)"
- ;;I '$D(@IBARY@("SCREEN")) S @IBARY@("SCREEN")=SCREEN
- ;
- ;List only active modifiers
- S SCREEN="I $P($$MOD^ICPTMOD(Y,""I""),U,7)=1"
- S DIC=81.3
- S DIC(0)="AEMQZ"
- S DIC("S")=SCREEN
- D ^DIC
- I +Y>0 D
- . ;- Use first 35 chars of modifier description
- . S CODE=$P(Y(0),"^"),NAME=$E($P(Y(0),"^",2),1,35)
- . S @IBARY=CODE_"^"_NAME
- ;
- ;- Kill if file doesn't exist or nothing chosen
- E K @IBARY
- Q
- ;------new code------
- ; IBDSERCH 1=Wildcard Search, 2=Lexicon Search
- ICD10 ; Wildcard search for ICD-10 codes.
- N DIR,%,IBDANS,IBDAUTO,IBDNEXT,IBDOUT,IBDTEXT,IBDWORD,IBDX,IBDY
- ; IBDSERCH 1=Wildcard ICD code search, 2=Lexicon ICD code search
- I '$D(IBDSERCH) S IBDSERCH=1 ;Set Wildcard ICD code search as default search.
- I IBDSERCH=2 D LXSEARCH Q ;Do Lexicon Partial Code ICD search.
- ;Wildcard ICD code search.
- K ^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$J),^TMP("IBDFN4_ASSOCIATE",$J)
- I $G(DIC("A"))="" K ^TMP("IBDFN4_WCSEARCH",$J)
- ;I $G(DIC("A"))'="" W !
- S IBDAUTO=0
- S DIR("A")=$S($G(DIC("A"))'="":$TR(DIC("A"),":",""),1:"SELECT ICD-10 DIAGNOSIS CODE NUMBER")
- 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="^"!(Y="")!($D(DTOUT)) K @IBARY Q
- ;Do wildcard search.
- S IBDANS=$P(Y,U)
- I $G(DIC("A"))="" S IBDY=$$CODELIST^IBDUTICD("10D",IBDANS,"IBDFN4_WCSEARCH",DT,"",1)
- I $G(DIC("A"))'="" S IBDY=$$CODELIST^IBDUTICD("10D",IBDANS,"IBDFN4_ASSOCIATE_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 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* .",!
- ;Do wildcard selection for SECOND and THIRD associated ICD-10 codes.
- S IBDOUT=0
- I $G(DIC("A"))'="" K Y D ASSOCIAT(.Y,.IBDOUT) G:Y=0!(IBDOUT) ICD10 Q
- 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 add all of these diagnosis codes to this block"
- ..S %=2 D YN^DICN
- .I %=1 S IBDAUTO=1
- .I ($G(DTOUT)) Q
- .I %=-1!(%=2) W !!,"Continue to select from the (# of items in list) ICD-10 diagnoses" S %=2 D YN^DICN I $G(DTOUT)!(%=-1)!(%=2) Q
- .D WCSEARCH(IBDAUTO) ;Wildcard Search
- I '$D(^TMP("IBDFN4_DISPLAY",$J)) K ^TMP("IBDFN4_SELECTED",$J),@IBARY G ICD10
- D DISPLAY
- K @IBARY,^TMP("IBDFN4_SELECTED",$J),^TMP("IBDFN4_DISPLAY",$J),^TMP("IBDFN4_WCSEARCH",$J),^TMP("IBDFN4_ASSOCIATE",$J)
- K ^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$J)
- I +IBDY W !,"Now for another!"
- G ICD10
- Q
- ;
- ;Loop through ^TMP global created by wildcard search.
- WCSEARCH(IBDAUTO) ;
- ;
- N IBDBEGN,IBDCNT,IBDCODE,IBDCONTU,IBDESCR,IBDNOE,IBDNDEX,IBDNO,IBDQUIT,IBDSEL,IBDX
- I 'IBDAUTO W !
- S (IBDNDEX,IBDCNT,IBDQUIT,IBDBEGN)=0
- S IBDCONTU=1
- F S IBDNDEX=$O(^TMP("IBDFN4_WCSEARCH",$J,IBDNDEX)) Q:IBDNDEX=""!(IBDQUIT)!('IBDCONTU) D ;
- .S IBDNOE=^TMP("IBDFN4_WCSEARCH",$J,0) ;Number of entries in wildcard search.
- .S IBDCODE=^TMP("IBDFN4_WCSEARCH",$J,IBDNDEX,1)
- .S IBDCODE=$P(IBDCODE,U,2)
- .S IBDX=$P($$GETIDX("10D",IBDCODE,DT),U,2)
- .S IBDESCR=$P(^TMP("IBDFN4_WCSEARCH",$J,IBDNDEX,2),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.
- ..I IBDCNT>1 W !!,"Automatic selection continued:",!
- ..;Display automatic selected wildcard search ICD code to user one at a time.
- ..S IBDNO=0
- ..D OKPROMPT($S(IBDNOE=1:1,1:""),IBDCODE,IBDX,.IBDQUIT,.IBDNO)
- ..I IBDNO!(IBDQUIT) Q
- ..S @IBARY=IBDCODE_U_IBDX_U_IBDESCR
- ..N IBDSLIEN
- ..;Add the Group and bring back the IEN Selection from ^IBE(357.3.
- ..D ADDGROUP(.IBDQUIT,.IBDSLIEN,IBDCODE)
- ..I IBDQUIT D:$D(IBDSLIEN) KILL3573(IBDSLIEN) S IBDQUIT=0 Q
- ..D SETMSG(IBDSLIEN,IBDCODE,IBDX,IBDCNT)
- .;User chose to select which ICD-10 codes he/she wants to add to form.
- .;Set ^TMP global for ICD selections.
- .S ^TMP("IBDFN4_SELECTED",$J,IBDCNT)=IBDCODE_U_IBDX_U_IBDESCR
- .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("IBDFN4_WCSEARCH",$J,IBDNDEX))'="",'IBDQUIT,IBDCONTU W @IOF
- I IBDAUTO!(IBDQUIT)!('IBDCONTU) Q
- ;Less than 22 ICD codes displayed.
- D SELECT(IBDBEGN,IBDCNT,.IBDQUIT,"",.IBDSEL,.IBDCONTU)
- Q
- ;Allow user to select a range of ICD codes.
- SELECT(IBDBEGN,IBDCNT,IBDQUIT,IBDNDEX,IBDSEL,IBDCONTU) ;
- N IBDCODE,IBDESCR,IBDI,IBDNEXT,IBDNO,IBDNODE,IBDSELN,IBDSKIP,IBDTEXT,IBDTEMP,IBDTEMPY,IBDX
- S IBDSKIP=0
- S IBDSEL=$G(IBDSEL)
- I IBDNDEX'="" S IBDNEXT=$O(^TMP("IBDFN4_WCSEARCH",$J,IBDNDEX))
- K Y
- S DIR("A")="Select ICD-10 DIAGNOSIS CODE or '?' for more help"
- S DIR("?")=$S(IBDCNT#22=0:"press Enter for more or '^' to exit.",1:"press Enter to continue 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"
- S DIR(0)="LO^"_IBDBEGN_":"_IBDCNT D ^DIR K DIR
- I $D(DTOUT) S IBDQUIT=1 Q
- I Y="",$G(IBDNEXT) W @IOF Q
- I $D(DUOUT) S IBDSKIP=1 ;Allows user to terminate with '^' out of selection list.
- S IBDTEMPY=Y
- I '$D(DUOUT),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 W @IOF
- .I Y=0 S IBDTEMP=""
- S Y=$G(Y)
- I $D(DTOUT) S IBDQUIT=1 Q
- I $D(DUOUT)!(Y=0) D
- .I IBDSEL="" S IBDCONTU=0
- Q:'IBDCONTU
- I IBDTEMPY="^",IBDSEL="" S IBDCONTU=0 Q
- I '$D(DUOUT),$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 IBDQUIT=1 K ^TMP("IBDFN4_DISPLAY",$J) Q
- W !
- F IBDI=1:1 Q:$P(IBDSEL,",",IBDI)="" D Q:IBDQUIT
- .I IBDI>1 W !!,"Selected list continued:",!
- .S IBDSELN=$P(IBDSEL,",",IBDI)
- .S IBDNODE=^TMP("IBDFN4_SELECTED",$J,IBDSELN)
- .S IBDCODE=$P(IBDNODE,U)
- .S IBDX=$P(IBDNODE,U,2)
- .S IBDESCR=$P(IBDNODE,U,3)
- .;W !,?4,IBDCODE,?15,IBDX
- .S IBDNO=0
- .D OKPROMPT("",IBDCODE,IBDX,.IBDQUIT,.IBDNO)
- .I IBDQUIT!(IBDNO) Q
- .S @IBARY=IBDCODE_"^"_IBDX_"^"_IBDESCR
- .N IBDSLIEN
- .;Adds the Group, files the entry and brings back the IEN Selection from ^IBE(357.3.
- .D ADDGROUP(.IBDQUIT,.IBDSLIEN,IBDCODE)
- .I IBDQUIT D:$D(IBDSLIEN) KILL3573(IBDSLIEN) S IBDQUIT=0 Q
- .D SETMSG(IBDSLIEN,IBDCODE,IBDX,IBDSELN)
- S IBDCONTU=0
- Q
- ;
- ;IBDEXTCD - the external code that we are adding to the group (optional)
- ADDGROUP(IBDQUIT,IBDSLIEN,IBDEXTCD) ;
- N DIC
- W !
- I '$D(@IBRTN("DATA_LOCATION")) W !,"Data location not established. Unable to file data." S IBDQUIT=1 Q
- I $G(IBGRP)'>0 D Q
- .S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S:X="^"!($D(DTOUT)) IBDQUIT=1 Q:IBDQUIT S IBGRP=+Y I Y<0 D Q:IBDQUIT=1
- ..W !!,"A SELECTION GROUP HEADER IS REQUIRED.... The selection will not be added if none is provided....Enter '??' for a list of choices.",!!
- ..S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRP=+Y I Y<0!($D(DTOUT)) S IBDQUIT=1 Q
- .D ADDREC^IBDF4(.IBDQUIT,"",.IBDSLIEN,$G(IBDEXTCD))
- .S IBGRP=""
- ;Adds Second and Third Associated ICD-10 codes,
- ;editing of subcolumn 3, Narrative to PCE, Clinical Lexicon Entry,
- ;files the entry and brings back the IEN Selection from ^IBE(357.3.
- D ADDREC^IBDF4(.IBDQUIT,"",.IBDSLIEN,$G(IBDEXTCD))
- Q
- ;Get the second and third associated codes.
- ASSOCIAT(Y,IBDOUT) ;
- N IBDCNT,IBDCODE,IBDESCR,IBDIEN,IBDNEXT,IBDNDEX,IBDNO,IBDNODE,IBDNOE,IBDQUIT,IBDX
- S (IBDAUTO,IBDCNT,IBDQUIT)=0
- S Y=""
- S (IBDNDEX,IBDNO)=0
- F S IBDNDEX=$O(^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$J,IBDNDEX)) Q:IBDNDEX=""!(IBDQUIT)!(IBDNO) D
- .S IBDNEXT=$O(^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$J,IBDNDEX))
- .S IBDCNT=IBDCNT+1
- .I IBDCNT=1 D
- ..S IBDBEGN=1
- ..S IBDNOE=^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$J,0) ;Number of entries in wildcard search.
- ..I IBDNOE>5 W @IOF
- .I IBDCNT=1,IBDNOE>1 W !,"There are "_IBDNOE_" associated codes beginning with "_IBDANS_":"
- .S IBDCODE=^TMP("IBDFN4_ASSOCIATE_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("10D",IBDCODE,DT),U,2)
- .S IBDESCR=$P(^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$J,IBDNDEX,2),U,2)
- .S ^TMP("IBDFN4_ASSOCIATE",$J,IBDCNT)=IBDIEN_U_IBDCODE_U_IBDX_U_IBDESCR
- .I IBDNOE>1 W !,IBDCNT_".",?4,IBDCODE,?15,IBDX
- .I IBDNOE=1 D
- ..D OKPROMPT(1,IBDCODE,IBDX,.IBDQUIT,.IBDNO)
- .I IBDQUIT!(IBDNO) Q
- .;Display every 22 ICD codes to user.
- .I IBDCNT#22=0 D
- ..K Y
- ..S DIR("A")="Press Enter for more, ^ to exit or Select ICD-10 ASSOCIATED CODE"
- ..S DIR(0)="NO^"_IBDBEGN_":"_IBDCNT
- ..D ^DIR K DIR
- ..S IBDBEGN=IBDCNT+1
- ..I Y="" W @IOF
- .I $D(DUOUT)!($D(DTOUT)) S (IBDQUIT,IBDOUT)=1 Q
- .I IBDCNT#22'=0,IBDNEXT="",IBDNOE'=1 D ;
- ..K Y
- ..S DIR("A")="Press Enter to continue, ^ to exit or Select ICD-10 ASSOCIATED CODE"
- ..S DIR(0)="NO^"_IBDBEGN_":"_IBDCNT
- ..D ^DIR K DIR
- .I $D(DUOUT)!($D(DTOUT)) S (IBDQUIT,IBDOUT)=1 Q
- .I Y?1N.N!(IBDNOE=1) D ;
- ..S IBDNODE=$S(IBDNOE=1:^TMP("IBDFN4_ASSOCIATE",$J,1),1:^TMP("IBDFN4_ASSOCIATE",$J,Y))
- ..S IBDIEN=$P(IBDNODE,U),IBDCODE=$P(IBDNODE,U,2),IBDX=$P(IBDNODE,U,3),IBDESCR=$P(IBDNODE,U,4)
- ..S @IBARY=IBDCODE_U_IBDX_U_IBDESCR
- ..S IBDQUIT=1
- ..I IBDNOE>1 W !,?4,IBDCODE,?15,IBDX
- ..K Y ;set up Y array to be passed back for filing of ^IBE(357.3.
- ..S Y=IBDIEN_U_IBDCODE
- ..S Y(0)=IBDCODE
- ..S Y(0,0)=IBDCODE
- Q
- ;Display the selected ICD-10 code(s) to user.
- DISPLAY ;
- ;
- N IBDCNT,IBDCODE,IBDNODE,IBDQUIT,IBDSUB,IBDX
- S (IBDCNT,IBDQUIT)=0
- W !!,^TMP("IBDFN4_DISPLAY",$J,0)_" Diagnosis Added.",!
- S IBDSUB=0
- F S IBDSUB=$O(^TMP("IBDFN4_DISPLAY",$J,IBDSUB)) Q:IBDSUB="" D ;
- .;Display wildcard selections to user.
- .S IBDCNT=IBDCNT+1
- .S IBDNODE=^TMP("IBDFN4_DISPLAY",$J,IBDSUB)
- .S IBDCODE=$P(IBDNODE,U)
- .S IBDX=$P(IBDNODE,U,2)
- .W !,IBDX_" (ICD-10-CM "_IBDCODE_")"
- .I IBDCNT#18=0 D ;
- ..W !
- ..S DIR(0)="E"
- ..D ^DIR
- ..I 'Y S IBDQUIT=1 Q
- ..W @IOF
- I IBDCNT#18=0 H 5
- W !
- Q
- ;get description
- GETDSCR(IBDCSYS,IBDCODE,IBDT) ;
- N IBDZZ,IBDRETV
- S IBDRETV=$$ICDDESC^ICDXCODE(IBDCSYS,IBDCODE,IBDT,.IBDZZ)
- I IBDRETV<1 Q $P(IBDRETV,U,2)
- Q IBDZZ(1)_" "_$G(IBDZZ(3))
- ;get ien and diagnosis description
- ;IBDCSYS - "ICD-9" if ICD9 code, "10D" if ICD-10 code
- ;IBDCODE - Actual ICD code (ie S62.011P)
- ;IBDT - Today's date.
- GETIDX(IBDCSYS,IBDCODE,IBDT) ;
- N IBDICDX
- S IBDICDX=$$ICDDATA^ICDXCODE(IBDCSYS,IBDCODE,IBDT)
- I IBDICDX<1 Q $P(IBDICDX,U,2)
- Q $P(IBDICDX,U)_U_$P(IBDICDX,U,4)
- ;Set ^TMP global to display selected ICD-10 code and ICD-10 description to the user.
- ;Selected ICD-10 codes will be displayed to the user in line tag DISPLAY.
- ;NOTE: ICD-10 description could have been edited by the user.
- SETMSG(IBDSLIEN,IBDCODE,IBDX,IBDSUB) ;
- N IBDI,IBDINDEX,IBDNODE,IBDSCHDR
- F IBDI=1:1:8 I $G(IBLIST("SCPIECE",IBDI)) D ;
- .S IBDSCHDR=$G(IBLIST("SCHDR",IBDI)) I IBDSCHDR'="" D ;
- ..I IBDSCHDR'="CODE",IBDSCHDR'="DIAGNOSIS" Q
- ..S IBDINDEX=0 F S IBDINDEX=$O(^IBE(357.3,IBDSLIEN,1,IBDINDEX)) Q:'IBDINDEX D ;
- ...S IBDNODE=^IBE(357.3,IBDSLIEN,1,IBDINDEX,0)
- ...I $P(IBDNODE,U)=IBDI,IBDSCHDR="DIAGNOSIS" S IBDX=$P(IBDNODE,U,2)
- ...I $P(IBDNODE,U)=IBDI,IBDSCHDR="CODE" S IBDCODE=$P(IBDNODE,U,2)
- S ^TMP("IBDFN4_DISPLAY",$J,0)=$G(^TMP("IBDFN4_DISPLAY",$J,0))+1
- S ^TMP("IBDFN4_DISPLAY",$J,IBDSUB)=IBDCODE_U_IBDX
- 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
- 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 match 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
- Q
- ;Partial Code Lexicon ICD code search.
- LXSEARCH ;
- N IBDCODE,IBDESCR,IBDINDEX,IBDQUIT,IBDX,IBDY
- S IBDQUIT=0
- I $G(DIC("A"))'="" D Q:IBDQUIT
- .S DIR("A")=DIC("A")
- .S DIR(0)="FAO^0:245"
- .S DIR("?")="^D INPHLP^IBDLXDG"
- .S DIR("??")="^D INPHLP^IBDLXDG"
- .D ^DIR
- .I Y="^"!(Y="")!($D(DTOUT)) K @IBARY,DIC S IBDQUIT=1 Q
- .D SETPARAM^IBDLXDG(.IBDPARAM)
- .S IBDY=$$LEXICD10^IBDLXDG(Y,$$ICD10DT^IBDUTICD(DT),.IBDPARAM)
- I $G(DIC("A"))="" D
- .D SETPARAM^IBDLXDG(.IBDPARAM)
- .S IBDY=$$DIAG10^IBDLXDG($$ICD10DT^IBDUTICD(DT),"",.IBDPARAM)
- I IBDY="" W !!,IBDPARAM("NO DATA FOUND"),!,IBDPARAM("NO DATA FOUND 2"),! G LXSEARCH
- I IBDY=-1!(IBDY=-2)!(IBDY=-3)!(IBDY=-4) Q ;Timed out or was aborted.
- S IBDCODE=$P($P(IBDY,U),";",2)
- S IBDX=$$GETIDX("10D",IBDCODE,DT)
- S IBDX=$P(IBDX,U,2)
- S IBDESCR=$P(IBDY,U,2)
- S @IBARY=IBDCODE_"^"_IBDX_"^"_IBDESCR
- K DIC
- Q
- ;IBDFN4
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFN4 16617 printed Jan 18, 2025@03:54:07 Page 2
- IBDFN4 ;ALB/CJM - ENCOUNTER FORM - (entry points for selection routines) ;5/21/93
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,51,64,63**;APR 24, 1997;Build 80
- +2 ;
- +3 ;
- CPT ;select ambulatory procedures
- +1 NEW NAME,CODE,SCREEN,IBDESCR,IBDESCLG,QUIT
- +2 SET QUIT=0
- +3 ;List only active codes
- SET SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- +4 KILL DIC
- SET DIC=81
- SET DIC(0)="AEMQZ"
- SET DIC("S")=SCREEN
- +5 IF $DATA(^ICPT)
- DO ^DIC
- KILL DIC
- IF +Y>0
- Begin DoDot:1
- +6 ;;change to api cpt;dhh
- +7 SET CODE=$PIECE(Y(0),U)
- +8 SET CODE=$$CPT^ICPTCOD(CODE)
- +9 IF +CODE=-1
- KILL @IBARY
- QUIT
- +10 SET NAME=$PIECE(CODE,"^",3)
- +11 SET IBDESCLG=$$CPTD^ICPTCOD(+CODE,.IBCPTD)
- +12 SET IBDESCR=$GET(IBCPTD(1))_" "_$GET(IBCPTD(2))
- +13 SET @IBARY=$PIECE(CODE,"^",2)_"^"_NAME_"^"_IBDESCR
- End DoDot:1
- +14 ;kill either if file doesn't exist or nothing chosen
- IF '$TEST
- KILL @IBARY
- +15 QUIT
- CPTSCRN ;This code is probably not called, but will modify to be safe.
- +1 SET SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- +2 ;
- +3 ;don't ask the user about categories - it doesn't work well
- +4 SET @IBARY@("SCREEN")=SCREEN
- +5 QUIT
- +6 ;
- ICD9 ;select ICD-9 codes
- +1 NEW IBDX,CODE,SCREEN,IBDESCR,QUIT
- +2 SET QUIT=0
- +3 ;List only active codes
- SET SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1"
- +4 IF $GET(DIC("A"))=""
- SET DIC("A")="SELECT ICD-9 DIAGNOSIS CODE NUMBER: "
- +5 SET DIC=80
- SET DIC(0)="AEMQZI"
- SET DIC("S")=SCREEN
- +6 DO ^DIC
- KILL DIC
- IF +Y>0
- Begin DoDot:1
- +7 ;(#10) DESCRIPTION in the old ICD9 DD
- SET CODE=$PIECE(Y(0),U)
- SET IBDX=$$GETIDX("ICD9",CODE,DT)
- SET IBDESCR=$$GETDSCR("ICD9",CODE,DT)
- +8 SET IBDX=$PIECE(IBDX,U,2)
- +9 SET @IBARY=CODE_"^"_IBDX_"^"_IBDESCR
- End DoDot:1
- +10 ;kill if either file doesn't exist or nothing chosen - this is how to let the encounter form utilities know nothing was selected
- IF '$TEST
- KILL @IBARY
- +11 QUIT
- ICD9SCRN ;This code is probably not called, but will modify to be safe.
- +1 SET SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1"
- +2 ;
- +3 SET @IBARY@("SCREEN")=SCREEN
- +4 QUIT
- NULL ;returns NOTHING for selection
- +1 SET @IBARY=""
- +2 QUIT
- +3 ;
- VSIT ; -- Select only visit cpt codes
- +1 NEW NAME,CODE,IBDESCR,QUIT,DIC,X,Y,IBHDR,IBTXT
- +2 SET QUIT=0
- +3 ;
- +4 ;;S DIC="^IBE(357.69,",DIC(0)="AEMQZ",DIC("S")="I '$P(^(0),U,4)"
- +5 SET DIC="^IBE(357.69,"
- SET DIC(0)="AEMQZ"
- +6 ;List only active codes
- SET DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- +7 DO ^DIC
- KILL DIC
- IF +Y>0
- Begin DoDot:1
- +8 ;;----change to api cpt;dhh
- +9 SET CODE=$PIECE(Y(0),U)
- SET IBHDR=$PIECE(Y(0),U,2)
- SET IBTXT=$PIECE(Y(0),U,3)
- +10 SET NODE=$$CPT^ICPTCOD(CODE)
- +11 IF +NODE=-1
- SET IBSNM=""
- QUIT
- +12 SET IBSNM=$PIECE(NODE,U,3)
- +13 SET @IBARY=CODE_"^"_IBTXT_"^"_IBHDR_"^"_IBSNM
- End DoDot:1
- +14 ;kill if nothing chosen
- IF '$TEST
- KILL @IBARY
- +15 QUIT
- +16 ;
- PRVDR ;for selecting provider
- +1 DO GETPRO^IBDF18B(IBCLINIC,IBARY)
- +2 QUIT
- +3 ;
- IBPFID ;for printing the form # assigned by form tracking
- +1 SET @IBARY=$GET(IBPFID)
- +2 QUIT
- +3 ;
- PCPR ; -- get primary care provider for a patient
- +1 SET @IBARY=$PIECE($$OUTPTPR^SDUTL3(DFN,DT),"^",2)
- +2 QUIT
- +3 ;
- PCTM ; -- get primary care team for a patient
- +1 SET @IBARY=$PIECE($$OUTPTTM^SDUTL3(DFN,DT),"^",2)
- +2 QUIT
- +3 ;
- SCCOND ; -- display sc conditions
- +1 if '$GET(DFN)
- QUIT
- +2 DO DIS^DGRPDB
- +3 WRITE !
- +4 QUIT
- +5 ;
- +6 ;
- CPTMOD ;- Select active CPT Modifiers
- +1 ;- (used in selecting CPT Modifier(s) when creating the CPT Modifier
- +2 ; Display ToolKit Block)
- +3 ;
- +4 NEW CODE,DIC,NAME,SCREEN
- +5 if $GET(IBARY)=""
- QUIT
- +6 ;
- +7 ;- Screen out inactive CPT modifiers
- +8 ;;S SCREEN="I '$P(^(0),U,5)"
- +9 ;;I '$D(@IBARY@("SCREEN")) S @IBARY@("SCREEN")=SCREEN
- +10 ;
- +11 ;List only active modifiers
- +12 SET SCREEN="I $P($$MOD^ICPTMOD(Y,""I""),U,7)=1"
- +13 SET DIC=81.3
- +14 SET DIC(0)="AEMQZ"
- +15 SET DIC("S")=SCREEN
- +16 DO ^DIC
- +17 IF +Y>0
- Begin DoDot:1
- +18 ;- Use first 35 chars of modifier description
- +19 SET CODE=$PIECE(Y(0),"^")
- SET NAME=$EXTRACT($PIECE(Y(0),"^",2),1,35)
- +20 SET @IBARY=CODE_"^"_NAME
- End DoDot:1
- +21 ;
- +22 ;- Kill if file doesn't exist or nothing chosen
- +23 IF '$TEST
- KILL @IBARY
- +24 QUIT
- +25 ;------new code------
- +26 ; IBDSERCH 1=Wildcard Search, 2=Lexicon Search
- ICD10 ; Wildcard search for ICD-10 codes.
- +1 NEW DIR,%,IBDANS,IBDAUTO,IBDNEXT,IBDOUT,IBDTEXT,IBDWORD,IBDX,IBDY
- +2 ; IBDSERCH 1=Wildcard ICD code search, 2=Lexicon ICD code search
- +3 ;Set Wildcard ICD code search as default search.
- IF '$DATA(IBDSERCH)
- SET IBDSERCH=1
- +4 ;Do Lexicon Partial Code ICD search.
- IF IBDSERCH=2
- DO LXSEARCH
- QUIT
- +5 ;Wildcard ICD code search.
- +6 KILL ^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$JOB),^TMP("IBDFN4_ASSOCIATE",$JOB)
- +7 IF $GET(DIC("A"))=""
- KILL ^TMP("IBDFN4_WCSEARCH",$JOB)
- +8 ;I $G(DIC("A"))'="" W !
- +9 SET IBDAUTO=0
- +10 SET DIR("A")=$SELECT($GET(DIC("A"))'="":$TRANSLATE(DIC("A"),":",""),1:"SELECT ICD-10 DIAGNOSIS CODE NUMBER")
- +11 SET DIR(0)="FO^3:8"
- +12 SET DIR("?")="Enter 3 to 8 characters or '??' for more help"
- +13 SET DIR("??")="^D HELP^IBDFN4A"
- +14 DO ^DIR
- KILL DIR
- +15 IF Y="^"!(Y="")!($DATA(DTOUT))
- KILL @IBARY
- QUIT
- +16 ;Do wildcard search.
- +17 SET IBDANS=$PIECE(Y,U)
- +18 IF $GET(DIC("A"))=""
- SET IBDY=$$CODELIST^IBDUTICD("10D",IBDANS,"IBDFN4_WCSEARCH",DT,"",1)
- +19 IF $GET(DIC("A"))'=""
- SET IBDY=$$CODELIST^IBDUTICD("10D",IBDANS,"IBDFN4_ASSOCIATE_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
- 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* .",!
- End DoDot:1
- GOTO ICD10
- +29 ;Do wildcard selection for SECOND and THIRD associated ICD-10 codes.
- +30 SET IBDOUT=0
- +31 IF $GET(DIC("A"))'=""
- KILL Y
- DO ASSOCIAT(.Y,.IBDOUT)
- if Y=0!(IBDOUT)
- GOTO ICD10
- QUIT
- +32 ;
- IF +IBDY'<1
- Begin DoDot:1
- +33 SET %=1
- +34 IF $PIECE(IBDY,U,2)>1
- Begin DoDot:2
- +35 WRITE !!,"There are "_$PIECE(IBDY,U,2)_" ICD-10-CM diagnosis codes that begin with "_IBDANS_". Do you wish to"
- +36 WRITE !,"automatically add all of these diagnosis codes to this block"
- +37 SET %=2
- DO YN^DICN
- End DoDot:2
- +38 IF %=1
- SET IBDAUTO=1
- +39 IF ($GET(DTOUT))
- QUIT
- +40 IF %=-1!(%=2)
- WRITE !!,"Continue to select from the (# of items in list) ICD-10 diagnoses"
- SET %=2
- DO YN^DICN
- IF $GET(DTOUT)!(%=-1)!(%=2)
- QUIT
- +41 ;Wildcard Search
- DO WCSEARCH(IBDAUTO)
- End DoDot:1
- +42 IF '$DATA(^TMP("IBDFN4_DISPLAY",$JOB))
- KILL ^TMP("IBDFN4_SELECTED",$JOB),@IBARY
- GOTO ICD10
- +43 DO DISPLAY
- +44 KILL @IBARY,^TMP("IBDFN4_SELECTED",$JOB),^TMP("IBDFN4_DISPLAY",$JOB),^TMP("IBDFN4_WCSEARCH",$JOB),^TMP("IBDFN4_ASSOCIATE",$JOB)
- +45 KILL ^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$JOB)
- +46 IF +IBDY
- WRITE !,"Now for another!"
- +47 GOTO ICD10
- +48 QUIT
- +49 ;
- +50 ;Loop through ^TMP global created by wildcard search.
- WCSEARCH(IBDAUTO) ;
- +1 ;
- +2 NEW IBDBEGN,IBDCNT,IBDCODE,IBDCONTU,IBDESCR,IBDNOE,IBDNDEX,IBDNO,IBDQUIT,IBDSEL,IBDX
- +3 IF 'IBDAUTO
- WRITE !
- +4 SET (IBDNDEX,IBDCNT,IBDQUIT,IBDBEGN)=0
- +5 SET IBDCONTU=1
- +6 ;
- FOR
- SET IBDNDEX=$ORDER(^TMP("IBDFN4_WCSEARCH",$JOB,IBDNDEX))
- if IBDNDEX=""!(IBDQUIT)!('IBDCONTU)
- QUIT
- Begin DoDot:1
- +7 ;Number of entries in wildcard search.
- SET IBDNOE=^TMP("IBDFN4_WCSEARCH",$JOB,0)
- +8 SET IBDCODE=^TMP("IBDFN4_WCSEARCH",$JOB,IBDNDEX,1)
- +9 SET IBDCODE=$PIECE(IBDCODE,U,2)
- +10 SET IBDX=$PIECE($$GETIDX("10D",IBDCODE,DT),U,2)
- +11 SET IBDESCR=$PIECE(^TMP("IBDFN4_WCSEARCH",$JOB,IBDNDEX,2),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 IF IBDCNT>1
- WRITE !!,"Automatic selection continued:",!
- +16 ;Display automatic selected wildcard search ICD code to user one at a time.
- +17 SET IBDNO=0
- +18 DO OKPROMPT($SELECT(IBDNOE=1:1,1:""),IBDCODE,IBDX,.IBDQUIT,.IBDNO)
- +19 IF IBDNO!(IBDQUIT)
- QUIT
- +20 SET @IBARY=IBDCODE_U_IBDX_U_IBDESCR
- +21 NEW IBDSLIEN
- +22 ;Add the Group and bring back the IEN Selection from ^IBE(357.3.
- +23 DO ADDGROUP(.IBDQUIT,.IBDSLIEN,IBDCODE)
- +24 IF IBDQUIT
- if $DATA(IBDSLIEN)
- DO KILL3573(IBDSLIEN)
- SET IBDQUIT=0
- QUIT
- +25 DO SETMSG(IBDSLIEN,IBDCODE,IBDX,IBDCNT)
- End DoDot:2
- QUIT
- +26 ;User chose to select which ICD-10 codes he/she wants to add to form.
- +27 ;Set ^TMP global for ICD selections.
- +28 SET ^TMP("IBDFN4_SELECTED",$JOB,IBDCNT)=IBDCODE_U_IBDX_U_IBDESCR
- +29 ;Display wildcard selected ICD codes
- WRITE !,IBDCNT_".",?4,IBDCODE,?15,IBDX
- +30 ;Display every 22 ICD codes to user.
- IF IBDCNT#22=0
- Begin DoDot:2
- +31 DO SELECT(IBDBEGN,IBDCNT,.IBDQUIT,.IBDNDEX,.IBDSEL,.IBDCONTU)
- +32 SET IBDBEGN=IBDCNT+1
- +33 ;I IBDSEL="",$O(^TMP("IBDFN4_WCSEARCH",$J,IBDNDEX))'="",'IBDQUIT,IBDCONTU W @IOF
- End DoDot:2
- QUIT
- End DoDot:1
- +34 IF IBDAUTO!(IBDQUIT)!('IBDCONTU)
- QUIT
- +35 ;Less than 22 ICD codes displayed.
- +36 DO SELECT(IBDBEGN,IBDCNT,.IBDQUIT,"",.IBDSEL,.IBDCONTU)
- +37 QUIT
- +38 ;Allow user to select a range of ICD codes.
- SELECT(IBDBEGN,IBDCNT,IBDQUIT,IBDNDEX,IBDSEL,IBDCONTU) ;
- +1 NEW IBDCODE,IBDESCR,IBDI,IBDNEXT,IBDNO,IBDNODE,IBDSELN,IBDSKIP,IBDTEXT,IBDTEMP,IBDTEMPY,IBDX
- +2 SET IBDSKIP=0
- +3 SET IBDSEL=$GET(IBDSEL)
- +4 IF IBDNDEX'=""
- SET IBDNEXT=$ORDER(^TMP("IBDFN4_WCSEARCH",$JOB,IBDNDEX))
- +5 KILL Y
- +6 SET DIR("A")="Select ICD-10 DIAGNOSIS CODE or '?' for more help"
- +7 SET DIR("?")=$SELECT(IBDCNT#22=0:"press Enter for more or '^' to exit.",1:"press Enter to continue 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 SET DIR(0)="LO^"_IBDBEGN_":"_IBDCNT
- DO ^DIR
- KILL DIR
- +10 IF $DATA(DTOUT)
- SET IBDQUIT=1
- QUIT
- +11 IF Y=""
- IF $GET(IBDNEXT)
- WRITE @IOF
- QUIT
- +12 ;Allows user to terminate with '^' out of selection list.
- IF $DATA(DUOUT)
- SET IBDSKIP=1
- +13 SET IBDTEMPY=Y
- +14 IF '$DATA(DUOUT)
- IF Y'=""
- SET IBDTEMP=Y
- +15 KILL Y
- +16 IF $GET(IBDNEXT)
- IF 'IBDSKIP
- Begin DoDot:1
- +17 SET DIR("A")="Save selections and continue to (# of remaining items) in list"
- +18 SET DIR(0)="Y"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- +19 IF Y
- WRITE @IOF
- +20 IF Y=0
- SET IBDTEMP=""
- End DoDot:1
- +21 SET Y=$GET(Y)
- +22 IF $DATA(DTOUT)
- SET IBDQUIT=1
- QUIT
- +23 IF $DATA(DUOUT)!(Y=0)
- Begin DoDot:1
- +24 IF IBDSEL=""
- SET IBDCONTU=0
- End DoDot:1
- +25 if 'IBDCONTU
- QUIT
- +26 IF IBDTEMPY="^"
- IF IBDSEL=""
- SET IBDCONTU=0
- QUIT
- +27 IF '$DATA(DUOUT)
- IF $GET(IBDTEMP)'=""
- SET IBDSEL=$GET(IBDSEL)_IBDTEMP
- IF $GET(IBDNEXT)
- QUIT
- +28 IF IBDSEL=""
- QUIT
- +29 SET IBDTEXT=$SELECT($LENGTH(IBDSEL,",")=2:"this diagnosis",1:"these diagnoses")
- +30 WRITE !,"Do you really want to select "_IBDTEXT
- +31 SET %=2
- DO YN^DICN
- +32 IF $GET(DTOUT)!(%=2)!(%=-1)
- SET IBDQUIT=1
- KILL ^TMP("IBDFN4_DISPLAY",$JOB)
- QUIT
- +33 WRITE !
- +34 FOR IBDI=1:1
- if $PIECE(IBDSEL,",",IBDI)=""
- QUIT
- Begin DoDot:1
- +35 IF IBDI>1
- WRITE !!,"Selected list continued:",!
- +36 SET IBDSELN=$PIECE(IBDSEL,",",IBDI)
- +37 SET IBDNODE=^TMP("IBDFN4_SELECTED",$JOB,IBDSELN)
- +38 SET IBDCODE=$PIECE(IBDNODE,U)
- +39 SET IBDX=$PIECE(IBDNODE,U,2)
- +40 SET IBDESCR=$PIECE(IBDNODE,U,3)
- +41 ;W !,?4,IBDCODE,?15,IBDX
- +42 SET IBDNO=0
- +43 DO OKPROMPT("",IBDCODE,IBDX,.IBDQUIT,.IBDNO)
- +44 IF IBDQUIT!(IBDNO)
- QUIT
- +45 SET @IBARY=IBDCODE_"^"_IBDX_"^"_IBDESCR
- +46 NEW IBDSLIEN
- +47 ;Adds the Group, files the entry and brings back the IEN Selection from ^IBE(357.3.
- +48 DO ADDGROUP(.IBDQUIT,.IBDSLIEN,IBDCODE)
- +49 IF IBDQUIT
- if $DATA(IBDSLIEN)
- DO KILL3573(IBDSLIEN)
- SET IBDQUIT=0
- QUIT
- +50 DO SETMSG(IBDSLIEN,IBDCODE,IBDX,IBDSELN)
- End DoDot:1
- if IBDQUIT
- QUIT
- +51 SET IBDCONTU=0
- +52 QUIT
- +53 ;
- +54 ;IBDEXTCD - the external code that we are adding to the group (optional)
- ADDGROUP(IBDQUIT,IBDSLIEN,IBDEXTCD) ;
- +1 NEW DIC
- +2 WRITE !
- +3 IF '$DATA(@IBRTN("DATA_LOCATION"))
- WRITE !,"Data location not established. Unable to file data."
- SET IBDQUIT=1
- QUIT
- +4 IF $GET(IBGRP)'>0
- Begin DoDot:1
- +5 SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST"
- DO ^DIC
- KILL DIC
- if X="^"!($DATA(DTOUT))
- SET IBDQUIT=1
- if IBDQUIT
- QUIT
- SET IBGRP=+Y
- IF Y<0
- Begin DoDot:2
- +6 WRITE !!,"A SELECTION GROUP HEADER IS REQUIRED.... The selection will not be added if none is provided....Enter '??' for a list of choices.",!!
- +7 SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST"
- DO ^DIC
- KILL DIC
- SET IBGRP=+Y
- IF Y<0!($DATA(DTOUT))
- SET IBDQUIT=1
- QUIT
- End DoDot:2
- if IBDQUIT=1
- QUIT
- +8 DO ADDREC^IBDF4(.IBDQUIT,"",.IBDSLIEN,$GET(IBDEXTCD))
- +9 SET IBGRP=""
- End DoDot:1
- QUIT
- +10 ;Adds Second and Third Associated ICD-10 codes,
- +11 ;editing of subcolumn 3, Narrative to PCE, Clinical Lexicon Entry,
- +12 ;files the entry and brings back the IEN Selection from ^IBE(357.3.
- +13 DO ADDREC^IBDF4(.IBDQUIT,"",.IBDSLIEN,$GET(IBDEXTCD))
- +14 QUIT
- +15 ;Get the second and third associated codes.
- ASSOCIAT(Y,IBDOUT) ;
- +1 NEW IBDCNT,IBDCODE,IBDESCR,IBDIEN,IBDNEXT,IBDNDEX,IBDNO,IBDNODE,IBDNOE,IBDQUIT,IBDX
- +2 SET (IBDAUTO,IBDCNT,IBDQUIT)=0
- +3 SET Y=""
- +4 SET (IBDNDEX,IBDNO)=0
- +5 FOR
- SET IBDNDEX=$ORDER(^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$JOB,IBDNDEX))
- if IBDNDEX=""!(IBDQUIT)!(IBDNO)
- QUIT
- Begin DoDot:1
- +6 SET IBDNEXT=$ORDER(^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$JOB,IBDNDEX))
- +7 SET IBDCNT=IBDCNT+1
- +8 IF IBDCNT=1
- Begin DoDot:2
- +9 SET IBDBEGN=1
- +10 ;Number of entries in wildcard search.
- SET IBDNOE=^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$JOB,0)
- +11 IF IBDNOE>5
- WRITE @IOF
- End DoDot:2
- +12 IF IBDCNT=1
- IF IBDNOE>1
- WRITE !,"There are "_IBDNOE_" associated codes beginning with "_IBDANS_":"
- +13 SET IBDCODE=^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$JOB,IBDNDEX,1)
- +14 ;+ to resolve both direct and variable pointers
- SET IBDIEN=+$PIECE(IBDCODE,U)
- +15 SET IBDCODE=$PIECE(IBDCODE,U,2)
- +16 SET IBDX=$PIECE($$GETIDX("10D",IBDCODE,DT),U,2)
- +17 SET IBDESCR=$PIECE(^TMP("IBDFN4_ASSOCIATE_WCSEARCH",$JOB,IBDNDEX,2),U,2)
- +18 SET ^TMP("IBDFN4_ASSOCIATE",$JOB,IBDCNT)=IBDIEN_U_IBDCODE_U_IBDX_U_IBDESCR
- +19 IF IBDNOE>1
- WRITE !,IBDCNT_".",?4,IBDCODE,?15,IBDX
- +20 IF IBDNOE=1
- Begin DoDot:2
- +21 DO OKPROMPT(1,IBDCODE,IBDX,.IBDQUIT,.IBDNO)
- End DoDot:2
- +22 IF IBDQUIT!(IBDNO)
- QUIT
- +23 ;Display every 22 ICD codes to user.
- +24 IF IBDCNT#22=0
- Begin DoDot:2
- +25 KILL Y
- +26 SET DIR("A")="Press Enter for more, ^ to exit or Select ICD-10 ASSOCIATED CODE"
- +27 SET DIR(0)="NO^"_IBDBEGN_":"_IBDCNT
- +28 DO ^DIR
- KILL DIR
- +29 SET IBDBEGN=IBDCNT+1
- +30 IF Y=""
- WRITE @IOF
- End DoDot:2
- +31 IF $DATA(DUOUT)!($DATA(DTOUT))
- SET (IBDQUIT,IBDOUT)=1
- QUIT
- +32 ;
- IF IBDCNT#22'=0
- IF IBDNEXT=""
- IF IBDNOE'=1
- Begin DoDot:2
- +33 KILL Y
- +34 SET DIR("A")="Press Enter to continue, ^ to exit or Select ICD-10 ASSOCIATED CODE"
- +35 SET DIR(0)="NO^"_IBDBEGN_":"_IBDCNT
- +36 DO ^DIR
- KILL DIR
- End DoDot:2
- +37 IF $DATA(DUOUT)!($DATA(DTOUT))
- SET (IBDQUIT,IBDOUT)=1
- QUIT
- +38 ;
- IF Y?1N.N!(IBDNOE=1)
- Begin DoDot:2
- +39 SET IBDNODE=$SELECT(IBDNOE=1:^TMP("IBDFN4_ASSOCIATE",$JOB,1),1:^TMP("IBDFN4_ASSOCIATE",$JOB,Y))
- +40 SET IBDIEN=$PIECE(IBDNODE,U)
- SET IBDCODE=$PIECE(IBDNODE,U,2)
- SET IBDX=$PIECE(IBDNODE,U,3)
- SET IBDESCR=$PIECE(IBDNODE,U,4)
- +41 SET @IBARY=IBDCODE_U_IBDX_U_IBDESCR
- +42 SET IBDQUIT=1
- +43 IF IBDNOE>1
- WRITE !,?4,IBDCODE,?15,IBDX
- +44 ;set up Y array to be passed back for filing of ^IBE(357.3.
- KILL Y
- +45 SET Y=IBDIEN_U_IBDCODE
- +46 SET Y(0)=IBDCODE
- +47 SET Y(0,0)=IBDCODE
- End DoDot:2
- End DoDot:1
- +48 QUIT
- +49 ;Display the selected ICD-10 code(s) to user.
- DISPLAY ;
- +1 ;
- +2 NEW IBDCNT,IBDCODE,IBDNODE,IBDQUIT,IBDSUB,IBDX
- +3 SET (IBDCNT,IBDQUIT)=0
- +4 WRITE !!,^TMP("IBDFN4_DISPLAY",$JOB,0)_" Diagnosis Added.",!
- +5 SET IBDSUB=0
- +6 ;
- FOR
- SET IBDSUB=$ORDER(^TMP("IBDFN4_DISPLAY",$JOB,IBDSUB))
- if IBDSUB=""
- QUIT
- Begin DoDot:1
- +7 ;Display wildcard selections to user.
- +8 SET IBDCNT=IBDCNT+1
- +9 SET IBDNODE=^TMP("IBDFN4_DISPLAY",$JOB,IBDSUB)
- +10 SET IBDCODE=$PIECE(IBDNODE,U)
- +11 SET IBDX=$PIECE(IBDNODE,U,2)
- +12 WRITE !,IBDX_" (ICD-10-CM "_IBDCODE_")"
- +13 ;
- IF IBDCNT#18=0
- Begin DoDot:2
- +14 WRITE !
- +15 SET DIR(0)="E"
- +16 DO ^DIR
- +17 IF 'Y
- SET IBDQUIT=1
- QUIT
- +18 WRITE @IOF
- End DoDot:2
- End DoDot:1
- +19 IF IBDCNT#18=0
- HANG 5
- +20 WRITE !
- +21 QUIT
- +22 ;get description
- GETDSCR(IBDCSYS,IBDCODE,IBDT) ;
- +1 NEW IBDZZ,IBDRETV
- +2 SET IBDRETV=$$ICDDESC^ICDXCODE(IBDCSYS,IBDCODE,IBDT,.IBDZZ)
- +3 IF IBDRETV<1
- QUIT $PIECE(IBDRETV,U,2)
- +4 QUIT IBDZZ(1)_" "_$GET(IBDZZ(3))
- +5 ;get ien and diagnosis description
- +6 ;IBDCSYS - "ICD-9" if ICD9 code, "10D" if ICD-10 code
- +7 ;IBDCODE - Actual ICD code (ie S62.011P)
- +8 ;IBDT - Today's date.
- GETIDX(IBDCSYS,IBDCODE,IBDT) ;
- +1 NEW IBDICDX
- +2 SET IBDICDX=$$ICDDATA^ICDXCODE(IBDCSYS,IBDCODE,IBDT)
- +3 IF IBDICDX<1
- QUIT $PIECE(IBDICDX,U,2)
- +4 QUIT $PIECE(IBDICDX,U)_U_$PIECE(IBDICDX,U,4)
- +5 ;Set ^TMP global to display selected ICD-10 code and ICD-10 description to the user.
- +6 ;Selected ICD-10 codes will be displayed to the user in line tag DISPLAY.
- +7 ;NOTE: ICD-10 description could have been edited by the user.
- SETMSG(IBDSLIEN,IBDCODE,IBDX,IBDSUB) ;
- +1 NEW IBDI,IBDINDEX,IBDNODE,IBDSCHDR
- +2 ;
- FOR IBDI=1:1:8
- IF $GET(IBLIST("SCPIECE",IBDI))
- Begin DoDot:1
- +3 ;
- SET IBDSCHDR=$GET(IBLIST("SCHDR",IBDI))
- IF IBDSCHDR'=""
- Begin DoDot:2
- +4 IF IBDSCHDR'="CODE"
- IF IBDSCHDR'="DIAGNOSIS"
- QUIT
- +5 ;
- SET IBDINDEX=0
- FOR
- SET IBDINDEX=$ORDER(^IBE(357.3,IBDSLIEN,1,IBDINDEX))
- if 'IBDINDEX
- QUIT
- Begin DoDot:3
- +6 SET IBDNODE=^IBE(357.3,IBDSLIEN,1,IBDINDEX,0)
- +7 IF $PIECE(IBDNODE,U)=IBDI
- IF IBDSCHDR="DIAGNOSIS"
- SET IBDX=$PIECE(IBDNODE,U,2)
- +8 IF $PIECE(IBDNODE,U)=IBDI
- IF IBDSCHDR="CODE"
- SET IBDCODE=$PIECE(IBDNODE,U,2)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +9 SET ^TMP("IBDFN4_DISPLAY",$JOB,0)=$GET(^TMP("IBDFN4_DISPLAY",$JOB,0))+1
- +10 SET ^TMP("IBDFN4_DISPLAY",$JOB,IBDSUB)=IBDCODE_U_IBDX
- +11 QUIT
- +12 ;To kill incomplete entries in ^IBE(357.3
- KILL3573(IBDSEL) ;
- +1 NEW DA,DIK
- +2 SET DA=IBDSEL
- SET DIK="^IBE(357.3,"
- DO ^DIK
- KILL DIK
- +3 QUIT
- +4 ;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 match 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
- +18 QUIT
- +19 ;Partial Code Lexicon ICD code search.
- LXSEARCH ;
- +1 NEW IBDCODE,IBDESCR,IBDINDEX,IBDQUIT,IBDX,IBDY
- +2 SET IBDQUIT=0
- +3 IF $GET(DIC("A"))'=""
- Begin DoDot:1
- +4 SET DIR("A")=DIC("A")
- +5 SET DIR(0)="FAO^0:245"
- +6 SET DIR("?")="^D INPHLP^IBDLXDG"
- +7 SET DIR("??")="^D INPHLP^IBDLXDG"
- +8 DO ^DIR
- +9 IF Y="^"!(Y="")!($DATA(DTOUT))
- KILL @IBARY,DIC
- SET IBDQUIT=1
- QUIT
- +10 DO SETPARAM^IBDLXDG(.IBDPARAM)
- +11 SET IBDY=$$LEXICD10^IBDLXDG(Y,$$ICD10DT^IBDUTICD(DT),.IBDPARAM)
- End DoDot:1
- if IBDQUIT
- QUIT
- +12 IF $GET(DIC("A"))=""
- Begin DoDot:1
- +13 DO SETPARAM^IBDLXDG(.IBDPARAM)
- +14 SET IBDY=$$DIAG10^IBDLXDG($$ICD10DT^IBDUTICD(DT),"",.IBDPARAM)
- End DoDot:1
- +15 IF IBDY=""
- WRITE !!,IBDPARAM("NO DATA FOUND"),!,IBDPARAM("NO DATA FOUND 2"),!
- GOTO LXSEARCH
- +16 ;Timed out or was aborted.
- IF IBDY=-1!(IBDY=-2)!(IBDY=-3)!(IBDY=-4)
- QUIT
- +17 SET IBDCODE=$PIECE($PIECE(IBDY,U),";",2)
- +18 SET IBDX=$$GETIDX("10D",IBDCODE,DT)
- +19 SET IBDX=$PIECE(IBDX,U,2)
- +20 SET IBDESCR=$PIECE(IBDY,U,2)
- +21 SET @IBARY=IBDCODE_"^"_IBDX_"^"_IBDESCR
- +22 KILL DIC
- +23 QUIT
- +24 ;IBDFN4