BLRAG07 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ; 17-Oct-2014 09:22 ; MKK
;;5.2;IHS LABORATORY;**1031,1034**;NOV 01, 1997;Build 88
;
; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
;
; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
;
; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest\
; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
;
;---------------------------------------------------------------
; Lookup ICD's matching input
; BLRINP = (required) Partial name lookup - free text
; BLRLEX = (optional) Use Lexicon
; 0=ICD9 lookup (default)
; 1=Lexicon lookup
; BLRVDT = (optional) Visit date in external format
; BLRGEN = (optional) patient gender
; BLRECOD = (optional) allow ECodes flag:
; 0=exclude (default)
; 1=include
; 2=ecodes only
; BLRVCOD = (optional) allow VCodes flag:
; 0=include
; 1=exclude
; 2=vcodes only
; Returned as a list of records in the format:
; 0 1 2 3
; Descriptive Text ^ ICD IEN ^ Narrative Text ^ ICD Code
;
;
ICDLKUP(BLRY,BLRINP,BLRLEX,BLRVDT,BLRGEN,BLRECOD,BLRVCOD) ;EP - ICD lookup
; rpc: BLR ICD LOOKUP
;INPUT:
; BLRINP = (required) Partial name lookup - free text; must be at least 3 characters
; BLRLEX = (optional) Use Lexicon
; 0=ICD9 lookup (default)
; 1=Lexicon lookup
; BLRVDT = (optional) Visit date in external format
; BLRGEN = (optional) patient gender
; BLRECOD = (optional) allow ECodes flag:
; 0=exclude (default)
; 1=include
; 2=ecodes only
; BLRVCOD = (optional) allow VCodes flag:
; 0=include
; 1=exclude
; 2=vcodes only
;RETURN:
; Returned as a list of records in the format:
; 0 1 2 3
; Descriptive Text ^ ICD IEN ^ Narrative Text ^ ICD Code
;
N DIC,X,Y,I,ICD,LEX,RES
N AICDRET,XTLKSAY,REC,DESC,CODE,NARR
N BLRI
N CODESYS
NEW ICDCODSY ; IHS/MSC/MKK - LR*5.2*1034
;
S BLRLEX=$G(BLRLEX)
; S BLRVDT=$G(BLRVDT)
S BLRVDT=$G(BLRVDT,$$DT^XLFDT) ; IHS/MSC/MKK - LR*5.2*1034
;
D ICDCODSY(BLRVDT,.ICDCODSY) ; IHS/MSC/MKK - LR*5.2*1034
;
S BLRGEN=$G(BLRGEN)
S BLRECOD=$G(BLRECOD)
S BLRVCOD=$G(BLRVCOD)
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
S BLRI=0
K ^TMP("BLRAG",$J)
S BLRY=$$TMPGLB^BLRAGUT()
S @BLRY@(0)="ERROR_ID"
;
I $L($G(BLRINP))<3 D ERR^BLRAGUT("BLRAG07: User name lookup requires at least 3 characters.") Q
S:BLRVDT'="" BLRVDT=$$CVTDATE^BLRAGUT(BLRVDT) ;convert date to FM format
;
I BLRLEX D
.N HITS
.D LEXLKUP^BLRAGUT(.HITS,BLRINP_"^ICD")
.S HITS=0
.F S HITS=$O(HITS(HITS)) Q:'HITS D
..S BLRLEX=+HITS(HITS)
..S X=$$ICDONE^LEXU(BLRLEX)
..Q:X=""
..S ICD=$O(^ICD9("BA",X,0))
..S:'ICD ICD=$O(^ICD9("BA",X_" ",0))
..D:ICD CHKHITS
E I $G(DUZ("AG"))="I" D
.S DIC="^ICD9(",DIC(0)="TM",X=BLRINP,XTLKSAY=0
.; K ^UTILITY("AICDHITS",$J),^TMP("XTLKHITS",$J)
. K ^TMP("ICD9",$J),^TMP("XTLKHITS",$J) ; IHS/MSC/MKK - LR*5.2*1034
.D ^DIC
.; I Y'=-1 D
.I +Y'=-1 D ; IHS/MSC/MKK - LR*5.2*1034
..S ICD=+Y
..D CHKHITS
.E I $G(^DD(80,0,"DIC"))="XTLKDICL" D
..D XTLKUP
.E D AICDLKUP
.I 'BLRI,$L(BLRINP)>2 D
..N LK,LN
..S LK=BLRINP,LN=$L(BLRINP)
..F D S LK=$O(^ICD9("BA",LK)) Q:$E(LK,1,LN)'=BLRINP
...S ICD=0
...F S ICD=$O(^ICD9("BA",LK,ICD)) Q:'ICD D CHKHITS
.K ^UTILITY("AICDHITS",$J),^TMP("XTLKHITS",$J)
E D
.; D FIND^DIC(80,,".01;10","M",BLRINP,,,,,"RES")
.D FINDER(BLRINP,.RES) ; IHS/MSC/MKK - LR*5.2*1034
.I '$O(RES("DILIST",0)) Q
.M ^TMP("XTLKHITS",$J)=RES("DILIST",2)
.D XTLKUP
.K ^TMP("XTLKHITS",$J)
K @BLRY@(0)
; 0 1 2 3
; S @BLRY@(0)="DESCRIPTION^ICD_IEN^NARRATIVE^ICD_CODE"
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; 0 1 2 3 4
S @BLRY@(0)="DESCRIPTION^ICD_IEN^NARRATIVE^ICD_CODE^CODING_SYSTEM"
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
Q
;
AICDLKUP S I=0
; F S I=$O(^UTILITY("AICDHITS",$J,I)) Q:'I D
; .S ICD=$G(^UTILITY("AICDHITS",$J,I))
; .D CHKHITS
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; AICD*4.0 Stores "Hits" in ^TMP("ICD9",$J not in ^UTILITY("AICDHITS",$J
F S I=$O(^TMP("ICD9",$J,"SEL",I)) Q:I<1 D
. S ICD=+$G(^TMP("ICD9",$J,"SEL",I))
. D CHKHITS
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
Q
;
XTLKUP S I=0
F S I=$O(^TMP("XTLKHITS",$J,I)) Q:'I D
.S ICD=$G(^TMP("XTLKHITS",$J,I))
.D CHKHITS
Q
;
CHKHITS Q:$D(@BLRY@(0,ICD)) S @BLRY@(0,ICD)=""
S REC=$G(^ICD9(ICD,0))
D ENTRYAUD^BLRUTIL("CHKHITS^BLRAG07 0.0")
; Q:$P(REC,U,9)
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; AICD 4.0 modified File 80. There is no longer an INACTIVE FLAG.
; STATUS is now a multiple. Note that STATUS=1 is ACTIVE; STATUS=0 is INACTIVE.
Q:'$P($G(^ICD9(ICD,66,+$O(^ICD9(ICD,66,"A"),-1),0)),"^",2) ; Most Current Status
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
I 'BLRECOD,$E(REC)="E" Q
I BLRECOD=2,$E(REC)'="E" Q
I BLRVCOD=1,$E(REC)="V" Q
I BLRVCOD=2,$E(REC)'="V" Q
;
D ENTRYAUD^BLRUTIL("CHKHITS^BLRAG07 3.0")
;
; I BLRVDT,$P(REC,U,11),$$FMDIFF^XLFDT(BLRVDT,$P(REC,U,11))>-1 Q
Q:$$INACTDT(ICD,BLRVDT) ; IHS/MSC/MKK - LR*5.2*1034
;
I $L(BLRGEN),$P(REC,U,10)'="",BLRGEN'=$P(REC,U,10) Q
;
; S NARR=$G(^ICD9(ICD,1)),CODE=$P(REC,U),DESC=$P(REC,U,3)
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
NEW CODE,NARR,DESC,CODESYS,ICD10ID,IMPLDATE
S CODE=$P(REC,U)
S NARR=$$DESCICD(ICD,$G(BLRVDT))
S DESC=$$DIAGICD(ICD,$G(BLRVDT))
S CODESYS=+$$GET1^DIQ(80,ICD,"CODING SYSTEM","I")
Q:$D(ICDCODSY(CODESYS))<1
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
S BLRI=BLRI+1
; S @BLRY@(BLRI)=DESC_U_ICD_U_NARR_U_CODE
S @BLRY@(BLRI)=DESC_U_ICD_U_NARR_U_CODE_U_CODESYS ; IHS/MSC/MKK - LR*5.2*1034
Q
;
ORL(BLRY,BLRINP) ;return order reasons from file 100.03
; rpc: BLR ORDER REASON LKUP
; BLRINP = (optional) Partial name lookup - free text
; Returned as a list of records in the format:
; 0 1
; IEN ^ NAME
; If the DEFAULT DC REASON from the LABORATORY SITE file 69.9 is
; defined, it will be the 1st entry in the return.
N BLRDEF,BLRI,BLRIEN,BLRJ
S BLRINP=$G(BLRINP)
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
S BLRI=0
K ^TMP("BLRAG",$J)
S BLRY=$$TMPGLB^BLRAGUT()
; 0 1
S @BLRY@(0)="IEN^NAME"
S BLRDEF=$P($G(^LAB(69.9,1,"OR")),"^",2)
I BLRDEF'="" S BLRI=BLRI+1 S @BLRY@(BLRI)=BLRDEF_U_$P($G(^ORD(100.03,BLRDEF,0)),U,1) ;set default DC reason as first entry
S BLRJ=$S(BLRINP'="":$$PREP^BLRAGUT(BLRINP),1:"") F S BLRJ=$O(^ORD(100.03,"B",BLRJ)) Q:BLRJ="" Q:BLRINP'[$E(BLRJ,1,$L(BLRINP)) D
.S BLRIEN=$O(^ORD(100.03,"B",BLRJ,0))
.S BLRI=BLRI+1 S @BLRY@(BLRI)=BLRIEN_U_BLRJ
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; AICD 4.0 modified ICD9 global. Need new functions to retrieve data.
;
FINDER(BLRINP,RES) ; EP - Mimic FIND^DIC call
NEW ICD,ICDSTR
;
K RES
;
S ICDSTR=$$ICDDX^ICDEX(BLRINP)
Q:+ICDSTR<1
;
S RES("DILIST",0)="1^*^0^"
S RES("DILIST",0,"MAP")=".01^10"
S RES("DILIST",1,1)=$P(ICDSTR,"^",2)
S RES("DILIST",2,1)=+ICDSTR
S RES("DILIST","ID",1,.01)=$P(ICDSTR,"^",2)
S ICD=+ICDSTR
S RES("DILIST","ID",1,10)=$$DESCICD(ICD)
Q
;
DESCICD(ICD,BLRVDT) ; EP - DESCRIPTION is now a multiple
NEW DESCDATE,DESCNUM,DESCRIP
;
S DESCRIP=$G(^ICD9(ICD,68,+$O(^ICD9(ICD,68,"A"),-1),1)) ; Most Current Description
;
I +$G(BLRVDT) D ; If there is date, retrieve description current as of that date
. S BLRVDT=$$FMADD^XLFDT(BLRVDT,-1) ; "Back up" 1 day to account for $ORDER function
. S DESCDATE=$O(^ICD9(ICD,68,"B",BLRVDT))
. Q:DESCDATE<1
. ;
. S DESCNUM=$O(^ICD9(ICD,68,"B",DESCDATE,0))
. Q:DESCNUM<1
. ;
. S DESCRIP=$G(^ICD9(ICD,68,DESCNUM,1))
;
Q DESCRIP
;
DIAGICD(ICD,BLRVDT) ; EP - DIAGNOSIS is now a multiple
NEW DIAGDATE,DIAGNUM,DIAGDESC
;
S DIAGDESC=$P($G(^ICD9(ICD,67,+$O(^ICD9(ICD,67,"A"),-1),0)),"^",2) ; Most Current Diagnosis
;
I +$G(BLRVDT) D ; If there is date, retrieve diagnosis current as of that date
. S BLRVDT=$$FMADD^XLFDT(BLRVDT,-1) ; "Back up" 1 day to account for $ORDER function
. S DIAGDATE=$O(^ICD9(ICD,67,"B",BLRVDT))
. Q:DIAGDATE<1
. ;
. S DIAGNUM=$O(^ICD9(ICD,67,"B",DIAGDATE,0))
. Q:DIAGNUM<1
. ;
. S DIAGDESC=$P($G(^ICD9(ICD,67,DIAGNUM,0)),"^",2)
;
Q DIAGDESC
;
INACTDT(ICD,BLRVDT) ; EP - STATUS EFFECTIVE DATE is part of the STATUS Multiple.
Q:$G(BLRVDT)<1 0 ; If no date, then cannot check STATUS EFFECTIVE DATE ==> Not Inactive
;
NEW STATUS,STSDATE,STSNUM
;
S BLRVDT=$$FMADD^XLFDT(BLRVDT,-1) ; "Back up" 1 day to account for $ORDER function
S STSDATE=$O(^ICD9(ICD,66,"B",BLRVDT))
Q:STSDATE<1 0 ; If no STATUS EFFECTIVE DATE ==> Not Inactive
;
Q:STSDATE>BLRVDT 0 ; If STATUS EFFECTIVE DATE > BLRVDT, then cannot check STATUS ==> Not Inactive
;
S STSNUM=$O(^ICD9(ICD,66,"B",STSDATE,0))
Q:STSNUM<1 0 ; If no STATUS ==> Not Inactive
;
S STATUS=+$G(^ICD9(ICD,66,STSNUM,0))
Q $S(STATUS=1:0,1:1) ; STATUS = 1 ==> ACTIVE; STATUS = 0 ==> INACTIVE
;
; The following routine sets the ICDCODSY array based upon the values
; in the ICD CODING SYSTEMS file, using the BLRVDT.
ICDCODSY(BLRVDT,ICDCODSY) ; EP - Set the ICDCODSY array
NEW CODESYS,CODESYSA,IEN,IMPLDATE,TMP
;
K ICDCODSY
;
; Sort by implementation date
S IEN=.9999999
F S IEN=$O(^ICDS(IEN)) Q:IEN<1 D
. S IMPLDATE=$$GET1^DIQ(80.4,IEN,"IMPLEMENTATION DATE","I")
. S CODESYSA=$$GET1^DIQ(80.4,IEN,"CODING SYSTEM ABBREVIATION")
. S CODESYS=$O(^ICDS("C",CODESYSA,0))
. S TMP(IMPLDATE,IEN)=CODESYS
;
; Find the implementation date less than or equal to BLRVDT
S IMPLDATE="A"
F S IMPLDATE=$O(TMP(IMPLDATE),-1) Q:IMPLDATE<1!($D(ICDCODSY)) D
. I IMPLDATE'>BLRVDT D
.. S IEN=0
.. F S IEN=$O(TMP(IMPLDATE,IEN)) Q:IEN<1 S ICDCODSY(+$G(TMP(IMPLDATE,IEN)))=""
Q
;
; TESTIT
TESTIT ; EP - Interactively test ICDLKUP call
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
K ^TMP("BLRAG")
;
S HEADER(1)="Interactively Test ICDLKUP^BLRAG07"
;
D HEADERDT^BLRGMENU
;
D ^XBFMK
S DIR(0)="DO"
S DIR("A")="BLRVDT (Date passed to $$ICDDX^ICDEX)"
S DIR("B")=$$DT^XLFDT
D ^DIR
Q:+$G(DIRUT) $$BADSTUFN("No/Quit/Invalid Entry.")
;
S:+Y BLRVDT=+Y
S BLRVDT=$G(BLRVDT,$$DT^XLFDT)
;
S HEADER(2)="Search Date:"_$$FMTE^XLFDT(BLRVDT,"5DZ")
;
S BLRLEX=$G(BLRLEX)
S BLRGEN=$G(BLRGEN)
S BLRECOD=$G(BLRECOD)
S BLRVCOD=$G(BLRVCOD)
;
D HEADERDT^BLRGMENU
;
D ^XBFMK
S DIR(0)="FO"
S DIR("A")="Enter ICD Lookup String"
D ^DIR
Q:+$G(DIRUT) $$BADSTUFN("No/Quit/Invalid Entry.")
;
S BLRINP=$G(X)
D ICDLKUP(.BLRY,BLRINP,,BLRVDT)
;
S HEADER(3)=$$CJ^XLFSTR("Lookup String:"_BLRINP,IOM)
S HEADER(4)=$$CJ^XLFSTR("Data Stored at "_BLRY,IOM)
S HEADER(5)=" "
S $E(HEADER(6),19)="CODE"
S HEADER(7)="BLRI"
S $E(HEADER(7),9)="ICD"
S $E(HEADER(7),19)="SYS"
S $E(HEADER(7),25)="Description"
S (CNT,PG)=0
S MAXLINES=IOSL-4,LINES=MAXLINES+10
S QFLG="NO"
;
S BLRI=0
F S BLRI=$O(@BLRY@(BLRI)) Q:BLRI<1!(QFLG="Q") D
. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO") Q:QFLG="Q"
. S STR=$G(@BLRY@(BLRI))
. W $J(BLRI,4),?8,$P(STR,"^",4),?19,$P(STR,"^",5)
. D LINEWRAP^BLRGMENU(24,$P(STR,"^"),56)
. W !
. S LINES=LINES+1
. S CNT=CNT+1
;
D PRESSKEY^BLRGMENU(9)
;
Q
;
BADSTUFN(MSG) ; EP - Display Message and Quit with ""
W !!,?4,MSG," Routine Ends."
D PRESSKEY^BLRGMENU(9)
Q ""
;
; ----- END IHS/MSC/MKK - LR*5.2*1034
BLRAG07 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1031,1034**;NOV 01, 1997;Build 88
+2 ;
+3 ; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
+4 ; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
+5 ; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
+6 ; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
+7 ; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
+8 ; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
+9 ;
+10 ; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
+11 ; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
+12 ; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
+13 ; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
+14 ; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
+15 ; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
+16 ; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
+17 ;
+18 ; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
+19 ; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
+20 ; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
+21 ; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
+22 ; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
+23 ; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest\
+24 ; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
+25 ; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
+26 ;
+27 ;---------------------------------------------------------------
+28 ; Lookup ICD's matching input
+29 ; BLRINP = (required) Partial name lookup - free text
+30 ; BLRLEX = (optional) Use Lexicon
+31 ; 0=ICD9 lookup (default)
+32 ; 1=Lexicon lookup
+33 ; BLRVDT = (optional) Visit date in external format
+34 ; BLRGEN = (optional) patient gender
+35 ; BLRECOD = (optional) allow ECodes flag:
+36 ; 0=exclude (default)
+37 ; 1=include
+38 ; 2=ecodes only
+39 ; BLRVCOD = (optional) allow VCodes flag:
+40 ; 0=include
+41 ; 1=exclude
+42 ; 2=vcodes only
+43 ; Returned as a list of records in the format:
+44 ; 0 1 2 3
+45 ; Descriptive Text ^ ICD IEN ^ Narrative Text ^ ICD Code
+46 ;
+47 ;
ICDLKUP(BLRY,BLRINP,BLRLEX,BLRVDT,BLRGEN,BLRECOD,BLRVCOD) ;EP - ICD lookup
+1 ; rpc: BLR ICD LOOKUP
+2 ;INPUT:
+3 ; BLRINP = (required) Partial name lookup - free text; must be at least 3 characters
+4 ; BLRLEX = (optional) Use Lexicon
+5 ; 0=ICD9 lookup (default)
+6 ; 1=Lexicon lookup
+7 ; BLRVDT = (optional) Visit date in external format
+8 ; BLRGEN = (optional) patient gender
+9 ; BLRECOD = (optional) allow ECodes flag:
+10 ; 0=exclude (default)
+11 ; 1=include
+12 ; 2=ecodes only
+13 ; BLRVCOD = (optional) allow VCodes flag:
+14 ; 0=include
+15 ; 1=exclude
+16 ; 2=vcodes only
+17 ;RETURN:
+18 ; Returned as a list of records in the format:
+19 ; 0 1 2 3
+20 ; Descriptive Text ^ ICD IEN ^ Narrative Text ^ ICD Code
+21 ;
+22 NEW DIC,X,Y,I,ICD,LEX,RES
+23 NEW AICDRET,XTLKSAY,REC,DESC,CODE,NARR
+24 NEW BLRI
+25 NEW CODESYS
+26 ; IHS/MSC/MKK - LR*5.2*1034
NEW ICDCODSY
+27 ;
+28 SET BLRLEX=$GET(BLRLEX)
+29 ; S BLRVDT=$G(BLRVDT)
+30 ; IHS/MSC/MKK - LR*5.2*1034
SET BLRVDT=$GET(BLRVDT,$$DT^XLFDT)
+31 ;
+32 ; IHS/MSC/MKK - LR*5.2*1034
DO ICDCODSY(BLRVDT,.ICDCODSY)
+33 ;
+34 SET BLRGEN=$GET(BLRGEN)
+35 SET BLRECOD=$GET(BLRECOD)
+36 SET BLRVCOD=$GET(BLRVCOD)
+37 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+38 SET BLRI=0
+39 KILL ^TMP("BLRAG",$JOB)
+40 SET BLRY=$$TMPGLB^BLRAGUT()
+41 SET @BLRY@(0)="ERROR_ID"
+42 ;
+43 IF $LENGTH($GET(BLRINP))<3
DO ERR^BLRAGUT("BLRAG07: User name lookup requires at least 3 characters.")
QUIT
+44 ;convert date to FM format
IF BLRVDT'=""
SET BLRVDT=$$CVTDATE^BLRAGUT(BLRVDT)
+45 ;
+46 IF BLRLEX
Begin DoDot:1
+47 NEW HITS
+48 DO LEXLKUP^BLRAGUT(.HITS,BLRINP_"^ICD")
+49 SET HITS=0
+50 FOR
SET HITS=$ORDER(HITS(HITS))
IF 'HITS
QUIT
Begin DoDot:2
+51 SET BLRLEX=+HITS(HITS)
+52 SET X=$$ICDONE^LEXU(BLRLEX)
+53 IF X=""
QUIT
+54 SET ICD=$ORDER(^ICD9("BA",X,0))
+55 IF 'ICD
SET ICD=$ORDER(^ICD9("BA",X_" ",0))
+56 IF ICD
DO CHKHITS
End DoDot:2
End DoDot:1
+57 IF '$TEST
IF $GET(DUZ("AG"))="I"
Begin DoDot:1
+58 SET DIC="^ICD9("
SET DIC(0)="TM"
SET X=BLRINP
SET XTLKSAY=0
+59 ; K ^UTILITY("AICDHITS",$J),^TMP("XTLKHITS",$J)
+60 ; IHS/MSC/MKK - LR*5.2*1034
KILL ^TMP("ICD9",$JOB),^TMP("XTLKHITS",$JOB)
+61 DO ^DIC
+62 ; I Y'=-1 D
+63 ; IHS/MSC/MKK - LR*5.2*1034
IF +Y'=-1
Begin DoDot:2
+64 SET ICD=+Y
+65 DO CHKHITS
End DoDot:2
+66 IF '$TEST
IF $GET(^DD(80,0,"DIC"))="XTLKDICL"
Begin DoDot:2
+67 DO XTLKUP
End DoDot:2
+68 IF '$TEST
DO AICDLKUP
+69 IF 'BLRI
IF $LENGTH(BLRINP)>2
Begin DoDot:2
+70 NEW LK,LN
+71 SET LK=BLRINP
SET LN=$LENGTH(BLRINP)
+72 FOR
Begin DoDot:3
+73 SET ICD=0
+74 FOR
SET ICD=$ORDER(^ICD9("BA",LK,ICD))
IF 'ICD
QUIT
DO CHKHITS
End DoDot:3
SET LK=$ORDER(^ICD9("BA",LK))
IF $EXTRACT(LK,1,LN)'=BLRINP
QUIT
End DoDot:2
+75 KILL ^UTILITY("AICDHITS",$JOB),^TMP("XTLKHITS",$JOB)
End DoDot:1
+76 IF '$TEST
Begin DoDot:1
+77 ; D FIND^DIC(80,,".01;10","M",BLRINP,,,,,"RES")
+78 ; IHS/MSC/MKK - LR*5.2*1034
DO FINDER(BLRINP,.RES)
+79 IF '$ORDER(RES("DILIST",0))
QUIT
+80 MERGE ^TMP("XTLKHITS",$JOB)=RES("DILIST",2)
+81 DO XTLKUP
+82 KILL ^TMP("XTLKHITS",$JOB)
End DoDot:1
+83 KILL @BLRY@(0)
+84 ; 0 1 2 3
+85 ; S @BLRY@(0)="DESCRIPTION^ICD_IEN^NARRATIVE^ICD_CODE"
+86 ;
+87 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+88 ; 0 1 2 3 4
+89 SET @BLRY@(0)="DESCRIPTION^ICD_IEN^NARRATIVE^ICD_CODE^CODING_SYSTEM"
+90 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+91 QUIT
+92 ;
AICDLKUP SET I=0
+1 ; F S I=$O(^UTILITY("AICDHITS",$J,I)) Q:'I D
+2 ; .S ICD=$G(^UTILITY("AICDHITS",$J,I))
+3 ; .D CHKHITS
+4 ;
+5 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+6 ; AICD*4.0 Stores "Hits" in ^TMP("ICD9",$J not in ^UTILITY("AICDHITS",$J
+7 FOR
SET I=$ORDER(^TMP("ICD9",$JOB,"SEL",I))
IF I<1
QUIT
Begin DoDot:1
+8 SET ICD=+$GET(^TMP("ICD9",$JOB,"SEL",I))
+9 DO CHKHITS
End DoDot:1
+10 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+11 ;
+12 QUIT
+13 ;
XTLKUP SET I=0
+1 FOR
SET I=$ORDER(^TMP("XTLKHITS",$JOB,I))
IF 'I
QUIT
Begin DoDot:1
+2 SET ICD=$GET(^TMP("XTLKHITS",$JOB,I))
+3 DO CHKHITS
End DoDot:1
+4 QUIT
+5 ;
CHKHITS IF $DATA(@BLRY@(0,ICD))
QUIT
SET @BLRY@(0,ICD)=""
+1 SET REC=$GET(^ICD9(ICD,0))
+2 DO ENTRYAUD^BLRUTIL("CHKHITS^BLRAG07 0.0")
+3 ; Q:$P(REC,U,9)
+4 ;
+5 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+6 ; AICD 4.0 modified File 80. There is no longer an INACTIVE FLAG.
+7 ; STATUS is now a multiple. Note that STATUS=1 is ACTIVE; STATUS=0 is INACTIVE.
+8 ; Most Current Status
IF '$PIECE($GET(^ICD9(ICD,66,+$ORDER(^ICD9(ICD,66,"A"),-1),0)),"^",2)
QUIT
+9 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+10 ;
+11 IF 'BLRECOD
IF $EXTRACT(REC)="E"
QUIT
+12 IF BLRECOD=2
IF $EXTRACT(REC)'="E"
QUIT
+13 IF BLRVCOD=1
IF $EXTRACT(REC)="V"
QUIT
+14 IF BLRVCOD=2
IF $EXTRACT(REC)'="V"
QUIT
+15 ;
+16 DO ENTRYAUD^BLRUTIL("CHKHITS^BLRAG07 3.0")
+17 ;
+18 ; I BLRVDT,$P(REC,U,11),$$FMDIFF^XLFDT(BLRVDT,$P(REC,U,11))>-1 Q
+19 ; IHS/MSC/MKK - LR*5.2*1034
IF $$INACTDT(ICD,BLRVDT)
QUIT
+20 ;
+21 IF $LENGTH(BLRGEN)
IF $PIECE(REC,U,10)'=""
IF BLRGEN'=$PIECE(REC,U,10)
QUIT
+22 ;
+23 ; S NARR=$G(^ICD9(ICD,1)),CODE=$P(REC,U),DESC=$P(REC,U,3)
+24 ;
+25 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+26 NEW CODE,NARR,DESC,CODESYS,ICD10ID,IMPLDATE
+27 SET CODE=$PIECE(REC,U)
+28 SET NARR=$$DESCICD(ICD,$GET(BLRVDT))
+29 SET DESC=$$DIAGICD(ICD,$GET(BLRVDT))
+30 SET CODESYS=+$$GET1^DIQ(80,ICD,"CODING SYSTEM","I")
+31 IF $DATA(ICDCODSY(CODESYS))<1
QUIT
+32 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+33 ;
+34 SET BLRI=BLRI+1
+35 ; S @BLRY@(BLRI)=DESC_U_ICD_U_NARR_U_CODE
+36 ; IHS/MSC/MKK - LR*5.2*1034
SET @BLRY@(BLRI)=DESC_U_ICD_U_NARR_U_CODE_U_CODESYS
+37 QUIT
+38 ;
ORL(BLRY,BLRINP) ;return order reasons from file 100.03
+1 ; rpc: BLR ORDER REASON LKUP
+2 ; BLRINP = (optional) Partial name lookup - free text
+3 ; Returned as a list of records in the format:
+4 ; 0 1
+5 ; IEN ^ NAME
+6 ; If the DEFAULT DC REASON from the LABORATORY SITE file 69.9 is
+7 ; defined, it will be the 1st entry in the return.
+8 NEW BLRDEF,BLRI,BLRIEN,BLRJ
+9 SET BLRINP=$GET(BLRINP)
+10 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+11 SET BLRI=0
+12 KILL ^TMP("BLRAG",$JOB)
+13 SET BLRY=$$TMPGLB^BLRAGUT()
+14 ; 0 1
+15 SET @BLRY@(0)="IEN^NAME"
+16 SET BLRDEF=$PIECE($GET(^LAB(69.9,1,"OR")),"^",2)
+17 ;set default DC reason as first entry
IF BLRDEF'=""
SET BLRI=BLRI+1
SET @BLRY@(BLRI)=BLRDEF_U_$PIECE($GET(^ORD(100.03,BLRDEF,0)),U,1)
+18 SET BLRJ=$SELECT(BLRINP'="":$$PREP^BLRAGUT(BLRINP),1:"")
FOR
SET BLRJ=$ORDER(^ORD(100.03,"B",BLRJ))
IF BLRJ=""
QUIT
IF BLRINP'[$EXTRACT(BLRJ,1,$LENGTH(BLRINP))
QUIT
Begin DoDot:1
+19 SET BLRIEN=$ORDER(^ORD(100.03,"B",BLRJ,0))
+20 SET BLRI=BLRI+1
SET @BLRY@(BLRI)=BLRIEN_U_BLRJ
End DoDot:1
+21 QUIT
+22 ;
+23 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+24 ; AICD 4.0 modified ICD9 global. Need new functions to retrieve data.
+25 ;
FINDER(BLRINP,RES) ; EP - Mimic FIND^DIC call
+1 NEW ICD,ICDSTR
+2 ;
+3 KILL RES
+4 ;
+5 SET ICDSTR=$$ICDDX^ICDEX(BLRINP)
+6 IF +ICDSTR<1
QUIT
+7 ;
+8 SET RES("DILIST",0)="1^*^0^"
+9 SET RES("DILIST",0,"MAP")=".01^10"
+10 SET RES("DILIST",1,1)=$PIECE(ICDSTR,"^",2)
+11 SET RES("DILIST",2,1)=+ICDSTR
+12 SET RES("DILIST","ID",1,.01)=$PIECE(ICDSTR,"^",2)
+13 SET ICD=+ICDSTR
+14 SET RES("DILIST","ID",1,10)=$$DESCICD(ICD)
+15 QUIT
+16 ;
DESCICD(ICD,BLRVDT) ; EP - DESCRIPTION is now a multiple
+1 NEW DESCDATE,DESCNUM,DESCRIP
+2 ;
+3 ; Most Current Description
SET DESCRIP=$GET(^ICD9(ICD,68,+$ORDER(^ICD9(ICD,68,"A"),-1),1))
+4 ;
+5 ; If there is date, retrieve description current as of that date
IF +$GET(BLRVDT)
Begin DoDot:1
+6 ; "Back up" 1 day to account for $ORDER function
SET BLRVDT=$$FMADD^XLFDT(BLRVDT,-1)
+7 SET DESCDATE=$ORDER(^ICD9(ICD,68,"B",BLRVDT))
+8 IF DESCDATE<1
QUIT
+9 ;
+10 SET DESCNUM=$ORDER(^ICD9(ICD,68,"B",DESCDATE,0))
+11 IF DESCNUM<1
QUIT
+12 ;
+13 SET DESCRIP=$GET(^ICD9(ICD,68,DESCNUM,1))
End DoDot:1
+14 ;
+15 QUIT DESCRIP
+16 ;
DIAGICD(ICD,BLRVDT) ; EP - DIAGNOSIS is now a multiple
+1 NEW DIAGDATE,DIAGNUM,DIAGDESC
+2 ;
+3 ; Most Current Diagnosis
SET DIAGDESC=$PIECE($GET(^ICD9(ICD,67,+$ORDER(^ICD9(ICD,67,"A"),-1),0)),"^",2)
+4 ;
+5 ; If there is date, retrieve diagnosis current as of that date
IF +$GET(BLRVDT)
Begin DoDot:1
+6 ; "Back up" 1 day to account for $ORDER function
SET BLRVDT=$$FMADD^XLFDT(BLRVDT,-1)
+7 SET DIAGDATE=$ORDER(^ICD9(ICD,67,"B",BLRVDT))
+8 IF DIAGDATE<1
QUIT
+9 ;
+10 SET DIAGNUM=$ORDER(^ICD9(ICD,67,"B",DIAGDATE,0))
+11 IF DIAGNUM<1
QUIT
+12 ;
+13 SET DIAGDESC=$PIECE($GET(^ICD9(ICD,67,DIAGNUM,0)),"^",2)
End DoDot:1
+14 ;
+15 QUIT DIAGDESC
+16 ;
INACTDT(ICD,BLRVDT) ; EP - STATUS EFFECTIVE DATE is part of the STATUS Multiple.
+1 ; If no date, then cannot check STATUS EFFECTIVE DATE ==> Not Inactive
IF $GET(BLRVDT)<1
QUIT 0
+2 ;
+3 NEW STATUS,STSDATE,STSNUM
+4 ;
+5 ; "Back up" 1 day to account for $ORDER function
SET BLRVDT=$$FMADD^XLFDT(BLRVDT,-1)
+6 SET STSDATE=$ORDER(^ICD9(ICD,66,"B",BLRVDT))
+7 ; If no STATUS EFFECTIVE DATE ==> Not Inactive
IF STSDATE<1
QUIT 0
+8 ;
+9 ; If STATUS EFFECTIVE DATE > BLRVDT, then cannot check STATUS ==> Not Inactive
IF STSDATE>BLRVDT
QUIT 0
+10 ;
+11 SET STSNUM=$ORDER(^ICD9(ICD,66,"B",STSDATE,0))
+12 ; If no STATUS ==> Not Inactive
IF STSNUM<1
QUIT 0
+13 ;
+14 SET STATUS=+$GET(^ICD9(ICD,66,STSNUM,0))
+15 ; STATUS = 1 ==> ACTIVE; STATUS = 0 ==> INACTIVE
QUIT $SELECT(STATUS=1:0,1:1)
+16 ;
+17 ; The following routine sets the ICDCODSY array based upon the values
+18 ; in the ICD CODING SYSTEMS file, using the BLRVDT.
ICDCODSY(BLRVDT,ICDCODSY) ; EP - Set the ICDCODSY array
+1 NEW CODESYS,CODESYSA,IEN,IMPLDATE,TMP
+2 ;
+3 KILL ICDCODSY
+4 ;
+5 ; Sort by implementation date
+6 SET IEN=.9999999
+7 FOR
SET IEN=$ORDER(^ICDS(IEN))
IF IEN<1
QUIT
Begin DoDot:1
+8 SET IMPLDATE=$$GET1^DIQ(80.4,IEN,"IMPLEMENTATION DATE","I")
+9 SET CODESYSA=$$GET1^DIQ(80.4,IEN,"CODING SYSTEM ABBREVIATION")
+10 SET CODESYS=$ORDER(^ICDS("C",CODESYSA,0))
+11 SET TMP(IMPLDATE,IEN)=CODESYS
End DoDot:1
+12 ;
+13 ; Find the implementation date less than or equal to BLRVDT
+14 SET IMPLDATE="A"
+15 FOR
SET IMPLDATE=$ORDER(TMP(IMPLDATE),-1)
IF IMPLDATE<1!($DATA(ICDCODSY))
QUIT
Begin DoDot:1
+16 IF IMPLDATE'>BLRVDT
Begin DoDot:2
+17 SET IEN=0
+18 FOR
SET IEN=$ORDER(TMP(IMPLDATE,IEN))
IF IEN<1
QUIT
SET ICDCODSY(+$GET(TMP(IMPLDATE,IEN)))=""
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ; TESTIT
TESTIT ; EP - Interactively test ICDLKUP call
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 KILL ^TMP("BLRAG")
+4 ;
+5 SET HEADER(1)="Interactively Test ICDLKUP^BLRAG07"
+6 ;
+7 DO HEADERDT^BLRGMENU
+8 ;
+9 DO ^XBFMK
+10 SET DIR(0)="DO"
+11 SET DIR("A")="BLRVDT (Date passed to $$ICDDX^ICDEX)"
+12 SET DIR("B")=$$DT^XLFDT
+13 DO ^DIR
+14 IF +$GET(DIRUT)
QUIT $$BADSTUFN("No/Quit/Invalid Entry.")
+15 ;
+16 IF +Y
SET BLRVDT=+Y
+17 SET BLRVDT=$GET(BLRVDT,$$DT^XLFDT)
+18 ;
+19 SET HEADER(2)="Search Date:"_$$FMTE^XLFDT(BLRVDT,"5DZ")
+20 ;
+21 SET BLRLEX=$GET(BLRLEX)
+22 SET BLRGEN=$GET(BLRGEN)
+23 SET BLRECOD=$GET(BLRECOD)
+24 SET BLRVCOD=$GET(BLRVCOD)
+25 ;
+26 DO HEADERDT^BLRGMENU
+27 ;
+28 DO ^XBFMK
+29 SET DIR(0)="FO"
+30 SET DIR("A")="Enter ICD Lookup String"
+31 DO ^DIR
+32 IF +$GET(DIRUT)
QUIT $$BADSTUFN("No/Quit/Invalid Entry.")
+33 ;
+34 SET BLRINP=$GET(X)
+35 DO ICDLKUP(.BLRY,BLRINP,,BLRVDT)
+36 ;
+37 SET HEADER(3)=$$CJ^XLFSTR("Lookup String:"_BLRINP,IOM)
+38 SET HEADER(4)=$$CJ^XLFSTR("Data Stored at "_BLRY,IOM)
+39 SET HEADER(5)=" "
+40 SET $EXTRACT(HEADER(6),19)="CODE"
+41 SET HEADER(7)="BLRI"
+42 SET $EXTRACT(HEADER(7),9)="ICD"
+43 SET $EXTRACT(HEADER(7),19)="SYS"
+44 SET $EXTRACT(HEADER(7),25)="Description"
+45 SET (CNT,PG)=0
+46 SET MAXLINES=IOSL-4
SET LINES=MAXLINES+10
+47 SET QFLG="NO"
+48 ;
+49 SET BLRI=0
+50 FOR
SET BLRI=$ORDER(@BLRY@(BLRI))
IF BLRI<1!(QFLG="Q")
QUIT
Begin DoDot:1
+51 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,"NO")
IF QFLG="Q"
QUIT
+52 SET STR=$GET(@BLRY@(BLRI))
+53 WRITE $JUSTIFY(BLRI,4),?8,$PIECE(STR,"^",4),?19,$PIECE(STR,"^",5)
+54 DO LINEWRAP^BLRGMENU(24,$PIECE(STR,"^"),56)
+55 WRITE !
+56 SET LINES=LINES+1
+57 SET CNT=CNT+1
End DoDot:1
+58 ;
+59 DO PRESSKEY^BLRGMENU(9)
+60 ;
+61 QUIT
+62 ;
BADSTUFN(MSG) ; EP - Display Message and Quit with ""
+1 WRITE !!,?4,MSG," Routine Ends."
+2 DO PRESSKEY^BLRGMENU(9)
+3 QUIT ""
+4 ;
+5 ; ----- END IHS/MSC/MKK - LR*5.2*1034
