- 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