BGOFHLK ; IHS/BAO/TMD - FHL - PROGRAM TO GET LIST OF DIAGNOSES ;02-Apr-2013 09:12;MGH
;;1.1;BGO COMPONENTS;**6,12**;Mar 20, 2007;Build 5
;---------------------------------------------------------------
; Lookup ICD's matching input
; INP = Lookup Value [1] ^ Visit Date [2] ^ Patient Gender [3]
; ^ FROM [4], TO [5]
; 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,CNT,DIC,X,Y,I,ICD,FROM,TO,CNT
N AICDRET,XTLKSAY,REC,DESC,CODE,NARR
S RET=$$TMPGBL^BGOUTL
S LKUP=$P(INP,U)
S FROM=$P(INP,U,4)
S TO=$P(INP,U,5)
S VDT=$$CVTDATE^BGOUTL($P(INP,U,3))
S SEX=$P(INP,U,3)
S CNT=0
I LKUP'="" D
.I $G(DUZ("AG"))="I" D
..I $$AICD^BGOUTL2 D
...N HITS
...S HITS=0
...K ^TMP("ICD9")
...S HITS=$$LKTX^ICDEX(LKUP,"ICD9(",VDT,1,1,2)
...I HITS>0 D
....S X=0 F S X=$O(^TMP("ICD9",$J,"SEL",X)) Q:X="" D
.....S ICD=$P($G(^TMP("ICD9",$J,"SEL",X)),U,1)
.....D CHKHITS
.E D
..S DIC="^ICD9(",DIC(0)="TM",X=LKUP,XTLKSAY=0
..K ^UTILITY("AICDHITS",$J),^TMP("XTLKHITS",$J)
..D ^DIC
..I Y'=-1 D
...S ICD=+Y
...D CHKHITS
..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
I LKUP="" D
. N LK,LK1
.I FROM="" S FROM="V16"
.I TO="" S TO="V20.0"
.S LK=FROM F S LK=$O(^ICD9("AB",LK)) S LK1=$E(LK,2,$L(LK)) Q:LK=TO!(LK1>19.9) D
..S ICD="" F S ICD=$O(^ICD9("AB",LK,ICD)) Q:'ICD D CHKHITS
K @RET@(0)
Q
CHKHITS ;Q:$D(@RET@(0,ICD)) S ^(ICD)=""
N OK,RECN
S REC=$G(^ICD9(ICD,0))
Q:$P(REC,U,9)
S RECN=$P(REC,U,1)
S OK=$$CHKFH^AUPNSICD(ICD)
I OK=0 Q
I VDT,$P(REC,U,11),$$FMDIFF^XLFDT(VDT,$P(REC,U,11))>-1 Q
I $L(SEX),$P(REC,U,10)'="",SEX'=$P(REC,U,10) Q
I $$AICD^BGOUTL2 S NARR=$P($$ICDDX^ICDEX(ICD,VDT),U,4) ;Patch 12
E S NARR=$G(^ICD9(ICD,1))
S CODE=$P(REC,U),DESC=$P(REC,U,3)
S CNT=CNT+1
S @RET@(CNT)=DESC_U_ICD_U_NARR_U_CODE
Q
CHKFH ;Family history lookup
BGOFHLK ; IHS/BAO/TMD - FHL - PROGRAM TO GET LIST OF DIAGNOSES ;02-Apr-2013 09:12;MGH
+1 ;;1.1;BGO COMPONENTS;**6,12**;Mar 20, 2007;Build 5
+2 ;---------------------------------------------------------------
+3 ; Lookup ICD's matching input
+4 ; INP = Lookup Value [1] ^ Visit Date [2] ^ Patient Gender [3]
+5 ; ^ FROM [4], TO [5]
+6 ; Returned as a list of records in the format:
+7 ; Descriptive Text [1] ^ ICD IEN [2] ^ Narrative Text [3] ^ ICD Code [4]
+8 ; Patch 12 updated for new ICD lookup
ICDLKUP(RET,INP) ;PEP - ICD lookup
+1 NEW LKUP,VDT,SEX,CNT,DIC,X,Y,I,ICD,FROM,TO,CNT
+2 NEW AICDRET,XTLKSAY,REC,DESC,CODE,NARR
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET LKUP=$PIECE(INP,U)
+5 SET FROM=$PIECE(INP,U,4)
+6 SET TO=$PIECE(INP,U,5)
+7 SET VDT=$$CVTDATE^BGOUTL($PIECE(INP,U,3))
+8 SET SEX=$PIECE(INP,U,3)
+9 SET CNT=0
+10 IF LKUP'=""
Begin DoDot:1
+11 IF $GET(DUZ("AG"))="I"
Begin DoDot:2
+12 IF $$AICD^BGOUTL2
Begin DoDot:3
+13 NEW HITS
+14 SET HITS=0
+15 KILL ^TMP("ICD9")
+16 SET HITS=$$LKTX^ICDEX(LKUP,"ICD9(",VDT,1,1,2)
+17 IF HITS>0
Begin DoDot:4
+18 SET X=0
FOR
SET X=$ORDER(^TMP("ICD9",$JOB,"SEL",X))
IF X=""
QUIT
Begin DoDot:5
+19 SET ICD=$PIECE($GET(^TMP("ICD9",$JOB,"SEL",X)),U,1)
+20 DO CHKHITS
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+21 IF '$TEST
Begin DoDot:2
+22 SET DIC="^ICD9("
SET DIC(0)="TM"
SET X=LKUP
SET XTLKSAY=0
+23 KILL ^UTILITY("AICDHITS",$JOB),^TMP("XTLKHITS",$JOB)
+24 DO ^DIC
+25 IF Y'=-1
Begin DoDot:3
+26 SET ICD=+Y
+27 DO CHKHITS
End DoDot:3
+28 IF 'CNT
IF $LENGTH(LKUP)>2
Begin DoDot:3
+29 NEW LK,LN
+30 SET LK=LKUP
SET LN=$LENGTH(LKUP)
+31 FOR
Begin DoDot:4
+32 SET ICD=0
+33 FOR
SET ICD=$ORDER(^ICD9("BA",LK,ICD))
IF 'ICD
QUIT
DO CHKHITS
End DoDot:4
SET LK=$ORDER(^ICD9("BA",LK))
IF $EXTRACT(LK,1,LN)'=LKUP
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+34 IF LKUP=""
Begin DoDot:1
+35 NEW LK,LK1
+36 IF FROM=""
SET FROM="V16"
+37 IF TO=""
SET TO="V20.0"
+38 SET LK=FROM
FOR
SET LK=$ORDER(^ICD9("AB",LK))
SET LK1=$EXTRACT(LK,2,$LENGTH(LK))
IF LK=TO!(LK1>19.9)
QUIT
Begin DoDot:2
+39 SET ICD=""
FOR
SET ICD=$ORDER(^ICD9("AB",LK,ICD))
IF 'ICD
QUIT
DO CHKHITS
End DoDot:2
End DoDot:1
+40 KILL @RET@(0)
+41 QUIT
CHKHITS ;Q:$D(@RET@(0,ICD)) S ^(ICD)=""
+1 NEW OK,RECN
+2 SET REC=$GET(^ICD9(ICD,0))
+3 IF $PIECE(REC,U,9)
QUIT
+4 SET RECN=$PIECE(REC,U,1)
+5 SET OK=$$CHKFH^AUPNSICD(ICD)
+6 IF OK=0
QUIT
+7 IF VDT
IF $PIECE(REC,U,11)
IF $$FMDIFF^XLFDT(VDT,$PIECE(REC,U,11))>-1
QUIT
+8 IF $LENGTH(SEX)
IF $PIECE(REC,U,10)'=""
IF SEX'=$PIECE(REC,U,10)
QUIT
+9 ;Patch 12
IF $$AICD^BGOUTL2
SET NARR=$PIECE($$ICDDX^ICDEX(ICD,VDT),U,4)
+10 IF '$TEST
SET NARR=$GET(^ICD9(ICD,1))
+11 SET CODE=$PIECE(REC,U)
SET DESC=$PIECE(REC,U,3)
+12 SET CNT=CNT+1
+13 SET @RET@(CNT)=DESC_U_ICD_U_NARR_U_CODE
+14 QUIT
CHKFH ;Family history lookup
