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

SROICD.m

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