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 Nov 22, 2024@18:03:06 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
