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

BGOICDLK.m

Go to the documentation of this file.
  1. 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
  1. ;---------------------------------------------------------------
  1. ; Lookup ICD's matching input
  1. ; INP = Lookup Value [1] ^ Use Lexicon [2] ^ Visit Date [3] ^
  1. ; Patient Gender [4] ^ ECodes [5] ^ VCodes [6]
  1. ; where ECodes = 0: exclude, 1: include, 2: only ecodes
  1. ; VCodes = 0: include, 1: exclude, 2: only vcodes
  1. ; Returned as a list of records in the format:
  1. ; Descriptive Text [1] ^ ICD IEN [2] ^ Narrative Text [3] ^ ICD Code [4]
  1. ; Patch 12 updated for new ICD lookup
  1. ICDLKUP(RET,INP) ;PEP - ICD lookup
  1. N LKUP,VDT,SEX,ECD,VCD,CNT,DIC,X,Y,I,ICD,LEX,RES,IEN
  1. N AICDRET,XTLKSAY,REC,DESC,CODE,NARR,SYS,INJ,APP,IMP
  1. S RET=$$TMPGBL^BGOUTL
  1. S LKUP=$P(INP,U)
  1. S LEX=$P(INP,U,2)
  1. S VDT=$$CVTDATE^BGOUTL($P(INP,U,3))
  1. I VDT="" S VDT=DT
  1. S SEX=$P(INP,U,4)
  1. S ECD=$P(INP,U,5)
  1. S VCD=$P(INP,U,6)
  1. S CNT=0
  1. ;Patch 14 find coding system
  1. S SYS=$$IMP^AUPNSICD(VDT)
  1. S IMP=$$IMP^ICDEX("10D",DT)
  1. I LEX D
  1. .N HITS
  1. .I $$AICD^BGOUTL2 D
  1. ..S APP=$S(IMP<VDT:"10D",1:"ICD")
  1. .D LEXLKUP^BGOUTL(.HITS,LKUP_U_APP_U_VDT)
  1. .S HITS=0
  1. .F S HITS=$O(HITS(HITS)) Q:'HITS D
  1. ..S LEX=+HITS(HITS)
  1. ..;I APP="ICD" S X=$$ICDONE^LEXU(LEX.VDT,APP)
  1. ..S X=$$ONE^LEXU(LEX,VDT,APP)
  1. ..Q:X=""
  1. ..;S ICD=$O(^ICD9("BA",X,0))
  1. ..;S:'ICD ICD=$O(^ICD9("BA",X_" ",0))
  1. ..I $$AICD^BGOUTL2 S ICD=$P($$ICDDX^ICDEX(X,VDT),U,1)
  1. ..E S ICD=$P($$ICDDX^ICDCODE(X,VDT),U,1)
  1. ..D:ICD CHKHITS
  1. E I $G(DUZ("AG"))="I" D
  1. .S DIC="^ICD9(",DIC(0)="TM",X=LKUP,XTLKSAY=0
  1. .K ^UTILITY("AICDHITS",$J),^TMP("XTLKHITS",$J)
  1. .D ^DIC
  1. .I $P(Y,U,1)'=-1 D
  1. ..S ICD=+Y
  1. ..D CHKHITS
  1. .E I $G(^DD(80,0,"DIC"))="XTLKDICL" D
  1. ..D XTLKUP
  1. .E D AICDLKUP
  1. .I 'CNT,$L(LKUP)>2 D
  1. ..N LK,LN
  1. ..S LK=LKUP,LN=$L(LKUP)
  1. ..F D S LK=$O(^ICD9("BA",LK)) Q:$E(LK,1,LN)'=LKUP
  1. ...S ICD=0
  1. ...F S ICD=$O(^ICD9("BA",LK,ICD)) Q:'ICD D CHKHITS
  1. .K ^UTILITY("AICDHITS",$J),^TMP("XTLKHITS",$J)
  1. E D
  1. .D FIND^DIC(80,,".01;10","M",LKUP,,,,,"RES")
  1. .I '$O(RES("DILIST",0)) Q
  1. .M ^TMP("XTLKHITS",$J)=RES("DILIST",2)
  1. .D XTLKUP
  1. .K ^TMP("XTLKHITS",$J)
  1. K @RET@(0)
  1. Q
  1. AICDLKUP S I=0
  1. F S I=$O(^UTILITY("AICDHITS",$J,I)) Q:'I D
  1. .S ICD=$G(^UTILITY("AICDHITS",$J,I))
  1. .D CHKHITS
  1. Q
  1. XTLKUP S I=0
  1. F S I=$O(^TMP("XTLKHITS",$J,I)) Q:'I D
  1. .S ICD=$G(^TMP("XTLKHITS",$J,I))
  1. .D CHKHITS
  1. Q
  1. CHKHITS Q:$D(@RET@(0,ICD)) S ^(ICD)=""
  1. I $$AICD^BGOUTL2 S IEN=$$ICDDX^ICDEX(ICD,VDT)
  1. E S IEN=$$ICDDX^ICDCODE(ICD,VDT)
  1. ;I IEN>0&($P(IEN,U,10)=1) D ;PATCH 8
  1. I +IEN>0&($P(IEN,U,12)="") D
  1. .S CNT=CNT+1
  1. .;Patch 12
  1. .I $$AICD^BGOUTL2 D
  1. ..S NARR=$$LD^ICDEX(80,+IEN,VDT)
  1. ..S INJ=$$CHKINJ(IEN,SYS)
  1. .E D
  1. ..;Patch 9
  1. ..S NARR=$G(^ICD9(ICD,1))
  1. ..I NARR="" S NARR=$P(+IEN,U,4)
  1. ..S INJ=$$CHKINJ(IEN,SYS)
  1. .I 'ECD,INJ=1 Q
  1. .I ECD=2,INJ=0 Q
  1. .S @RET@(CNT)=$P(IEN,U,4)_U_ICD_U_NARR_U_$P(IEN,U,2)
  1. Q
  1. CHKINJ(IEN,SYS) ;Check for an injury code
  1. N J
  1. S J=0
  1. ;Patch 14 changed injury code lookup
  1. I SYS=30 D
  1. .I $E($P(IEN,U,2),1)="V" S J=1 ;only codes V00-Y99 per Leslie Racine.
  1. .I $E($P(IEN,U,2),1)="W" S J=1
  1. .I $E($P(IEN,U,2),1)="X" S J=1
  1. .I $E($P(IEN,U,2),1)="Y" S J=1 D
  1. ..I $P(IEN,".",1)'="Y92" S J=1
  1. E D
  1. .I $E($P(IEN,U,2))="E" S J=1
  1. Q J
  1. ; Retrieve diagnosis list
  1. DXLIST(RET,INP) ;PEP - retrieve dx list
  1. N LKUP,VDT,SEX,ECD,VCD,MAX,MORE
  1. S LKUP=$P(INP,U)
  1. S MAX=$P(INP,U,2)
  1. S MORE=$P(INP,U,3)
  1. S VDT=$P(INP,U,4)
  1. S SEX=$P(INP,U,5)
  1. S ECD=$P(INP,U,6)
  1. S VCD=$P(INP,U,7)
  1. D ICDLKUP(.RET,LKUP_U_VDT_U_SEX_U_ECD_U_VCD)
  1. Q