BPCGDX.m

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