BGOICDLK ; IHS/BAO/TMD - FHL - PROGRAM TO GET LIST OF DIAGNOSES ;06-Mar-2014 20:24;DU
;;1.1;BGO COMPONENTS;**1,3,6,8,9,12,14**;Mar 20, 2007;Build 5
;---------------------------------------------------------------
; Lookup ICD's matching input
; INP = Lookup Value [1] ^ Use Lexicon [2] ^ Visit Date [3] ^
; Patient Gender [4] ^ ECodes [5] ^ VCodes [6]
; where ECodes = 0: exclude, 1: include, 2: only ecodes
; VCodes = 0: include, 1: exclude, 2: only vcodes
; Returned as a list of records in the format:
; Descriptive Text [1] ^ ICD IEN [2] ^ Narrative Text [3] ^ ICD Code [4]
; Patch 12 updated for new ICD lookup
ICDLKUP(RET,INP) ;PEP - ICD lookup
N LKUP,VDT,SEX,ECD,VCD,CNT,DIC,X,Y,I,ICD,LEX,RES,IEN
N AICDRET,XTLKSAY,REC,DESC,CODE,NARR,SYS,INJ,APP,IMP
S RET=$$TMPGBL^BGOUTL
S LKUP=$P(INP,U)
S LEX=$P(INP,U,2)
S VDT=$$CVTDATE^BGOUTL($P(INP,U,3))
I VDT="" S VDT=DT
S SEX=$P(INP,U,4)
S ECD=$P(INP,U,5)
S VCD=$P(INP,U,6)
S CNT=0
;Patch 14 find coding system
S SYS=$$IMP^AUPNSICD(VDT)
S IMP=$$IMP^ICDEX("10D",DT)
I LEX D
.N HITS
.I $$AICD^BGOUTL2 D
..S APP=$S(IMP<VDT:"10D",1:"ICD")
.D LEXLKUP^BGOUTL(.HITS,LKUP_U_APP_U_VDT)
.S HITS=0
.F S HITS=$O(HITS(HITS)) Q:'HITS D
..S LEX=+HITS(HITS)
..;I APP="ICD" S X=$$ICDONE^LEXU(LEX.VDT,APP)
..S X=$$ONE^LEXU(LEX,VDT,APP)
..Q:X=""
..;S ICD=$O(^ICD9("BA",X,0))
..;S:'ICD ICD=$O(^ICD9("BA",X_" ",0))
..I $$AICD^BGOUTL2 S ICD=$P($$ICDDX^ICDEX(X,VDT),U,1)
..E S ICD=$P($$ICDDX^ICDCODE(X,VDT),U,1)
..D:ICD CHKHITS
E I $G(DUZ("AG"))="I" D
.S DIC="^ICD9(",DIC(0)="TM",X=LKUP,XTLKSAY=0
.K ^UTILITY("AICDHITS",$J),^TMP("XTLKHITS",$J)
.D ^DIC
.I $P(Y,U,1)'=-1 D
..S ICD=+Y
..D CHKHITS
.E I $G(^DD(80,0,"DIC"))="XTLKDICL" D
..D XTLKUP
.E D AICDLKUP
.I 'CNT,$L(LKUP)>2 D
..N LK,LN
..S LK=LKUP,LN=$L(LKUP)
..F D S LK=$O(^ICD9("BA",LK)) Q:$E(LK,1,LN)'=LKUP
...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",LKUP,,,,,"RES")
.I '$O(RES("DILIST",0)) Q
.M ^TMP("XTLKHITS",$J)=RES("DILIST",2)
.D XTLKUP
.K ^TMP("XTLKHITS",$J)
K @RET@(0)
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
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(@RET@(0,ICD)) S ^(ICD)=""
I $$AICD^BGOUTL2 S IEN=$$ICDDX^ICDEX(ICD,VDT)
E S IEN=$$ICDDX^ICDCODE(ICD,VDT)
;I IEN>0&($P(IEN,U,10)=1) D ;PATCH 8
I +IEN>0&($P(IEN,U,12)="") D
.S CNT=CNT+1
.;Patch 12
.I $$AICD^BGOUTL2 D
..S NARR=$$LD^ICDEX(80,+IEN,VDT)
..S INJ=$$CHKINJ(IEN,SYS)
.E D
..;Patch 9
..S NARR=$G(^ICD9(ICD,1))
..I NARR="" S NARR=$P(+IEN,U,4)
..S INJ=$$CHKINJ(IEN,SYS)
.I 'ECD,INJ=1 Q
.I ECD=2,INJ=0 Q
.S @RET@(CNT)=$P(IEN,U,4)_U_ICD_U_NARR_U_$P(IEN,U,2)
Q
CHKINJ(IEN,SYS) ;Check for an injury code
N J
S J=0
;Patch 14 changed injury code lookup
I SYS=30 D
.I $E($P(IEN,U,2),1)="V" S J=1 ;only codes V00-Y99 per Leslie Racine.
.I $E($P(IEN,U,2),1)="W" S J=1
.I $E($P(IEN,U,2),1)="X" S J=1
.I $E($P(IEN,U,2),1)="Y" S J=1 D
..I $P(IEN,".",1)'="Y92" S J=1
E D
.I $E($P(IEN,U,2))="E" S J=1
Q J
; Retrieve diagnosis list
DXLIST(RET,INP) ;PEP - retrieve dx list
N LKUP,VDT,SEX,ECD,VCD,MAX,MORE
S LKUP=$P(INP,U)
S MAX=$P(INP,U,2)
S MORE=$P(INP,U,3)
S VDT=$P(INP,U,4)
S SEX=$P(INP,U,5)
S ECD=$P(INP,U,6)
S VCD=$P(INP,U,7)
D ICDLKUP(.RET,LKUP_U_VDT_U_SEX_U_ECD_U_VCD)
Q
BGOICDLK ; IHS/BAO/TMD - FHL - PROGRAM TO GET LIST OF DIAGNOSES ;06-Mar-2014 20:24;DU
+1 ;;1.1;BGO COMPONENTS;**1,3,6,8,9,12,14**;Mar 20, 2007;Build 5
+2 ;---------------------------------------------------------------
+3 ; Lookup ICD's matching input
+4 ; INP = Lookup Value [1] ^ Use Lexicon [2] ^ Visit Date [3] ^
+5 ; Patient Gender [4] ^ ECodes [5] ^ VCodes [6]
+6 ; where ECodes = 0: exclude, 1: include, 2: only ecodes
+7 ; VCodes = 0: include, 1: exclude, 2: only vcodes
+8 ; Returned as a list of records in the format:
+9 ; Descriptive Text [1] ^ ICD IEN [2] ^ Narrative Text [3] ^ ICD Code [4]
+10 ; Patch 12 updated for new ICD lookup
ICDLKUP(RET,INP) ;PEP - ICD lookup
+1 NEW LKUP,VDT,SEX,ECD,VCD,CNT,DIC,X,Y,I,ICD,LEX,RES,IEN
+2 NEW AICDRET,XTLKSAY,REC,DESC,CODE,NARR,SYS,INJ,APP,IMP
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET LKUP=$PIECE(INP,U)
+5 SET LEX=$PIECE(INP,U,2)
+6 SET VDT=$$CVTDATE^BGOUTL($PIECE(INP,U,3))
+7 IF VDT=""
SET VDT=DT
+8 SET SEX=$PIECE(INP,U,4)
+9 SET ECD=$PIECE(INP,U,5)
+10 SET VCD=$PIECE(INP,U,6)
+11 SET CNT=0
+12 ;Patch 14 find coding system
+13 SET SYS=$$IMP^AUPNSICD(VDT)
+14 SET IMP=$$IMP^ICDEX("10D",DT)
+15 IF LEX
Begin DoDot:1
+16 NEW HITS
+17 IF $$AICD^BGOUTL2
Begin DoDot:2
+18 SET APP=$SELECT(IMP<VDT:"10D",1:"ICD")
End DoDot:2
+19 DO LEXLKUP^BGOUTL(.HITS,LKUP_U_APP_U_VDT)
+20 SET HITS=0
+21 FOR
SET HITS=$ORDER(HITS(HITS))
IF 'HITS
QUIT
Begin DoDot:2
+22 SET LEX=+HITS(HITS)
+23 ;I APP="ICD" S X=$$ICDONE^LEXU(LEX.VDT,APP)
+24 SET X=$$ONE^LEXU(LEX,VDT,APP)
+25 IF X=""
QUIT
+26 ;S ICD=$O(^ICD9("BA",X,0))
+27 ;S:'ICD ICD=$O(^ICD9("BA",X_" ",0))
+28 IF $$AICD^BGOUTL2
SET ICD=$PIECE($$ICDDX^ICDEX(X,VDT),U,1)
+29 IF '$TEST
SET ICD=$PIECE($$ICDDX^ICDCODE(X,VDT),U,1)
+30 IF ICD
DO CHKHITS
End DoDot:2
End DoDot:1
+31 IF '$TEST
IF $GET(DUZ("AG"))="I"
Begin DoDot:1
+32 SET DIC="^ICD9("
SET DIC(0)="TM"
SET X=LKUP
SET XTLKSAY=0
+33 KILL ^UTILITY("AICDHITS",$JOB),^TMP("XTLKHITS",$JOB)
+34 DO ^DIC
+35 IF $PIECE(Y,U,1)'=-1
Begin DoDot:2
+36 SET ICD=+Y
+37 DO CHKHITS
End DoDot:2
+38 IF '$TEST
IF $GET(^DD(80,0,"DIC"))="XTLKDICL"
Begin DoDot:2
+39 DO XTLKUP
End DoDot:2
+40 IF '$TEST
DO AICDLKUP
+41 IF 'CNT
IF $LENGTH(LKUP)>2
Begin DoDot:2
+42 NEW LK,LN
+43 SET LK=LKUP
SET LN=$LENGTH(LKUP)
+44 FOR
Begin DoDot:3
+45 SET ICD=0
+46 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)'=LKUP
QUIT
End DoDot:2
+47 KILL ^UTILITY("AICDHITS",$JOB),^TMP("XTLKHITS",$JOB)
End DoDot:1
+48 IF '$TEST
Begin DoDot:1
+49 DO FIND^DIC(80,,".01;10","M",LKUP,,,,,"RES")
+50 IF '$ORDER(RES("DILIST",0))
QUIT
+51 MERGE ^TMP("XTLKHITS",$JOB)=RES("DILIST",2)
+52 DO XTLKUP
+53 KILL ^TMP("XTLKHITS",$JOB)
End DoDot:1
+54 KILL @RET@(0)
+55 QUIT
AICDLKUP SET I=0
+1 FOR
SET I=$ORDER(^UTILITY("AICDHITS",$JOB,I))
IF 'I
QUIT
Begin DoDot:1
+2 SET ICD=$GET(^UTILITY("AICDHITS",$JOB,I))
+3 DO CHKHITS
End DoDot:1
+4 QUIT
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
CHKHITS IF $DATA(@RET@(0,ICD))
QUIT
SET ^(ICD)=""
+1 IF $$AICD^BGOUTL2
SET IEN=$$ICDDX^ICDEX(ICD,VDT)
+2 IF '$TEST
SET IEN=$$ICDDX^ICDCODE(ICD,VDT)
+3 ;I IEN>0&($P(IEN,U,10)=1) D ;PATCH 8
+4 IF +IEN>0&($PIECE(IEN,U,12)="")
Begin DoDot:1
+5 SET CNT=CNT+1
+6 ;Patch 12
+7 IF $$AICD^BGOUTL2
Begin DoDot:2
+8 SET NARR=$$LD^ICDEX(80,+IEN,VDT)
+9 SET INJ=$$CHKINJ(IEN,SYS)
End DoDot:2
+10 IF '$TEST
Begin DoDot:2
+11 ;Patch 9
+12 SET NARR=$GET(^ICD9(ICD,1))
+13 IF NARR=""
SET NARR=$PIECE(+IEN,U,4)
+14 SET INJ=$$CHKINJ(IEN,SYS)
End DoDot:2
+15 IF 'ECD
IF INJ=1
QUIT
+16 IF ECD=2
IF INJ=0
QUIT
+17 SET @RET@(CNT)=$PIECE(IEN,U,4)_U_ICD_U_NARR_U_$PIECE(IEN,U,2)
End DoDot:1
+18 QUIT
CHKINJ(IEN,SYS) ;Check for an injury code
+1 NEW J
+2 SET J=0
+3 ;Patch 14 changed injury code lookup
+4 IF SYS=30
Begin DoDot:1
+5 ;only codes V00-Y99 per Leslie Racine.
IF $EXTRACT($PIECE(IEN,U,2),1)="V"
SET J=1
+6 IF $EXTRACT($PIECE(IEN,U,2),1)="W"
SET J=1
+7 IF $EXTRACT($PIECE(IEN,U,2),1)="X"
SET J=1
+8 IF $EXTRACT($PIECE(IEN,U,2),1)="Y"
SET J=1
Begin DoDot:2
+9 IF $PIECE(IEN,".",1)'="Y92"
SET J=1
End DoDot:2
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 IF $EXTRACT($PIECE(IEN,U,2))="E"
SET J=1
End DoDot:1
+12 QUIT J
+13 ; Retrieve diagnosis list
DXLIST(RET,INP) ;PEP - retrieve dx list
+1 NEW LKUP,VDT,SEX,ECD,VCD,MAX,MORE
+2 SET LKUP=$PIECE(INP,U)
+3 SET MAX=$PIECE(INP,U,2)
+4 SET MORE=$PIECE(INP,U,3)
+5 SET VDT=$PIECE(INP,U,4)
+6 SET SEX=$PIECE(INP,U,5)
+7 SET ECD=$PIECE(INP,U,6)
+8 SET VCD=$PIECE(INP,U,7)
+9 DO ICDLKUP(.RET,LKUP_U_VDT_U_SEX_U_ECD_U_VCD)
+10 QUIT
