LAMIVTLP ;VA/DALISC/PAC - VITEK MICRO DATA LITERAL PARSER; 5-24-95;
;;5.2;AUTOMATED LAB INSTRUMENTS;**1030**;NOV 01, 1997
;;5.2;AUTOMATED LAB INSTRUMENTS;**12,35**;Sep 27, 1994;Build 7
;Parses the literal data stream and calls LAMIVTLU
;to stuff data in the LAH for verification
;***** LOCAL PATCH *****
LA1 S LANM=$T(+0),TSK=$O(^LAB(62.4,"C",LANM,0)) Q:TSK<1
Q:'$D(^LA(TSK,"I",0))
K LATOP D ^LASET Q:'TSK S LROVER=1,X="TRAP^"_LANM,@^%ZOSF("TRAP")
S MTRSL="mtrsl|",RT="rt",PI="pi",CI="ci",SI="si",ZZ="zz",U="^"
S LABUG="o2",LADRUG="a2",LAMIC="a3",A4="a4"
; FIELD HIEARCHY = "pi^si^ci^rt^zz"
S LABGNODE="o1",LANTIB="a1",LACOUNT=0
K ^TMP("VITEK") ;S LAFIN=0
LA2 K LAIN,LAPD,LASI,LART,LACI,LARTX
S TOUT=0,LAIN=0,LASUM=0,ERR=0
;Q:LAFIN=2
D IN G QUIT:TOUT,LA2:$E(IN,1,6)'=MTRSL
I IN["TEST PATTERN" G LA2
D AGAIN G:ERR LA2
D PARSE G:'$G(LACI(CI)) LA2
I $D(^LA("VITEK")) D DEBUG^LAMIVTLC
S ID=LACI(CI) ;G:$L(ID)<9 LA2
;----------------------------------------------------------------
; Entered to accomadate file 60 prefix field
; point to micro det-up file
; chk accn also
S:$D(^LAB(61.38,1,1)) LRPREFIX=^(1)
I $G(LRPREFIX)=1 D
. I '$D(^LRO(68,WL,1,LADT,1,ID)) D
.. I $L(ID)=6 S ID=+$E(ID,2,6)
LA3 S DHZGEN="S LOG=+ID D LOG^LAMIVTLG" S IDE=+ID
S LROVER=0
X DHZGEN G LA2:'ISQN ;Can be changed by the cross-link code
D ^LAMIVTLC
;CREATE^LAMIVTLC (DAVID'S RTN)
G LA2
AGAIN ;store records in array
;K LAHARCHY
READ ;
S LAIN=LAIN+1
S LAIN(LAIN)=IN S LASUM=LASUM+$$CHK(IN)
I IN["~]" D IN D Q
.S LAHEX=$$HEX(LASUM)
.S LAHEX=$E(LAHEX,$L(LAHEX)-1,$L(LAHEX))
.;D:LAHEX'[$E(IN,1,2) ERR("CHECKSUM") ;TAKEOFFLATER
D IN G AGAIN ;READ ;W !,"READ" G READ
PARSE ;create separate arrays pat demographics, tests, results, etc.
S TERM=0,INT="",FIN=0,II=1,END=0
S INT=INT_LAIN(II)
S INT=$P(INT,MTRSL,2) ;D ADD
K LAPD,LASI,LACI,LARTX,LART
;K LAPD pat demographics
PID D PD(INT,SI) D ADD G:'TERM&('END) PID
Q:END ;K LASI ;-> specimen demographics
SID D SI(INT,CI) D ADD G:'TERM&('END) SID
Q:END ;K LACI ;->culture demographics
CID D CI(INT,RT) D ADD G:'TERM&('END) CID
Q:END ;K LARTX,LART ;->results and other fields
RTD D RT(INT,ZZ) D ADD G:'TERM&('END) RTD
Q:END
G:'FIN!('TERM) RTD
Q
ADD ;
I END QUIT
I FIN,INT["|zz|" Q
I LAIN>II D
. S II=II+1
. I $L(INT)<160 S INT=$TR(INT,"~^")_LAIN(II) Q
. I INT["~^" S INT=$TR(INT,"~^")_LAIN(II) Q
. S INT=$TR(INT,"~^")_LAIN(II)
S FIN=II=LAIN
Q
PD(INPD,DELIM) ; patient demographics
S TERM=0
F J=1:1:$L(INPD,"|")-1 D Q:TERM!(END)
. S LAPD=$$BLANKS($P(INPD,"|",J))
. S:$E(LAPD,1,2)=DELIM TERM=1 D
. . S LAPD=$P(INPD,"|",J) S:LAPD=ZZ END=1
. . Q:$L(LAPD)<3
. . S LAPD($E(LAPD,1,2))=$E(LAPD,3,$L(LAPD))
S INT=$S(INPD[LAPD:$P(INPD,LAPD_"|",2),1:INPD)
Q
SI(INSD,DELIM) ; specimen demographics
S TERM=0
F J=1:1:$L(INSD,"|")-1 S:$E($P(INSD,"|",J),1,2)=DELIM TERM=1 Q:TERM!(END) D
.S LASI=$$BLANKS($P(INSD,"|",J)) S:LASI=ZZ END=1 Q:END I LASI'="" D
. .Q:$L(LASI)<3
. .S LASI($E(LASI,1,2))=$E(LASI,3,$L(LASI))
S INT=$S(INSD[LASI:$P(INSD,LASI_"|",2),1:INSD)
Q
CI(INTD,DELIM) ; exam info, id etc
S TERM=0
F J=1:1:$L(INTD,"|")-1 S:$E($P(INTD,"|",J),1,2)=DELIM TERM=1 Q:TERM!(END) D
. S LACI=$$BLANKS($P(INTD,"|",J)) S:LACI=ZZ END=1
. I LACI'="",$E(LACI)'="~" D
. .Q:$L(LACI)<3
. .S LACI($E(LACI,1,2))=$E(LACI,3,$L(LACI))
S INT=$S(INTD[LACI:$P(INTD,LACI_"|",2),1:INTD)
Q
RT(INTR,DELIM) ; results including tests organism, drugs etc.
S TERM=0 S L=$L(INTR,"|") ;S:INTR["~]" FIN=1
F J=1:1:L S LART=$$BLANKS($P(INTR,"|",J)) S:$E(LART,1,2)=DELIM END=1 Q:END Q:LART["~" Q:LART="" D ;!($L(LART)<3) D
.I LART["," D COMMA Q
.Q:$L(LART)<3
.I $D(SC) I SC="a3"&($E(LART,1,2)="a1") D
..S LARTX("a4")=$S($G(LARTX("a4")):LARTX("a4")+1,1:1)
..S LART("a4",LARTX("a4"))=LART("a3",LARTX("a4"))
.S SC=$E(LART,1,2)
.S LARTX(SC)=$S($G(LARTX(SC)):LARTX(SC)+1,1:1)
.S LART(SC,LARTX(SC))=$E(LART,3,$L(LART))
S INT=$P(INTR,"|",J,L)
S:II=LAIN&(END) FIN=1
Q
COMMA I SC="rr" S LAMULTST=1 Q
I SC'="gn" Q
S GN=$L(LART,",") Q:GN'>1
F L=1:1:GN D
.S LARTGN=$P(LART,",",L)
.S LARTX(SC)=$S($G(LARTX(SC)):LARTX(SC)+1,1:1)
.S LART(SC,LARTX(SC))=$$BLANKS($E(LARTGN,3,$L(LARTGN)))
Q
IN S CNT=^LA(TSK,"I",0)+1
IF '$D(^LA(TSK,"I",CNT)) S TOUT=TOUT+1 Q:TOUT>9 H 10 G IN
;S:TOUT>9 LAFIN=LAFIN+1 Q:TOUT>9 H 10 G IN
S ^LA(TSK,"I",0)=CNT,IN=^(CNT),TOUT=0
S ^TMP("VITEK",$J,CNT)=IN
Q
OUT S CNT=^LA(TSK,"O")+1,^("O")=CNT,^("O",CNT)=TSK_OUT
LOCK ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=TSK LOCK
Q
CHK(XX) ;
N X,I S XX=$TR(XX,"^"),X=0
F I=1:1:$L(XX) D
.S X=X+$S($E(XX,I)="~":30,$E(XX,I)="]":29,1:$A(XX,I))
Q X
;
QUIT I (^LA(TSK,"I")'=^LA(TSK,"I",0)) G LA2
I $D(^LA(TSK,"O",0)),^LA(TSK,"O")'=^LA(TSK,"O",0) G LA2
L ^LA(TSK) H 1
K ^LA(TSK),^LA("LOCK",TSK),^TMP($J),^TMP("LA",$J)
D KILL^%ZTLOAD
Q
TRAP D ^LABERR S T=TSK D SET^LAB G @("LA2^"_LANM) ;ERROR TRAP
;
HEX(HEX) ;
Q:'$D(HEX) 0 Q:'(HEX?.N) "*ERROR" Q:'HEX 0
N LADN,LADD,LADH S LADN=HEX,LADH=""
L I LADN'=0 D S LADH=LADD_LADH G L
.S LADD=LADN#16,LADN=LADN\16 Q:LADD<10 S LADD=$C($A("a")+LADD-10)
Q LADH
ERR(ERTYPE) ;
N LL
F LL=CNT-LAIN:1:CNT D
.S ^TMP("LA",ERTYPE_" ERR",$J,LL)=^LA(TSK,"I",LL)
S ^TMP("VITEK",LL)=LAHEX_U_LASUM_U_^LA(TSK,"I",LL)
S ERR=1
Q
BLANKS(XX) ;
N I,J
F I=$L(XX):-1:1 Q:$E(XX,I)'=" "
F J=1:1:$L(XX) Q:$E(XX,J)'=" "
Q $E(XX,J,I)
LAMIVTLP ;VA/DALISC/PAC - VITEK MICRO DATA LITERAL PARSER; 5-24-95;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1030**;NOV 01, 1997
+2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12,35**;Sep 27, 1994;Build 7
+3 ;Parses the literal data stream and calls LAMIVTLU
+4 ;to stuff data in the LAH for verification
+5 ;***** LOCAL PATCH *****
LA1 SET LANM=$TEXT(+0)
SET TSK=$ORDER(^LAB(62.4,"C",LANM,0))
IF TSK<1
QUIT
+1 IF '$DATA(^LA(TSK,"I",0))
QUIT
+2 KILL LATOP
DO ^LASET
IF 'TSK
QUIT
SET LROVER=1
SET X="TRAP^"_LANM
SET @^%ZOSF("TRAP")
+3 SET MTRSL="mtrsl|"
SET RT="rt"
SET PI="pi"
SET CI="ci"
SET SI="si"
SET ZZ="zz"
SET U="^"
+4 SET LABUG="o2"
SET LADRUG="a2"
SET LAMIC="a3"
SET A4="a4"
+5 ; FIELD HIEARCHY = "pi^si^ci^rt^zz"
+6 SET LABGNODE="o1"
SET LANTIB="a1"
SET LACOUNT=0
+7 ;S LAFIN=0
KILL ^TMP("VITEK")
LA2 KILL LAIN,LAPD,LASI,LART,LACI,LARTX
+1 SET TOUT=0
SET LAIN=0
SET LASUM=0
SET ERR=0
+2 ;Q:LAFIN=2
+3 DO IN
IF TOUT
GOTO QUIT
IF $EXTRACT(IN,1,6)'=MTRSL
GOTO LA2
+4 IF IN["TEST PATTERN"
GOTO LA2
+5 DO AGAIN
IF ERR
GOTO LA2
+6 DO PARSE
IF '$GET(LACI(CI))
GOTO LA2
+7 IF $DATA(^LA("VITEK"))
DO DEBUG^LAMIVTLC
+8 ;G:$L(ID)<9 LA2
SET ID=LACI(CI)
+9 ;----------------------------------------------------------------
+10 ; Entered to accomadate file 60 prefix field
+11 ; point to micro det-up file
+12 ; chk accn also
+13 IF $DATA(^LAB(61.38,1,1))
SET LRPREFIX=^(1)
+14 IF $GET(LRPREFIX)=1
Begin DoDot:1
+15 IF '$DATA(^LRO(68,WL,1,LADT,1,ID))
Begin DoDot:2
+16 IF $LENGTH(ID)=6
SET ID=+$EXTRACT(ID,2,6)
End DoDot:2
End DoDot:1
LA3 SET DHZGEN="S LOG=+ID D LOG^LAMIVTLG"
SET IDE=+ID
+1 SET LROVER=0
+2 ;Can be changed by the cross-link code
XECUTE DHZGEN
IF 'ISQN
GOTO LA2
+3 DO ^LAMIVTLC
+4 ;CREATE^LAMIVTLC (DAVID'S RTN)
+5 GOTO LA2
AGAIN ;store records in array
+1 ;K LAHARCHY
READ ;
+1 SET LAIN=LAIN+1
+2 SET LAIN(LAIN)=IN
SET LASUM=LASUM+$$CHK(IN)
+3 IF IN["~]"
DO IN
Begin DoDot:1
+4 SET LAHEX=$$HEX(LASUM)
+5 SET LAHEX=$EXTRACT(LAHEX,$LENGTH(LAHEX)-1,$LENGTH(LAHEX))
+6 ;D:LAHEX'[$E(IN,1,2) ERR("CHECKSUM") ;TAKEOFFLATER
End DoDot:1
QUIT
+7 ;READ ;W !,"READ" G READ
DO IN
GOTO AGAIN
PARSE ;create separate arrays pat demographics, tests, results, etc.
+1 SET TERM=0
SET INT=""
SET FIN=0
SET II=1
SET END=0
+2 SET INT=INT_LAIN(II)
+3 ;D ADD
SET INT=$PIECE(INT,MTRSL,2)
+4 KILL LAPD,LASI,LACI,LARTX,LART
+5 ;K LAPD pat demographics
PID DO PD(INT,SI)
DO ADD
IF 'TERM&('END)
GOTO PID
+1 ;K LASI ;-> specimen demographics
IF END
QUIT
SID DO SI(INT,CI)
DO ADD
IF 'TERM&('END)
GOTO SID
+1 ;K LACI ;->culture demographics
IF END
QUIT
CID DO CI(INT,RT)
DO ADD
IF 'TERM&('END)
GOTO CID
+1 ;K LARTX,LART ;->results and other fields
IF END
QUIT
RTD DO RT(INT,ZZ)
DO ADD
IF 'TERM&('END)
GOTO RTD
+1 IF END
QUIT
+2 IF 'FIN!('TERM)
GOTO RTD
+3 QUIT
ADD ;
+1 IF END
QUIT
+2 IF FIN
IF INT["|zz|"
QUIT
+3 IF LAIN>II
Begin DoDot:1
+4 SET II=II+1
+5 IF $LENGTH(INT)<160
SET INT=$TRANSLATE(INT,"~^")_LAIN(II)
QUIT
+6 IF INT["~^"
SET INT=$TRANSLATE(INT,"~^")_LAIN(II)
QUIT
+7 SET INT=$TRANSLATE(INT,"~^")_LAIN(II)
End DoDot:1
+8 SET FIN=II=LAIN
+9 QUIT
PD(INPD,DELIM) ; patient demographics
+1 SET TERM=0
+2 FOR J=1:1:$LENGTH(INPD,"|")-1
Begin DoDot:1
+3 SET LAPD=$$BLANKS($PIECE(INPD,"|",J))
+4 IF $EXTRACT(LAPD,1,2)=DELIM
SET TERM=1
Begin DoDot:2
+5 SET LAPD=$PIECE(INPD,"|",J)
IF LAPD=ZZ
SET END=1
+6 IF $LENGTH(LAPD)<3
QUIT
+7 SET LAPD($EXTRACT(LAPD,1,2))=$EXTRACT(LAPD,3,$LENGTH(LAPD))
End DoDot:2
End DoDot:1
IF TERM!(END)
QUIT
+8 SET INT=$SELECT(INPD[LAPD:$PIECE(INPD,LAPD_"|",2),1:INPD)
+9 QUIT
SI(INSD,DELIM) ; specimen demographics
+1 SET TERM=0
+2 FOR J=1:1:$LENGTH(INSD,"|")-1
IF $EXTRACT($PIECE(INSD,"|",J),1,2)=DELIM
SET TERM=1
IF TERM!(END)
QUIT
Begin DoDot:1
+3 SET LASI=$$BLANKS($PIECE(INSD,"|",J))
IF LASI=ZZ
SET END=1
IF END
QUIT
IF LASI'=""
Begin DoDot:2
+4 IF $LENGTH(LASI)<3
QUIT
+5 SET LASI($EXTRACT(LASI,1,2))=$EXTRACT(LASI,3,$LENGTH(LASI))
End DoDot:2
End DoDot:1
+6 SET INT=$SELECT(INSD[LASI:$PIECE(INSD,LASI_"|",2),1:INSD)
+7 QUIT
CI(INTD,DELIM) ; exam info, id etc
+1 SET TERM=0
+2 FOR J=1:1:$LENGTH(INTD,"|")-1
IF $EXTRACT($PIECE(INTD,"|",J),1,2)=DELIM
SET TERM=1
IF TERM!(END)
QUIT
Begin DoDot:1
+3 SET LACI=$$BLANKS($PIECE(INTD,"|",J))
IF LACI=ZZ
SET END=1
+4 IF LACI'=""
IF $EXTRACT(LACI)'="~"
Begin DoDot:2
+5 IF $LENGTH(LACI)<3
QUIT
+6 SET LACI($EXTRACT(LACI,1,2))=$EXTRACT(LACI,3,$LENGTH(LACI))
End DoDot:2
End DoDot:1
+7 SET INT=$SELECT(INTD[LACI:$PIECE(INTD,LACI_"|",2),1:INTD)
+8 QUIT
RT(INTR,DELIM) ; results including tests organism, drugs etc.
+1 ;S:INTR["~]" FIN=1
SET TERM=0
SET L=$LENGTH(INTR,"|")
+2 ;!($L(LART)<3) D
FOR J=1:1:L
SET LART=$$BLANKS($PIECE(INTR,"|",J))
IF $EXTRACT(LART,1,2)=DELIM
SET END=1
IF END
QUIT
IF LART["~"
QUIT
IF LART=""
QUIT
Begin DoDot:1
+3 IF LART[","
DO COMMA
QUIT
+4 IF $LENGTH(LART)<3
QUIT
+5 IF $DATA(SC)
IF SC="a3"&($EXTRACT(LART,1,2)="a1")
Begin DoDot:2
+6 SET LARTX("a4")=$SELECT($GET(LARTX("a4")):LARTX("a4")+1,1:1)
+7 SET LART("a4",LARTX("a4"))=LART("a3",LARTX("a4"))
End DoDot:2
+8 SET SC=$EXTRACT(LART,1,2)
+9 SET LARTX(SC)=$SELECT($GET(LARTX(SC)):LARTX(SC)+1,1:1)
+10 SET LART(SC,LARTX(SC))=$EXTRACT(LART,3,$LENGTH(LART))
End DoDot:1
+11 SET INT=$PIECE(INTR,"|",J,L)
+12 IF II=LAIN&(END)
SET FIN=1
+13 QUIT
COMMA IF SC="rr"
SET LAMULTST=1
QUIT
+1 IF SC'="gn"
QUIT
+2 SET GN=$LENGTH(LART,",")
IF GN'>1
QUIT
+3 FOR L=1:1:GN
Begin DoDot:1
+4 SET LARTGN=$PIECE(LART,",",L)
+5 SET LARTX(SC)=$SELECT($GET(LARTX(SC)):LARTX(SC)+1,1:1)
+6 SET LART(SC,LARTX(SC))=$$BLANKS($EXTRACT(LARTGN,3,$LENGTH(LARTGN)))
End DoDot:1
+7 QUIT
IN SET CNT=^LA(TSK,"I",0)+1
+1 IF '$DATA(^LA(TSK,"I",CNT))
SET TOUT=TOUT+1
IF TOUT>9
QUIT
HANG 10
GOTO IN
+2 ;S:TOUT>9 LAFIN=LAFIN+1 Q:TOUT>9 H 10 G IN
+3 SET ^LA(TSK,"I",0)=CNT
SET IN=^(CNT)
SET TOUT=0
+4 SET ^TMP("VITEK",$JOB,CNT)=IN
+5 QUIT
OUT SET CNT=^LA(TSK,"O")+1
SET ^("O")=CNT
SET ^("O",CNT)=TSK_OUT
+1 LOCK ^LA("Q")
SET Q=^LA("Q")+1
SET ^("Q")=Q
SET ^("Q",Q)=TSK
LOCK
+2 QUIT
CHK(XX) ;
+1 NEW X,I
SET XX=$TRANSLATE(XX,"^")
SET X=0
+2 FOR I=1:1:$LENGTH(XX)
Begin DoDot:1
+3 SET X=X+$SELECT($EXTRACT(XX,I)="~":30,$EXTRACT(XX,I)="]":29,1:$ASCII(XX,I))
End DoDot:1
+4 QUIT X
+5 ;
QUIT IF (^LA(TSK,"I")'=^LA(TSK,"I",0))
GOTO LA2
+1 IF $DATA(^LA(TSK,"O",0))
IF ^LA(TSK,"O")'=^LA(TSK,"O",0)
GOTO LA2
+2 LOCK ^LA(TSK)
HANG 1
+3 KILL ^LA(TSK),^LA("LOCK",TSK),^TMP($JOB),^TMP("LA",$JOB)
+4 DO KILL^%ZTLOAD
+5 QUIT
TRAP ;ERROR TRAP
DO ^LABERR
SET T=TSK
DO SET^LAB
GOTO @("LA2^"_LANM)
+1 ;
HEX(HEX) ;
+1 IF '$DATA(HEX)
QUIT 0
IF '(HEX?.N)
QUIT "*ERROR"
IF 'HEX
QUIT 0
+2 NEW LADN,LADD,LADH
SET LADN=HEX
SET LADH=""
L IF LADN'=0
Begin DoDot:1
+1 SET LADD=LADN#16
SET LADN=LADN\16
IF LADD<10
QUIT
SET LADD=$CHAR($ASCII("a")+LADD-10)
End DoDot:1
SET LADH=LADD_LADH
GOTO L
+2 QUIT LADH
ERR(ERTYPE) ;
+1 NEW LL
+2 FOR LL=CNT-LAIN:1:CNT
Begin DoDot:1
+3 SET ^TMP("LA",ERTYPE_" ERR",$JOB,LL)=^LA(TSK,"I",LL)
End DoDot:1
+4 SET ^TMP("VITEK",LL)=LAHEX_U_LASUM_U_^LA(TSK,"I",LL)
+5 SET ERR=1
+6 QUIT
BLANKS(XX) ;
+1 NEW I,J
+2 FOR I=$LENGTH(XX):-1:1
IF $EXTRACT(XX,I)'=" "
QUIT
+3 FOR J=1:1:$LENGTH(XX)
IF $EXTRACT(XX,J)'=" "
QUIT
+4 QUIT $EXTRACT(XX,J,I)
