- 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
