BLRHLTBL ; cmi/anch/maw - BHL Import HL7 Tables ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
;
BHLTBLL(DIR,FILE) ; EP
;;3.01;BHL IHS HL7 UTILTIES;;JUL 11,2013
;
;
;EP - This is the main routine driver
S C=","
D LOAD(DIR,FILE)
Q:$G(BHLFLG)
Q
;D EOJ
Q
;
LOAD(DIR,FL) ;-- load from the file and bhl hl7 tables File
N VALUE,DESC,TB
S BLRY=$$OPEN^%ZISH(DIR,FL,"R")
I BLRY D Q
. S BLRFLG=1
. W !,"Trouble Opening File, please fix and try again" Q
F BLRI=1:1 U IO R BLRX:DTIME D Q:BLRX=""
. Q:BLRX=""
. S VALUE=$P(BLRX,C)
. S DESC=$E($P(BLRX,C,2),1,150)
. S DESC=$TR(DESC,"""","")
. S TB=$E($P(BLRX,C,3),4,7)
. S BLRTI=$$ADD(TB,VALUE,DESC)
. Q:'BLRTI
. Q
. ;S BLRLT=$$MTCH(BLRTI)
D ^%ZISC
Q
;
ADD(TAB,VAL,DSC) ;-- add the test code to the file
I $O(^BHLTBL("AVAL",TAB,VAL,0)) Q ""
N FDA,FIENS,FERR
S FDA(90076.9,"+1,",.01)=TAB
S FDA(90076.9,"+1,",.02)=VAL
S FDA(90076.9,"+1,",.03)=DSC
D UPDATE^DIE("","FDA","FIENS","FERR(1)")
Q ""
;
LOADO(DIR,FL) ;-- load from the file and bhl other tables File
N VALUE,DESC,TB
S BLRY=$$OPEN^%ZISH(DIR,FL,"R")
I BLRY D Q
. S BLRFLG=1
. W !,"Trouble Opening File, please fix and try again" Q
F BLRI=1:1 U IO R BLRX:DTIME D Q:BLRX=""
. Q:BLRX=""
. S VALUE=$P(BLRX,C)
. S DESC=$E($P(BLRX,C,2),1,150)
. S DESC=$TR(DESC,"""","")
. S TB=$P(BLRX,C,3)
. S BLRTI=$$ADDO(TB,VALUE,DESC)
. Q:'BLRTI
. Q
. ;S BLRLT=$$MTCH(BLRTI)
D ^%ZISC
Q
;
ADDO(TAB,VAL,DSC) ;-- add the test code to the file
I $O(^BHLOTBL("AVAL",TAB,VAL,0)) Q ""
N FDA,FIENS,FERR
S FDA(90076.8,"+1,",.01)=TAB
S FDA(90076.8,"+1,",.02)=VAL
S FDA(90076.8,"+1,",.03)=DSC
D UPDATE^DIE("","FDA","FIENS","FERR(1)")
Q ""
;
DISP ; EP -- display the values in an HL7 table
N HTAB,TABL,TDA,TIEN,DATA
S TABL=$$ASKTAB()
I TABL="O" D DISPO Q
S HTAB=$$ASKHTAB()
I $G(HTAB)="" W !!,?4,"HL7 table not on system" D PRESSKEY^BLRGMENU(9) Q
;
D DSPHLTBL(HTAB)
; W @IOF
; W "HL7 Table "_HTAB
; W !,"Value",?17,"Description"
; S TDA=0 F S TDA=$O(^BHLTBL("AVAL",HTAB,TDA)) Q:TDA="" D
; . S TIEN=0 F S TIEN=$O(^BHLTBL("AVAL",HTAB,TDA,TIEN)) Q:'TIEN D
; .. S DATA=$G(^BHLTBL(TIEN,0))
; .. W !,$P(DATA,U,2),?17,$P(DATA,U,3)
; D PRESSKEY^BLRGMENU(9)
Q
;
DISPO ;-- display the values in an HL7 table
N OTAB,TABL,TDA,TIEN,DATA
S OTAB=$$ASKOTAB()
I $G(OTAB)="" W !!,?4,"Other table not on system" D PRESSKEY^BLRGMENU(9) Q
;
D DSPOTTBL(OTAB)
; W @IOF
; W "Other Table "_OTAB
; W !,"Value",?17,"Description"
; S TDA=0 F S TDA=$O(^BHLOTBL("AVAL",OTAB,TDA)) Q:TDA="" D
; . S TIEN=0 F S TIEN=$O(^BHLOTBL("AVAL",OTAB,TDA,TIEN)) Q:'TIEN D
; .. S DATA=$G(^BHLOTBL(TIEN,0))
; .. W !,$P(DATA,U,2),?27,$P(DATA,U,3)
; D PRESSKEY^BLRGMENU(9)
Q
;
DSPHLTBL(TABLE) ; EP - Display HL7 Table
NEW DESC,HEADER,LINES,MAXLINES,PG,QFLG
;
S HEADER(1)="HL7"
S HEADER(2)="Table "_TABLE
S HEADER(3)=" "
S $E(HEADER(4),5)="Value"
S $E(HEADER(4),20)="Description"
;
S MAXLINES=(IOSL-3),LINES=MAXLINES+10,PG=0,QFLG="NO"
;
S TDA=0 F S TDA=$O(^BHLTBL("AVAL",TABLE,TDA)) Q:TDA=""!(QFLG="Q") D
. S TIEN=0 F S TIEN=$O(^BHLTBL("AVAL",TABLE,TDA,TIEN)) Q:'TIEN!(QFLG="Q") D
.. S DATA=$G(^BHLTBL(TIEN,0))
.. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO") Q:QFLG="Q"
.. S DESC=$P(DATA,U,3)
.. W ?4,$P(DATA,U,2)
.. W:$L(DESC)<61 ?19,DESC
.. D:$L(DESC)>60 LINEWRAP^BLRGMENU(19,DESC,60)
.. W !
.. S LINES=LINES+1
;
D:QFLG'="Q" PRESSKEY^BLRGMENU(9)
Q
;
DSPOTTBL(TABLE) ; EP - Display OTHER Table
NEW DESC,HEADER,LINES,MAXLINES,PG,QFLG
;
S HEADER(1)="Other"
S HEADER(2)="Table "_TABLE
S HEADER(3)=" "
S $E(HEADER(4),5)="Value"
S $E(HEADER(4),30)="Description"
;
S MAXLINES=(IOSL-3),LINES=MAXLINES+10,PG=0,QFLG="NO"
;
S TDA=0 F S TDA=$O(^BHLOTBL("AVAL",TABLE,TDA)) Q:TDA=""!(QFLG="Q") D
. S TIEN=0 F S TIEN=$O(^BHLOTBL("AVAL",TABLE,TDA,TIEN)) Q:'TIEN!(QFLG="Q") D
.. S DATA=$G(^BHLOTBL(TIEN,0))
.. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO") Q:QFLG="Q"
.. S DESC=$P(DATA,U,3)
.. W ?4,$P(DATA,U,2)
.. W:$L(DESC)<51 ?29,DESC
.. D:$L(DESC)>50 LINEWRAP^BLRGMENU(29,DESC,50)
.. W !
.. S LINES=LINES+1
;
D:QFLG'="Q" PRESSKEY^BLRGMENU(9)
Q
;
ASKTAB() ;-- get the table number
N TAB
S DIR("A")="HL7 or Other Table",DIR(0)="S^H:HL7;O:Other"
D ^DIR
I $D(DIRUT) Q ""
S TAB=Y
Q TAB
;
ASKHTAB() ;-- get the table number
N TAB
S DIR("A")="Which HL7 table",DIR(0)="F^1:6"
D ^DIR
I $D(DIRUT) Q ""
S TAB=Y
I '$O(^BHLTBL("B",TAB,0)) Q ""
Q TAB
;
ASKOTAB() ;-- get the table number
N TAB
S DIR("A")="Which table",DIR(0)="F^1:15"
D ^DIR
I $D(DIRUT) Q ""
S TAB=Y
I '$O(^BHLOTBL("B",TAB,0)) Q ""
Q TAB
;
BLRHLTBL ; cmi/anch/maw - BHL Import HL7 Tables ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
+2 ;
BHLTBLL(DIR,FILE) ; EP
+1 ;;3.01;BHL IHS HL7 UTILTIES;;JUL 11,2013
+2 ;
+3 ;
+4 ;EP - This is the main routine driver
+5 SET C=","
+6 DO LOAD(DIR,FILE)
+7 IF $GET(BHLFLG)
QUIT
+8 QUIT
+9 ;D EOJ
+10 QUIT
+11 ;
LOAD(DIR,FL) ;-- load from the file and bhl hl7 tables File
+1 NEW VALUE,DESC,TB
+2 SET BLRY=$$OPEN^%ZISH(DIR,FL,"R")
+3 IF BLRY
Begin DoDot:1
+4 SET BLRFLG=1
+5 WRITE !,"Trouble Opening File, please fix and try again"
QUIT
End DoDot:1
QUIT
+6 FOR BLRI=1:1
USE IO
READ BLRX:DTIME
Begin DoDot:1
+7 IF BLRX=""
QUIT
+8 SET VALUE=$PIECE(BLRX,C)
+9 SET DESC=$EXTRACT($PIECE(BLRX,C,2),1,150)
+10 SET DESC=$TRANSLATE(DESC,"""","")
+11 SET TB=$EXTRACT($PIECE(BLRX,C,3),4,7)
+12 SET BLRTI=$$ADD(TB,VALUE,DESC)
+13 IF 'BLRTI
QUIT
+14 QUIT
+15 ;S BLRLT=$$MTCH(BLRTI)
End DoDot:1
IF BLRX=""
QUIT
+16 DO ^%ZISC
+17 QUIT
+18 ;
ADD(TAB,VAL,DSC) ;-- add the test code to the file
+1 IF $ORDER(^BHLTBL("AVAL",TAB,VAL,0))
QUIT ""
+2 NEW FDA,FIENS,FERR
+3 SET FDA(90076.9,"+1,",.01)=TAB
+4 SET FDA(90076.9,"+1,",.02)=VAL
+5 SET FDA(90076.9,"+1,",.03)=DSC
+6 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+7 QUIT ""
+8 ;
LOADO(DIR,FL) ;-- load from the file and bhl other tables File
+1 NEW VALUE,DESC,TB
+2 SET BLRY=$$OPEN^%ZISH(DIR,FL,"R")
+3 IF BLRY
Begin DoDot:1
+4 SET BLRFLG=1
+5 WRITE !,"Trouble Opening File, please fix and try again"
QUIT
End DoDot:1
QUIT
+6 FOR BLRI=1:1
USE IO
READ BLRX:DTIME
Begin DoDot:1
+7 IF BLRX=""
QUIT
+8 SET VALUE=$PIECE(BLRX,C)
+9 SET DESC=$EXTRACT($PIECE(BLRX,C,2),1,150)
+10 SET DESC=$TRANSLATE(DESC,"""","")
+11 SET TB=$PIECE(BLRX,C,3)
+12 SET BLRTI=$$ADDO(TB,VALUE,DESC)
+13 IF 'BLRTI
QUIT
+14 QUIT
+15 ;S BLRLT=$$MTCH(BLRTI)
End DoDot:1
IF BLRX=""
QUIT
+16 DO ^%ZISC
+17 QUIT
+18 ;
ADDO(TAB,VAL,DSC) ;-- add the test code to the file
+1 IF $ORDER(^BHLOTBL("AVAL",TAB,VAL,0))
QUIT ""
+2 NEW FDA,FIENS,FERR
+3 SET FDA(90076.8,"+1,",.01)=TAB
+4 SET FDA(90076.8,"+1,",.02)=VAL
+5 SET FDA(90076.8,"+1,",.03)=DSC
+6 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+7 QUIT ""
+8 ;
DISP ; EP -- display the values in an HL7 table
+1 NEW HTAB,TABL,TDA,TIEN,DATA
+2 SET TABL=$$ASKTAB()
+3 IF TABL="O"
DO DISPO
QUIT
+4 SET HTAB=$$ASKHTAB()
+5 IF $GET(HTAB)=""
WRITE !!,?4,"HL7 table not on system"
DO PRESSKEY^BLRGMENU(9)
QUIT
+6 ;
+7 DO DSPHLTBL(HTAB)
+8 ; W @IOF
+9 ; W "HL7 Table "_HTAB
+10 ; W !,"Value",?17,"Description"
+11 ; S TDA=0 F S TDA=$O(^BHLTBL("AVAL",HTAB,TDA)) Q:TDA="" D
+12 ; . S TIEN=0 F S TIEN=$O(^BHLTBL("AVAL",HTAB,TDA,TIEN)) Q:'TIEN D
+13 ; .. S DATA=$G(^BHLTBL(TIEN,0))
+14 ; .. W !,$P(DATA,U,2),?17,$P(DATA,U,3)
+15 ; D PRESSKEY^BLRGMENU(9)
+16 QUIT
+17 ;
DISPO ;-- display the values in an HL7 table
+1 NEW OTAB,TABL,TDA,TIEN,DATA
+2 SET OTAB=$$ASKOTAB()
+3 IF $GET(OTAB)=""
WRITE !!,?4,"Other table not on system"
DO PRESSKEY^BLRGMENU(9)
QUIT
+4 ;
+5 DO DSPOTTBL(OTAB)
+6 ; W @IOF
+7 ; W "Other Table "_OTAB
+8 ; W !,"Value",?17,"Description"
+9 ; S TDA=0 F S TDA=$O(^BHLOTBL("AVAL",OTAB,TDA)) Q:TDA="" D
+10 ; . S TIEN=0 F S TIEN=$O(^BHLOTBL("AVAL",OTAB,TDA,TIEN)) Q:'TIEN D
+11 ; .. S DATA=$G(^BHLOTBL(TIEN,0))
+12 ; .. W !,$P(DATA,U,2),?27,$P(DATA,U,3)
+13 ; D PRESSKEY^BLRGMENU(9)
+14 QUIT
+15 ;
DSPHLTBL(TABLE) ; EP - Display HL7 Table
+1 NEW DESC,HEADER,LINES,MAXLINES,PG,QFLG
+2 ;
+3 SET HEADER(1)="HL7"
+4 SET HEADER(2)="Table "_TABLE
+5 SET HEADER(3)=" "
+6 SET $EXTRACT(HEADER(4),5)="Value"
+7 SET $EXTRACT(HEADER(4),20)="Description"
+8 ;
+9 SET MAXLINES=(IOSL-3)
SET LINES=MAXLINES+10
SET PG=0
SET QFLG="NO"
+10 ;
+11 SET TDA=0
FOR
SET TDA=$ORDER(^BHLTBL("AVAL",TABLE,TDA))
IF TDA=""!(QFLG="Q")
QUIT
Begin DoDot:1
+12 SET TIEN=0
FOR
SET TIEN=$ORDER(^BHLTBL("AVAL",TABLE,TDA,TIEN))
IF 'TIEN!(QFLG="Q")
QUIT
Begin DoDot:2
+13 SET DATA=$GET(^BHLTBL(TIEN,0))
+14 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,"NO")
IF QFLG="Q"
QUIT
+15 SET DESC=$PIECE(DATA,U,3)
+16 WRITE ?4,$PIECE(DATA,U,2)
+17 IF $LENGTH(DESC)<61
WRITE ?19,DESC
+18 IF $LENGTH(DESC)>60
DO LINEWRAP^BLRGMENU(19,DESC,60)
+19 WRITE !
+20 SET LINES=LINES+1
End DoDot:2
End DoDot:1
+21 ;
+22 IF QFLG'="Q"
DO PRESSKEY^BLRGMENU(9)
+23 QUIT
+24 ;
DSPOTTBL(TABLE) ; EP - Display OTHER Table
+1 NEW DESC,HEADER,LINES,MAXLINES,PG,QFLG
+2 ;
+3 SET HEADER(1)="Other"
+4 SET HEADER(2)="Table "_TABLE
+5 SET HEADER(3)=" "
+6 SET $EXTRACT(HEADER(4),5)="Value"
+7 SET $EXTRACT(HEADER(4),30)="Description"
+8 ;
+9 SET MAXLINES=(IOSL-3)
SET LINES=MAXLINES+10
SET PG=0
SET QFLG="NO"
+10 ;
+11 SET TDA=0
FOR
SET TDA=$ORDER(^BHLOTBL("AVAL",TABLE,TDA))
IF TDA=""!(QFLG="Q")
QUIT
Begin DoDot:1
+12 SET TIEN=0
FOR
SET TIEN=$ORDER(^BHLOTBL("AVAL",TABLE,TDA,TIEN))
IF 'TIEN!(QFLG="Q")
QUIT
Begin DoDot:2
+13 SET DATA=$GET(^BHLOTBL(TIEN,0))
+14 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,"NO")
IF QFLG="Q"
QUIT
+15 SET DESC=$PIECE(DATA,U,3)
+16 WRITE ?4,$PIECE(DATA,U,2)
+17 IF $LENGTH(DESC)<51
WRITE ?29,DESC
+18 IF $LENGTH(DESC)>50
DO LINEWRAP^BLRGMENU(29,DESC,50)
+19 WRITE !
+20 SET LINES=LINES+1
End DoDot:2
End DoDot:1
+21 ;
+22 IF QFLG'="Q"
DO PRESSKEY^BLRGMENU(9)
+23 QUIT
+24 ;
ASKTAB() ;-- get the table number
+1 NEW TAB
+2 SET DIR("A")="HL7 or Other Table"
SET DIR(0)="S^H:HL7;O:Other"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT ""
+5 SET TAB=Y
+6 QUIT TAB
+7 ;
ASKHTAB() ;-- get the table number
+1 NEW TAB
+2 SET DIR("A")="Which HL7 table"
SET DIR(0)="F^1:6"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT ""
+5 SET TAB=Y
+6 IF '$ORDER(^BHLTBL("B",TAB,0))
QUIT ""
+7 QUIT TAB
+8 ;
ASKOTAB() ;-- get the table number
+1 NEW TAB
+2 SET DIR("A")="Which table"
SET DIR(0)="F^1:15"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT ""
+5 SET TAB=Y
+6 IF '$ORDER(^BHLOTBL("B",TAB,0))
QUIT ""
+7 QUIT TAB
+8 ;
