SROICD ;BIR/SJA - CODE SET VERSIONING UTILITY ;27 Sep 2013 4:00 PM
;;3.0;Surgery;**116,127,177**;24 Jun 93;Build 89
;
; Reference to $$ICDDATA^ICDXCODE supported by DBIA #5699
; Reference to $$LS^ICDEX supported by DBIA #5747
; Reference to $$CODEC^ICDEX supported by DBIA #5747
; Reference to $$CODEN^ICDEX supported by DBIA #5747
; Reference to $$SYS^ICDEX supported by DBIA #5747
; Reference to $$VST^ICDEX supported by DBIA #5747
; Reference to $$SEARCH^ICDSAPI supported by DBIA #5757
; Reference to $$DIAGSRCH^LEX10CS supported by DBIA #5681
; Reference to $$IMPDATE^LEXU supported by DBIA #5679
; Reference to $$FREQ^LEXU supported by DBIA #5679
; Reference to $$MAX^LEXU supported by DBIA #5679
;
ICDVST(SRCODE) ; Output Short Description, called from SRCUSS
; -- Input SRCODE in external code (e.g. "100.0" or "H54.0"
N SRIEN,SRVST
S SRIEN=+$$CODEN^ICDEX($G(SRCODE),80)
I SRIEN<1 Q ""
S SRVST=$$VST^ICDEX(80,SRIEN)
Q SRVST
ICDC(SRCODE) ; output principal ICD
N SRC,SRSDATE,SRDA
I $D(SRCODE),SRCODE="" Q
S SRDA=$S($G(SRIEN):SRIEN,$D(DA(2)):DA(2),$D(DA(1)):DA(1),$D(D0):D0,1:"")
S SRC=$$ICD(SRDA,SRCODE)
Q $P(SRC,"^",2,4)
;
ICD(SRIEN,SRC) ;
N SRSYS,SRICD,SRDATE
S SRDATE=$P($P($G(^SRF(SRIEN,0)),"^",9),".")
S SRSYS=$$ICDSYS(SRDATE)
S SRICD=$$ICDDATA^ICDXCODE(SRSYS,SRC,SRDATE,"I")
Q SRICD
;
ICDSYS(SRDT,SRICDTYP) ; determine ICD coding system
; If date of interest is null, today's date will be assumed
; If SRICDTYP is null, Diagnosis is assumed for code type
N SRSYS,SRIMPDT
S SRDT=$S($G(SRDT):$P(SRDT,"."),1:DT)
S SRIMPDT=$$IMPDATE("10D")
; JAS - 06/12/13 - PATCH 177 - Modified ICD-9 to return proper 3 character coding system abbrev.
S SRSYS=$S(SRDT'<SRIMPDT:"10D",1:"ICD")
I $G(SRICDTYP)="DIAG" S SRSYS=$S(SRSYS="10D":"10D",1:"ICD")
I $G(SRICDTYP)="PROC" S SRSYS=$S(SRSYS="10D":"10P",1:"ICP")
; END 177
Q SRSYS
;
ICDSTR(SRIEN) ; return either "(ICD9)" or "(ICD10)" string
N SRDT,SRSYS
S SRDT=$P($P($G(^SRF(SRIEN,0)),"^",9),"."),SRDT=$S($G(SRDT):SRDT,1:DT)
S SRSYS=$$ICDSYS(SRDT),SRSYS=$S(SRSYS="10D":"(ICD10)",1:"(ICD9)")
Q SRSYS
;
ICD910(SRIEN) ; return either "9" or "10"
N SRDT,SRSYS
S SRDT=$P($P($G(^SRF(SRIEN,0)),"^",9),"."),SRDT=$S($G(SRDT):SRDT,1:DT)
S SRSYS=$$ICDSYS(SRDT),SRSYS=$S(SRSYS="10D":"10",1:"9")
Q SRSYS
IMPDATE(SRCODSYS) ; a wrapper for IMPDATE API
Q $$IMPDATE^LEXU(SRCODSYS)
;
P80 ;No longer Used. ICD-9/ICD-10 diagnosis selection - called by input transform
N DIC,SRDA,SRDT,SRSYS
S SRDA=$S($G(SRIEN):SRIEN,$D(DA(2)):DA(2),$D(DA(1)):DA(1),$D(D0):D0,1:"") I 'SRDA K X Q
S SRDT=$S($G(SRDA):$P($P(^SRF(SRDA,0),"^",9),"."),1:DT),SRSYS=$$ICDSYS(SRDT)
I $L(X)>100!($L(X)<1) K X Q
I SRSYS["10" S SRTXT=X D LEX Q
S Y=$$SEARCH^ICDSAPI("DIAG",("I $$LS^ICDEX(80,+Y,"""_SRDT_""")=1"),"QEMZ",SRDT) S:Y>0 X=+Y
I Y'>0 S X="" Q
Q
ASKOK(SRTOTAL) ;
; -- See default setting of SRASK at LEX+8
I $G(SRASK)=1 D Q
. D EN^DDIOL("A total of "_$G(SRTOTAL)_" Entries found for this search.","","!!")
. D EN^DDIOL("Please refine your Search!")
. D EN^DDIOL(" ")
. H 3 S SROK=0
. Q
;
I $G(SRASK)=2 D Q
. W !!,"Searching for """_SRICDTXT_""" requires inspecting "_$G(SRTOTAL)_" records to determine"
. W !,"if they match the search criteria. This could take quite some time. Suggest"
. W !,"refining the search by further specifying """_SRICDTXT_""".",!
. ;
. N DIR,X,Y
. S DIR(0)="Y",DIR("A")="Do you wish to continue (Y/N)"
. S DIR("B")="No"
. S DIR("?")="Answer 'Y' for 'Yes' to continue searching on "_SRICDTXT_" or 'N' for 'No' to refine search criteria."
. D ^DIR
. I $D(DIROUT)!($D(DIRUT))!($D(DTOUT))!($D(DTOUT)) S SROK=0 Q
. S SROK=Y
. I SROK=1 W !," Searching...."
. W !
Q
LEX N %DT,DIROUT,DUOUT,DTOUT,SREXIT,SRICDDT,SRICDTXT,SRICDUP,SRICDY,XX,SRTOT,SROK,SRZZONE
; Begin Recursive Loop
S SRICDTXT=$G(X) Q:'$L(SRICDTXT)
; RBD - 10/15/13 - PATCH 177 - Spacebar search functionality added.
I SRICDTXT=" " S SRICDTXT=$$SPACEBAR("^ICD9(") I SRICDTXT=" " K SRICDY G LOOK2
; End 177
I $L(SRICDTXT)<2 D S X="" Q
. D EN^DDIOL("Please enter at least the first two characters of the ICD-10","","!!?5")
. D EN^DDIOL("code or code description to start the search.","","!?5")
. D EN^DDIOL(" ")
. Q
S:'$G(SRASK) SRASK=2
S SRTOT=$$FREQ^LEXU(SRICDTXT) ;IA 5679
I SRTOT>$$MAX^LEXU(30) D ASKOK(SRTOT) Q:'$G(SROK)
S SRICDDT=$G(SRDT),SREXIT=0
K SRASK,SROK
LOOK ; Lookup
Q:+($G(SREXIT))>0 K SRICDY
S SRICDY=$$DIAGSRCH^LEX10CS(SRICDTXT,.SRICDY,SRICDDT,30)
S:$O(SRICDY(" "),-1)>0 SRICDY=+SRICDY
; RBD - 10/15/13 - PATCH 177 - LOOK2 label added for Spacebar logic
LOOK2 I +SRICDY'>0 D K X,Y Q
. D EN^DDIOL("No records found matching the value entered, revise search or enter ""?""","","!?5")
. D EN^DDIOL("for help.","","!?5")
. D EN^DDIOL(" ","","!?4")
. Q
; RBD - 10/15/13 - PATCH 177 - 8 items at a time changed to 4
S XX=$$SEL^SROICDL(.SRICDY,4)
; End 177
I $D(DUOUT)&('$D(DIROUT)) K:'$D(SRICDNT) X Q
I $D(DTOUT)&('$D(DIROUT)) S SREXIT=1 K X Q
I $D(DIROUT) S SREXIT=1 K X Q
; Abort if timed out or user enters "^^"
I $D(DTOUT)!($D(DIROUT)) S SREXIT=1 K X Q
; Up one level (SRICDUP) if user enters "^"
; Quit if already at top level and user enters "^"
I $D(DUOUT),'$D(DIROUT),$L($G(SRICDUP)) K X Q
; No Selection
I '$D(DUOUT),XX=-1 S SREXIT=1
; Code Found and Selected
I $P(XX,";")'="99:CAT" S Y=+$$ICDDATA^ICDXCODE("10D",$P($P(XX,"^"),";",2)) S SREXIT=1 D Q
. ; RBD - 10/15/13 - PATCH 177 - Spacebar logic added.
. D SAVSPACE("^ICD9(",Y)
. ; End 177
. ;CHOOSE 1-5: 1 003.0 ICD-9 003.0 SALMONELLA ENTERITIS (C/C)
. W:'$D(SRZZONE) " ",$P(XX,";",2)," ICD-10 ",$$VST^ICDEX(80,Y)
; Category Found and Selected
D NXT G:+($G(SREXIT))'>0 LOOK
Q
NXT ; Next
Q:+($G(SREXIT))>0 N SRICDNT,SRICDND,SRICDX
S SRICDNT=$G(SRICDTXT),SRICDND=$G(SRICDDT),SRICDX=$G(XX)
N SRICDTXT,SRICDDT S SRICDTXT=$P($P(SRICDX,"^"),";",2),SRICDDT=SRICDND
G LOOK
Q
; RBD - 10/15/13 - PATCH 177 - Spacebar save & retrieval APIs added
; retrieves the last code selected by the user - space bar recall
; logic here
SPACEBAR(SRROOT) ;
N SRICDIEN,SRRTV
S SRRTV=" " I SRROOT="^ICD9(" D
. S SRICDIEN=$G(^DISV(DUZ,SRROOT)) ; subscription to ICR #510
. I $L(SRICDIEN) S SRRTV=$$CODEC^ICDEX(80,SRICDIEN)
Q SRRTV
;
; store the selected code for the space bar recall feature above
SAVSPACE(SRROOT,SRRETV) ;
I +$G(DUZ)=0 Q
; Subscription to ICD #510 needed for call to RECALL API below
I SRROOT="^ICD9(" D RECALL^DILFD(80,SRRETV_",",+DUZ) Q
Q
;
; End 177
OUT(SRICDC) ; called by output transform fields of the ICD diagnosis code fields
N SRDA,SRDT,SRY
;JAS - 5/31/13 - PATCH 177 - Rewrote the following line since it was grabbing the wrong ien.
S SRDA=$S($G(SRIEN):SRIEN,$G(SRTN):SRTN,$D(DA(1)):DA(1),$D(D0):D0,1:"")
S SRDT=$P($P($G(^SRF(SRDA,0)),"^",9),".")
;JAS - 4/18/13 - PATCH 177 - Either internal or external value could be passed in, so made changes to handle that
I SRICDC?1N.N S SRY=$$ICDDATA^ICDXCODE("DIAG",SRICDC,SRDT,"I")
E S SRY=$$ICDDATA^ICDXCODE("DIAG",SRICDC,SRDT,"E")
;End 177
Q $P(SRY,"^",2)
;
SCRN(SRCODE) ;screen for active ICD codes
N SRSTAT,SRDA,SRDT
S SRDA=$S($G(SRIEN):SRIEN,$D(DA(2)):DA(2),$D(DA(1)):DA(1),$D(D0):D0,1:"")
S SRDT=$S($G(SRDA):$P($P(^SRF(SRDA,0),"^",9),"."),1:DT)
S SRSTAT=$$LS^ICDEX(80,SRCODE,SRDT)
Q $S(SRSTAT<1:0,1:1)
;
ICDSRCH ; To handle ICD ICD-9/10 Diagnosis Code Searches when ^DIC or ^DIE cannot be used
; SRPRMT - For specific label, this field needs to be set from calling routine
; SRDEF - For displaying the default field value at diagnosis prompt
; X & Y variables need to be newed prior to calling this tag
I $G(SRPRMT)="" S SRPRMT=" Select ICD Diagnosis "
N SRDT,SRSYS
S SRDT=$P($P($G(^SRF(SRTN,0)),"^",9),"."),SRDT=$S($G(SRDT):SRDT,1:DT),SRSYS=$$SYS^ICDEX("DIAG",SRDT)
W !!,SRPRMT_$$ICDSTR^SROICD(SRTN)_": "_$S($G(SRDEF)'="":SRDEF_"// ",1:"") R X:DTIME
I X="",$G(SRDEF)'="" S X=SRDEF
; RBD - 10/15/13 - PATCH 177 - Needs to Quit when X Null also
I (X="")!(X="^")!(X="@") Q
; End 177
I X["?" D K X,Y G ICDSRCH
.N SRTAG,SRFMT S SRTAG=""
.I SRSYS=30 S SRTAG=$S(X["???":"D3^SROICDGT",X["??":"D2^SROICDGT",X["?":"D1^SROICDGT",1:"D1^SROICDGT") D @SRTAG Q
.I SRSYS=1 S SRTAG="Answer with ICD-9 DIAGNOSIS CODE NUMBER, or DESCRIPTION."
.S SRFMT=$S(X["??":"!?8",1:"!?5")
.D EN^DDIOL(SRTAG,"",SRFMT)
.Q
I SRSYS=1 S Y=$$SEARCH^ICDSAPI("DIAG","","QEMZ",SRDT)
E D LEX^SROICD
;JAS - 11/07/13 - PATCH 177 - Need to Kill Y too prior to returning to ICDSRCH
I $G(Y)'>0!($G(Y)="") D K X,Y G ICDSRCH
.I SRSYS=1 W !,?6,"Enter the ICD Diagnosis code for the principal postoperative diagnosis.",!,?6,"Screen prevents selection of inactive diagnosis."
K SRPRMT,SRDEF
Q
;
TEST1 ;
; do not ask question
S SRASK=1
S X="FRACTURE",SRDT=3150101 D LEX
Q
TEST2 ;
; ask question
S SRASK=2
S X="FRACTURE",SRDT=3150101 D LEX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROICD 9047 printed Dec 13, 2024@02:43:53 Page 2
SROICD ;BIR/SJA - CODE SET VERSIONING UTILITY ;27 Sep 2013 4:00 PM
+1 ;;3.0;Surgery;**116,127,177**;24 Jun 93;Build 89
+2 ;
+3 ; Reference to $$ICDDATA^ICDXCODE supported by DBIA #5699
+4 ; Reference to $$LS^ICDEX supported by DBIA #5747
+5 ; Reference to $$CODEC^ICDEX supported by DBIA #5747
+6 ; Reference to $$CODEN^ICDEX supported by DBIA #5747
+7 ; Reference to $$SYS^ICDEX supported by DBIA #5747
+8 ; Reference to $$VST^ICDEX supported by DBIA #5747
+9 ; Reference to $$SEARCH^ICDSAPI supported by DBIA #5757
+10 ; Reference to $$DIAGSRCH^LEX10CS supported by DBIA #5681
+11 ; Reference to $$IMPDATE^LEXU supported by DBIA #5679
+12 ; Reference to $$FREQ^LEXU supported by DBIA #5679
+13 ; Reference to $$MAX^LEXU supported by DBIA #5679
+14 ;
ICDVST(SRCODE) ; Output Short Description, called from SRCUSS
+1 ; -- Input SRCODE in external code (e.g. "100.0" or "H54.0"
+2 NEW SRIEN,SRVST
+3 SET SRIEN=+$$CODEN^ICDEX($GET(SRCODE),80)
+4 IF SRIEN<1
QUIT ""
+5 SET SRVST=$$VST^ICDEX(80,SRIEN)
+6 QUIT SRVST
ICDC(SRCODE) ; output principal ICD
+1 NEW SRC,SRSDATE,SRDA
+2 IF $DATA(SRCODE)
IF SRCODE=""
QUIT
+3 SET SRDA=$SELECT($GET(SRIEN):SRIEN,$DATA(DA(2)):DA(2),$DATA(DA(1)):DA(1),$DATA(D0):D0,1:"")
+4 SET SRC=$$ICD(SRDA,SRCODE)
+5 QUIT $PIECE(SRC,"^",2,4)
+6 ;
ICD(SRIEN,SRC) ;
+1 NEW SRSYS,SRICD,SRDATE
+2 SET SRDATE=$PIECE($PIECE($GET(^SRF(SRIEN,0)),"^",9),".")
+3 SET SRSYS=$$ICDSYS(SRDATE)
+4 SET SRICD=$$ICDDATA^ICDXCODE(SRSYS,SRC,SRDATE,"I")
+5 QUIT SRICD
+6 ;
ICDSYS(SRDT,SRICDTYP) ; determine ICD coding system
+1 ; If date of interest is null, today's date will be assumed
+2 ; If SRICDTYP is null, Diagnosis is assumed for code type
+3 NEW SRSYS,SRIMPDT
+4 SET SRDT=$SELECT($GET(SRDT):$PIECE(SRDT,"."),1:DT)
+5 SET SRIMPDT=$$IMPDATE("10D")
+6 ; JAS - 06/12/13 - PATCH 177 - Modified ICD-9 to return proper 3 character coding system abbrev.
+7 SET SRSYS=$SELECT(SRDT'<SRIMPDT:"10D",1:"ICD")
+8 IF $GET(SRICDTYP)="DIAG"
SET SRSYS=$SELECT(SRSYS="10D":"10D",1:"ICD")
+9 IF $GET(SRICDTYP)="PROC"
SET SRSYS=$SELECT(SRSYS="10D":"10P",1:"ICP")
+10 ; END 177
+11 QUIT SRSYS
+12 ;
ICDSTR(SRIEN) ; return either "(ICD9)" or "(ICD10)" string
+1 NEW SRDT,SRSYS
+2 SET SRDT=$PIECE($PIECE($GET(^SRF(SRIEN,0)),"^",9),".")
SET SRDT=$SELECT($GET(SRDT):SRDT,1:DT)
+3 SET SRSYS=$$ICDSYS(SRDT)
SET SRSYS=$SELECT(SRSYS="10D":"(ICD10)",1:"(ICD9)")
+4 QUIT SRSYS
+5 ;
ICD910(SRIEN) ; return either "9" or "10"
+1 NEW SRDT,SRSYS
+2 SET SRDT=$PIECE($PIECE($GET(^SRF(SRIEN,0)),"^",9),".")
SET SRDT=$SELECT($GET(SRDT):SRDT,1:DT)
+3 SET SRSYS=$$ICDSYS(SRDT)
SET SRSYS=$SELECT(SRSYS="10D":"10",1:"9")
+4 QUIT SRSYS
IMPDATE(SRCODSYS) ; a wrapper for IMPDATE API
+1 QUIT $$IMPDATE^LEXU(SRCODSYS)
+2 ;
P80 ;No longer Used. ICD-9/ICD-10 diagnosis selection - called by input transform
+1 NEW DIC,SRDA,SRDT,SRSYS
+2 SET SRDA=$SELECT($GET(SRIEN):SRIEN,$DATA(DA(2)):DA(2),$DATA(DA(1)):DA(1),$DATA(D0):D0,1:"")
IF 'SRDA
KILL X
QUIT
+3 SET SRDT=$SELECT($GET(SRDA):$PIECE($PIECE(^SRF(SRDA,0),"^",9),"."),1:DT)
SET SRSYS=$$ICDSYS(SRDT)
+4 IF $LENGTH(X)>100!($LENGTH(X)<1)
KILL X
QUIT
+5 IF SRSYS["10"
SET SRTXT=X
DO LEX
QUIT
+6 SET Y=$$SEARCH^ICDSAPI("DIAG",("I $$LS^ICDEX(80,+Y,"""_SRDT_""")=1"),"QEMZ",SRDT)
if Y>0
SET X=+Y
+7 IF Y'>0
SET X=""
QUIT
+8 QUIT
ASKOK(SRTOTAL) ;
+1 ; -- See default setting of SRASK at LEX+8
+2 IF $GET(SRASK)=1
Begin DoDot:1
+3 DO EN^DDIOL("A total of "_$GET(SRTOTAL)_" Entries found for this search.","","!!")
+4 DO EN^DDIOL("Please refine your Search!")
+5 DO EN^DDIOL(" ")
+6 HANG 3
SET SROK=0
+7 QUIT
End DoDot:1
QUIT
+8 ;
+9 IF $GET(SRASK)=2
Begin DoDot:1
+10 WRITE !!,"Searching for """_SRICDTXT_""" requires inspecting "_$GET(SRTOTAL)_" records to determine"
+11 WRITE !,"if they match the search criteria. This could take quite some time. Suggest"
+12 WRITE !,"refining the search by further specifying """_SRICDTXT_""".",!
+13 ;
+14 NEW DIR,X,Y
+15 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue (Y/N)"
+16 SET DIR("B")="No"
+17 SET DIR("?")="Answer 'Y' for 'Yes' to continue searching on "_SRICDTXT_" or 'N' for 'No' to refine search criteria."
+18 DO ^DIR
+19 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DTOUT))!($DATA(DTOUT))
SET SROK=0
QUIT
+20 SET SROK=Y
+21 IF SROK=1
WRITE !," Searching...."
+22 WRITE !
End DoDot:1
QUIT
+23 QUIT
LEX NEW %DT,DIROUT,DUOUT,DTOUT,SREXIT,SRICDDT,SRICDTXT,SRICDUP,SRICDY,XX,SRTOT,SROK,SRZZONE
+1 ; Begin Recursive Loop
+2 SET SRICDTXT=$GET(X)
if '$LENGTH(SRICDTXT)
QUIT
+3 ; RBD - 10/15/13 - PATCH 177 - Spacebar search functionality added.
+4 IF SRICDTXT=" "
SET SRICDTXT=$$SPACEBAR("^ICD9(")
IF SRICDTXT=" "
KILL SRICDY
GOTO LOOK2
+5 ; End 177
+6 IF $LENGTH(SRICDTXT)<2
Begin DoDot:1
+7 DO EN^DDIOL("Please enter at least the first two characters of the ICD-10","","!!?5")
+8 DO EN^DDIOL("code or code description to start the search.","","!?5")
+9 DO EN^DDIOL(" ")
+10 QUIT
End DoDot:1
SET X=""
QUIT
+11 if '$GET(SRASK)
SET SRASK=2
+12 ;IA 5679
SET SRTOT=$$FREQ^LEXU(SRICDTXT)
+13 IF SRTOT>$$MAX^LEXU(30)
DO ASKOK(SRTOT)
if '$GET(SROK)
QUIT
+14 SET SRICDDT=$GET(SRDT)
SET SREXIT=0
+15 KILL SRASK,SROK
LOOK ; Lookup
+1 if +($GET(SREXIT))>0
QUIT
KILL SRICDY
+2 SET SRICDY=$$DIAGSRCH^LEX10CS(SRICDTXT,.SRICDY,SRICDDT,30)
+3 if $ORDER(SRICDY(" "),-1)>0
SET SRICDY=+SRICDY
+4 ; RBD - 10/15/13 - PATCH 177 - LOOK2 label added for Spacebar logic
LOOK2 IF +SRICDY'>0
Begin DoDot:1
+1 DO EN^DDIOL("No records found matching the value entered, revise search or enter ""?""","","!?5")
+2 DO EN^DDIOL("for help.","","!?5")
+3 DO EN^DDIOL(" ","","!?4")
+4 QUIT
End DoDot:1
KILL X,Y
QUIT
+5 ; RBD - 10/15/13 - PATCH 177 - 8 items at a time changed to 4
+6 SET XX=$$SEL^SROICDL(.SRICDY,4)
+7 ; End 177
+8 IF $DATA(DUOUT)&('$DATA(DIROUT))
if '$DATA(SRICDNT)
KILL X
QUIT
+9 IF $DATA(DTOUT)&('$DATA(DIROUT))
SET SREXIT=1
KILL X
QUIT
+10 IF $DATA(DIROUT)
SET SREXIT=1
KILL X
QUIT
+11 ; Abort if timed out or user enters "^^"
+12 IF $DATA(DTOUT)!($DATA(DIROUT))
SET SREXIT=1
KILL X
QUIT
+13 ; Up one level (SRICDUP) if user enters "^"
+14 ; Quit if already at top level and user enters "^"
+15 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
IF $LENGTH($GET(SRICDUP))
KILL X
QUIT
+16 ; No Selection
+17 IF '$DATA(DUOUT)
IF XX=-1
SET SREXIT=1
+18 ; Code Found and Selected
+19 IF $PIECE(XX,";")'="99:CAT"
SET Y=+$$ICDDATA^ICDXCODE("10D",$PIECE($PIECE(XX,"^"),";",2))
SET SREXIT=1
Begin DoDot:1
+20 ; RBD - 10/15/13 - PATCH 177 - Spacebar logic added.
+21 DO SAVSPACE("^ICD9(",Y)
+22 ; End 177
+23 ;CHOOSE 1-5: 1 003.0 ICD-9 003.0 SALMONELLA ENTERITIS (C/C)
+24 if '$DATA(SRZZONE)
WRITE " ",$PIECE(XX,";",2)," ICD-10 ",$$VST^ICDEX(80,Y)
End DoDot:1
QUIT
+25 ; Category Found and Selected
+26 DO NXT
if +($GET(SREXIT))'>0
GOTO LOOK
+27 QUIT
NXT ; Next
+1 if +($GET(SREXIT))>0
QUIT
NEW SRICDNT,SRICDND,SRICDX
+2 SET SRICDNT=$GET(SRICDTXT)
SET SRICDND=$GET(SRICDDT)
SET SRICDX=$GET(XX)
+3 NEW SRICDTXT,SRICDDT
SET SRICDTXT=$PIECE($PIECE(SRICDX,"^"),";",2)
SET SRICDDT=SRICDND
+4 GOTO LOOK
+5 QUIT
+6 ; RBD - 10/15/13 - PATCH 177 - Spacebar save & retrieval APIs added
+7 ; retrieves the last code selected by the user - space bar recall
+8 ; logic here
SPACEBAR(SRROOT) ;
+1 NEW SRICDIEN,SRRTV
+2 SET SRRTV=" "
IF SRROOT="^ICD9("
Begin DoDot:1
+3 ; subscription to ICR #510
SET SRICDIEN=$GET(^DISV(DUZ,SRROOT))
+4 IF $LENGTH(SRICDIEN)
SET SRRTV=$$CODEC^ICDEX(80,SRICDIEN)
End DoDot:1
+5 QUIT SRRTV
+6 ;
+7 ; store the selected code for the space bar recall feature above
SAVSPACE(SRROOT,SRRETV) ;
+1 IF +$GET(DUZ)=0
QUIT
+2 ; Subscription to ICD #510 needed for call to RECALL API below
+3 IF SRROOT="^ICD9("
DO RECALL^DILFD(80,SRRETV_",",+DUZ)
QUIT
+4 QUIT
+5 ;
+6 ; End 177
OUT(SRICDC) ; called by output transform fields of the ICD diagnosis code fields
+1 NEW SRDA,SRDT,SRY
+2 ;JAS - 5/31/13 - PATCH 177 - Rewrote the following line since it was grabbing the wrong ien.
+3 SET SRDA=$SELECT($GET(SRIEN):SRIEN,$GET(SRTN):SRTN,$DATA(DA(1)):DA(1),$DATA(D0):D0,1:"")
+4 SET SRDT=$PIECE($PIECE($GET(^SRF(SRDA,0)),"^",9),".")
+5 ;JAS - 4/18/13 - PATCH 177 - Either internal or external value could be passed in, so made changes to handle that
+6 IF SRICDC?1N.N
SET SRY=$$ICDDATA^ICDXCODE("DIAG",SRICDC,SRDT,"I")
+7 IF '$TEST
SET SRY=$$ICDDATA^ICDXCODE("DIAG",SRICDC,SRDT,"E")
+8 ;End 177
+9 QUIT $PIECE(SRY,"^",2)
+10 ;
SCRN(SRCODE) ;screen for active ICD codes
+1 NEW SRSTAT,SRDA,SRDT
+2 SET SRDA=$SELECT($GET(SRIEN):SRIEN,$DATA(DA(2)):DA(2),$DATA(DA(1)):DA(1),$DATA(D0):D0,1:"")
+3 SET SRDT=$SELECT($GET(SRDA):$PIECE($PIECE(^SRF(SRDA,0),"^",9),"."),1:DT)
+4 SET SRSTAT=$$LS^ICDEX(80,SRCODE,SRDT)
+5 QUIT $SELECT(SRSTAT<1:0,1:1)
+6 ;
ICDSRCH ; To handle ICD ICD-9/10 Diagnosis Code Searches when ^DIC or ^DIE cannot be used
+1 ; SRPRMT - For specific label, this field needs to be set from calling routine
+2 ; SRDEF - For displaying the default field value at diagnosis prompt
+3 ; X & Y variables need to be newed prior to calling this tag
+4 IF $GET(SRPRMT)=""
SET SRPRMT=" Select ICD Diagnosis "
+5 NEW SRDT,SRSYS
+6 SET SRDT=$PIECE($PIECE($GET(^SRF(SRTN,0)),"^",9),".")
SET SRDT=$SELECT($GET(SRDT):SRDT,1:DT)
SET SRSYS=$$SYS^ICDEX("DIAG",SRDT)
+7 WRITE !!,SRPRMT_$$ICDSTR^SROICD(SRTN)_": "_$SELECT($GET(SRDEF)'="":SRDEF_"// ",1:"")
READ X:DTIME
+8 IF X=""
IF $GET(SRDEF)'=""
SET X=SRDEF
+9 ; RBD - 10/15/13 - PATCH 177 - Needs to Quit when X Null also
+10 IF (X="")!(X="^")!(X="@")
QUIT
+11 ; End 177
+12 IF X["?"
Begin DoDot:1
+13 NEW SRTAG,SRFMT
SET SRTAG=""
+14 IF SRSYS=30
SET SRTAG=$SELECT(X["???":"D3^SROICDGT",X["??":"D2^SROICDGT",X["?":"D1^SROICDGT",1:"D1^SROICDGT")
DO @SRTAG
QUIT
+15 IF SRSYS=1
SET SRTAG="Answer with ICD-9 DIAGNOSIS CODE NUMBER, or DESCRIPTION."
+16 SET SRFMT=$SELECT(X["??":"!?8",1:"!?5")
+17 DO EN^DDIOL(SRTAG,"",SRFMT)
+18 QUIT
End DoDot:1
KILL X,Y
GOTO ICDSRCH
+19 IF SRSYS=1
SET Y=$$SEARCH^ICDSAPI("DIAG","","QEMZ",SRDT)
+20 IF '$TEST
DO LEX^SROICD
+21 ;JAS - 11/07/13 - PATCH 177 - Need to Kill Y too prior to returning to ICDSRCH
+22 IF $GET(Y)'>0!($GET(Y)="")
Begin DoDot:1
+23 IF SRSYS=1
WRITE !,?6,"Enter the ICD Diagnosis code for the principal postoperative diagnosis.",!,?6,"Screen prevents selection of inactive diagnosis."
End DoDot:1
KILL X,Y
GOTO ICDSRCH
+24 KILL SRPRMT,SRDEF
+25 QUIT
+26 ;
TEST1 ;
+1 ; do not ask question
+2 SET SRASK=1
+3 SET X="FRACTURE"
SET SRDT=3150101
DO LEX
+4 QUIT
TEST2 ;
+1 ; ask question
+2 SET SRASK=2
+3 SET X="FRACTURE"
SET SRDT=3150101
DO LEX
+4 QUIT
