BPCGDX ; IHS/OIT/MJL - PROGRAM TO GET LIST OF DIAGNOSES ;
;;1.5;BPC;;MAY 26, 2005
DXLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP REMOTE PROC: BPC GETDIAGNOSISLIST
S BPCGUI=1
;
; BPCRES - The output array (ICD9 code data)
; BPCRES(1) - Total number of entries (BPCMAX or less)
; subscript - sequence number (2 thru value of BPCMAX +1)
; Piece (delimited by "^")
; 1 - Description
; 2 - IEN
; 3 - Category (e.g.
; 4 - Data (in ^ICD9(code,0) )
; BPCX - Input string (e.g. 250,DIAB,etc.)
; BPCMAX - Maximum number of elements to return in BPCRES
; BPCMORE - More data
; Piece (delimited by "|")
; 1 - Next IEN
; 2 - Next ICD9 code
; 3 - Next description ref
; BPCPARAM - Reserved for future use
;
EN ;
S U="^",XWBWRAP=1,BPCCTR=0,BPCSUB=$J,BPCGUI=$G(BPCGUI),BPCLEN=$L(BPCX),BPCC="",BPCMORE=$G(BPCMORE)
K:'BPCMORE ^BGUTMP(BPCSUB,1) K BPCRES S BPCSEQ=$G(^BGUTMP(BPCSUB,1)),BPCLSQP=$P(BPCSEQ,U,2),BPCLSQA=BPCSEQ
I BPCX="" S BPCRES(0)=-1,BPCRES(1)="NO SEARCH PARAMETER GIVEN!" D KILL Q
S BPCMAX=$G(BPCMAX) S:'BPCMAX BPCMAX=$S(BPCGUI:50,1:1E10)
I 'BPCMORE,BPCPARAM'="" S BPCPVS="" F BPCN=1:1:$L(BPCPARAM,"|") S BPCPRM1=$P(BPCPARAM,"|",BPCN),BPCPV=$P(BPCPRM1,"="),BPCPVS=BPCPVS_$S(BPCN>1:",",1:"")_BPCPV,@BPCPV=$P(BPCPRM1,"=",2)
D @$S(BPCMORE:"SETRES",BPCX?.N.1"."1N.N:"GETNUM",$D(^AICDKWLC(1,1,"B",BPCX)):"KWLC",$D(^ICD9("AIHS",BPCX)):"GETKWD",1:"GETTXT"),SETRES:'BPCMORE,KILL
Q
;
GETNUM ; Handles numeric entries
;
S BPCC=$O(^ICD9("BA",BPCX),-1),BPCNEXT=$O(^ICD9("BA",BPCC)),BPCFND=$E(BPCNEXT,1,BPCLEN)=BPCX
I 'BPCFND F S BPCNEXT=$O(^ICD9("BA",BPCNEXT)) Q:BPCNEXT="" I $E(BPCNEXT,1,BPCLEN)=BPCX S BPCC=$O(^ICD9("BA",BPCNEXT),-1) S BPCFND=1 Q
I BPCFND F S BPCC=$O(^ICD9("BA",BPCC)) Q:BPCC=""!($E(BPCC,1,BPCLEN)'=BPCX) S BPCI="" F S BPCI=$O(^ICD9("BA",BPCC,BPCI)) Q:BPCI="" D SETMATCH
K BPCC,BPCFND,BPCNEXT
Q
;
KWLC ; Look in Keyword Lookup Control file for synonyms
;
S BPCSVX=BPCX,BPCN=0
S BPCN="" F S BPCN=$O(^AICDKWLC(1,1,"B",BPCSVX,BPCN)) Q:BPCN="" S BPCN1=0 F S BPCN1=$O(^AICDKWLC(1,1,BPCN,1,BPCN1)) Q:BPCN1="" S BPCX=^(BPCN1,0) D @$S($D(^ICD9("AIHS",BPCX)):"GETKWD",1:"GETTXT")
K BPCN,BPCN1,BPCSVX
Q
;
GETKWD ; Handles keywords
;
S BPCI="" F S BPCI=$O(^ICD9("AIHS",BPCX,BPCI)) Q:BPCI="" D SETMATCH
Q
;
GETTXT ; Handles text entries
;
S BPCC=$O(^ICD9("D",BPCX),-1) F S BPCC=$O(^ICD9("D",BPCC)) Q:BPCC=""!($E(BPCC,1,BPCLEN)'=BPCX) S BPCI="" F S BPCI=$O(^ICD9("D",BPCC,BPCI)) Q:BPCI="" D SETMATCH
Q
;
SETMATCH ;
; Validate the ICD9 code : It doesn't start with an E, It's not
; inactive, and if Patient sex is set, and if sex is defined for this
; code, they're equal.
S BPCDATA=$G(^ICD9(BPCI,0))
Q:$E(BPCDATA)="E" Q:$P(BPCDATA,U,9)'="" I $G(BPCPSEX)'="",$P(BPCDATA,U,10)'="",BPCPSEX'=$P(BPCDATA,U,10) Q
S BPCDESC=$G(^ICD9(BPCI,1)),BPCCAT=$P(BPCDATA,U,5),BPCCDE=$P(BPCDATA,U,1) S:BPCCAT'="" BPCCAT=$G(^ICM(BPCCAT,0))
S:BPCCDE BPCCDE=+BPCCDE
S:'$D(^BGUTMP(BPCSUB,1,BPCCDE)) BPCSEQ=BPCCDE,^BGUTMP(BPCSUB,1,BPCCDE)=BPCDESC_U_BPCI_U_BPCCAT_U_BPCDATA
Q
;
SETRES ; Copy from ^BPCTMP to BPCRES
;
I BPCSEQ="" S BPCRES(0)=-1,BPCRES(1)="vEnter another Selection, Code or Diagnosis!" Q
S:'BPCMORE BPCSEQ=BPCCDE,$P(^BGUTMP(BPCSUB,1),U,1)=BPCSEQ,BPCLSQA=BPCSEQ
S BPCSEQ=BPCLSQP F BPCCTR=1:1:BPCMAX S BPCSEQ=$O(^BGUTMP(BPCSUB,1,BPCSEQ)) Q:BPCSEQ="" S BPCRES(BPCCTR)=^(BPCSEQ)
S:BPCSEQ="" BPCCTR=BPCCTR-1 S BPCRES(0)=BPCCTR
I BPCSEQ'="" S BPCCTR=BPCCTR+1,BPCRES(0)=BPCCTR,BPCRES(BPCCTR)="..MORE",$P(^BGUTMP(BPCSUB,1),U,2)=BPCSEQ Q
K @BPCPVS,BPCPV,BPCPVS,^BGUTMP(BPCSUB,1)
Q
;
KILL ;
K BPCC,BPCCAT,BPCCDE,BPCCTR,BPCDATA,BPCDESC,BPCGUI,BPCI,BPCLEN,BPCLSQA,BPCLSQP,BPCMAX,BPCMORE,BPCN,BPCNEXT,BPCPARAM,BPCPRM1,BPCSEQ,BPCSUB,BPCX,BPCXS
Q
BPCGDX ; IHS/OIT/MJL - PROGRAM TO GET LIST OF DIAGNOSES ;
+1 ;;1.5;BPC;;MAY 26, 2005
DXLIST(BPCRES,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP REMOTE PROC: BPC GETDIAGNOSISLIST
+1 SET BPCGUI=1
+2 ;
+3 ; BPCRES - The output array (ICD9 code data)
+4 ; BPCRES(1) - Total number of entries (BPCMAX or less)
+5 ; subscript - sequence number (2 thru value of BPCMAX +1)
+6 ; Piece (delimited by "^")
+7 ; 1 - Description
+8 ; 2 - IEN
+9 ; 3 - Category (e.g.
+10 ; 4 - Data (in ^ICD9(code,0) )
+11 ; BPCX - Input string (e.g. 250,DIAB,etc.)
+12 ; BPCMAX - Maximum number of elements to return in BPCRES
+13 ; BPCMORE - More data
+14 ; Piece (delimited by "|")
+15 ; 1 - Next IEN
+16 ; 2 - Next ICD9 code
+17 ; 3 - Next description ref
+18 ; BPCPARAM - Reserved for future use
+19 ;
EN ;
+1 SET U="^"
SET XWBWRAP=1
SET BPCCTR=0
SET BPCSUB=$JOB
SET BPCGUI=$GET(BPCGUI)
SET BPCLEN=$LENGTH(BPCX)
SET BPCC=""
SET BPCMORE=$GET(BPCMORE)
+2 IF 'BPCMORE
KILL ^BGUTMP(BPCSUB,1)
KILL BPCRES
SET BPCSEQ=$GET(^BGUTMP(BPCSUB,1))
SET BPCLSQP=$PIECE(BPCSEQ,U,2)
SET BPCLSQA=BPCSEQ
+3 IF BPCX=""
SET BPCRES(0)=-1
SET BPCRES(1)="NO SEARCH PARAMETER GIVEN!"
DO KILL
QUIT
+4 SET BPCMAX=$GET(BPCMAX)
IF 'BPCMAX
SET BPCMAX=$SELECT(BPCGUI:50,1:1E10)
+5 IF 'BPCMORE
IF BPCPARAM'=""
SET BPCPVS=""
FOR BPCN=1:1:$LENGTH(BPCPARAM,"|")
SET BPCPRM1=$PIECE(BPCPARAM,"|",BPCN)
SET BPCPV=$PIECE(BPCPRM1,"=")
SET BPCPVS=BPCPVS_$SELECT(BPCN>1:",",1:"")_BPCPV
SET @BPCPV=$PIECE(BPCPRM1,"=",2)
+6 DO @$SELECT(BPCMORE:"SETRES",BPCX?.N.1"."1N.N:"GETNUM",$DATA(^AICDKWLC(1,1,"B",BPCX)):"KWLC",$DATA(^ICD9("AIHS",BPCX)):"GETKWD",1:"GETTXT")
IF 'BPCMORE
DO SETRES
DO KILL
+7 QUIT
+8 ;
GETNUM ; Handles numeric entries
+1 ;
+2 SET BPCC=$ORDER(^ICD9("BA",BPCX),-1)
SET BPCNEXT=$ORDER(^ICD9("BA",BPCC))
SET BPCFND=$EXTRACT(BPCNEXT,1,BPCLEN)=BPCX
+3 IF 'BPCFND
FOR
SET BPCNEXT=$ORDER(^ICD9("BA",BPCNEXT))
IF BPCNEXT=""
QUIT
IF $EXTRACT(BPCNEXT,1,BPCLEN)=BPCX
SET BPCC=$ORDER(^ICD9("BA",BPCNEXT),-1)
SET BPCFND=1
QUIT
+4 IF BPCFND
FOR
SET BPCC=$ORDER(^ICD9("BA",BPCC))
IF BPCC=""!($EXTRACT(BPCC,1,BPCLEN)'=BPCX)
QUIT
SET BPCI=""
FOR
SET BPCI=$ORDER(^ICD9("BA",BPCC,BPCI))
IF BPCI=""
QUIT
DO SETMATCH
+5 KILL BPCC,BPCFND,BPCNEXT
+6 QUIT
+7 ;
KWLC ; Look in Keyword Lookup Control file for synonyms
+1 ;
+2 SET BPCSVX=BPCX
SET BPCN=0
+3 SET BPCN=""
FOR
SET BPCN=$ORDER(^AICDKWLC(1,1,"B",BPCSVX,BPCN))
IF BPCN=""
QUIT
SET BPCN1=0
FOR
SET BPCN1=$ORDER(^AICDKWLC(1,1,BPCN,1,BPCN1))
IF BPCN1=""
QUIT
SET BPCX=^(BPCN1,0)
DO @$SELECT($DATA(^ICD9("AIHS",BPCX)):"GETKWD",1:"GETTXT")
+4 KILL BPCN,BPCN1,BPCSVX
+5 QUIT
+6 ;
GETKWD ; Handles keywords
+1 ;
+2 SET BPCI=""
FOR
SET BPCI=$ORDER(^ICD9("AIHS",BPCX,BPCI))
IF BPCI=""
QUIT
DO SETMATCH
+3 QUIT
+4 ;
GETTXT ; Handles text entries
+1 ;
+2 SET BPCC=$ORDER(^ICD9("D",BPCX),-1)
FOR
SET BPCC=$ORDER(^ICD9("D",BPCC))
IF BPCC=""!($EXTRACT(BPCC,1,BPCLEN)'=BPCX)
QUIT
SET BPCI=""
FOR
SET BPCI=$ORDER(^ICD9("D",BPCC,BPCI))
IF BPCI=""
QUIT
DO SETMATCH
+3 QUIT
+4 ;
SETMATCH ;
+1 ; Validate the ICD9 code : It doesn't start with an E, It's not
+2 ; inactive, and if Patient sex is set, and if sex is defined for this
+3 ; code, they're equal.
+4 SET BPCDATA=$GET(^ICD9(BPCI,0))
+5 IF $EXTRACT(BPCDATA)="E"
QUIT
IF $PIECE(BPCDATA,U,9)'=""
QUIT
IF $GET(BPCPSEX)'=""
IF $PIECE(BPCDATA,U,10)'=""
IF BPCPSEX'=$PIECE(BPCDATA,U,10)
QUIT
+6 SET BPCDESC=$GET(^ICD9(BPCI,1))
SET BPCCAT=$PIECE(BPCDATA,U,5)
SET BPCCDE=$PIECE(BPCDATA,U,1)
IF BPCCAT'=""
SET BPCCAT=$GET(^ICM(BPCCAT,0))
+7 IF BPCCDE
SET BPCCDE=+BPCCDE
+8 IF '$DATA(^BGUTMP(BPCSUB,1,BPCCDE))
SET BPCSEQ=BPCCDE
SET ^BGUTMP(BPCSUB,1,BPCCDE)=BPCDESC_U_BPCI_U_BPCCAT_U_BPCDATA
+9 QUIT
+10 ;
SETRES ; Copy from ^BPCTMP to BPCRES
+1 ;
+2 IF BPCSEQ=""
SET BPCRES(0)=-1
SET BPCRES(1)="vEnter another Selection, Code or Diagnosis!"
QUIT
+3 IF 'BPCMORE
SET BPCSEQ=BPCCDE
SET $PIECE(^BGUTMP(BPCSUB,1),U,1)=BPCSEQ
SET BPCLSQA=BPCSEQ
+4 SET BPCSEQ=BPCLSQP
FOR BPCCTR=1:1:BPCMAX
SET BPCSEQ=$ORDER(^BGUTMP(BPCSUB,1,BPCSEQ))
IF BPCSEQ=""
QUIT
SET BPCRES(BPCCTR)=^(BPCSEQ)
+5 IF BPCSEQ=""
SET BPCCTR=BPCCTR-1
SET BPCRES(0)=BPCCTR
+6 IF BPCSEQ'=""
SET BPCCTR=BPCCTR+1
SET BPCRES(0)=BPCCTR
SET BPCRES(BPCCTR)="..MORE"
SET $PIECE(^BGUTMP(BPCSUB,1),U,2)=BPCSEQ
QUIT
+7 KILL @BPCPVS,BPCPV,BPCPVS,^BGUTMP(BPCSUB,1)
+8 QUIT
+9 ;
KILL ;
+1 KILL BPCC,BPCCAT,BPCCDE,BPCCTR,BPCDATA,BPCDESC,BPCGUI,BPCI,BPCLEN,BPCLSQA,BPCLSQP,BPCMAX,BPCMORE,BPCN,BPCNEXT,BPCPARAM,BPCPRM1,BPCSEQ,BPCSUB,BPCX,BPCXS
+2 QUIT
