LAXSYM ;MLD/ABBOTT/SLC/RAF - TEMPLATE ROUTINE FOR AUTOMATED DATA ;6/13/96 0900 ;
;;5.2;AUTOMATED LAB INSTRUMENTS;**11,19**;Sep 27, 1994
;CROSS LINK BY ID OR IDE
;
LAPX ; orig routine name, copied to LAXSYM (for Abbott AxSYM) 5/3/94 /mld
;
N FR,LANM,TSK,LANM,A,I,X,Y,TC,TV,V1,TOUT,BAD,ID,IDE,TRAY,CUP,LANOCTL1,TP
N LATEST,RMK,DATE,CNT,LAGEN,RESCOM,RESTYPE,HCNT,DFN,HTYPE,IN,OUT,D
N LALCT,LAZZ,LINK,LOG,LRDFN,LROVER,LWL,METH,NOW,WL,ALPHA,TST60,TSK
N ISQN,LADT
;
LA1 ; Init vars/arrays
S LANM=$T(+0),TSK=$O(^LAB(62.4,"C",LANM,0)) Q:TSK<1
K LATOP D ^LASET Q:'TSK
D LA1INIT^LAXSYMU ; init vars in util routine
;
LA2 ; Begin here to parse out data
K TV,Y
S (TST60,TOUT)=0,(A,TRAY)=1,(CUP,ID,IDE,RMK)="",D="|"
D IN ; get data
G QUIT:TOUT,LA2:IN=""!(V1'="H") ; 'H' is start of packet
G:$F("HPORLCQMS",V1)<2 LA2 ; frame hdr = line tag
I V1="H" S HCNT=CNT-1 ; get hdr count for error trapping
D @V1 ; get hdr info
;
; loop thru single packet, L=end of packet
F A=2:1 D IN Q:TOUT!(V1="L") I $F("ORLCQMS",V1)>1 D @V1 ; bypass HP
;
LA3 ; Now process the packet
G:'$G(ID) LA2 ; not valid or incomplete record
X LAGEN G LA2:'ISQN ; Can be changed by the cross-link code
F I=0:0 S I=$O(TV(I)) Q:I<1 S:TV(I,1)]"" ^LAH(LWL,1,ISQN,I)=TV(I,1)
I RMK]"" D RMK^LASET
G LA2
;
H ; Header node TYPE: P=pt, Q=qc
S HTYPE=$P(IN,D,12)
Q
;
P ; Patient node
S DFN=$P($P(IN,D,5),U)
Q
;
O ; Order node.
N SPECID,TNUM,PTYPE,X,AN,L
S SPECID=$P(IN,D,4),AN=$P(SPECID,U),L=$L(AN)
; AN is the numeric value of the last 4 characters of SID field!
S AN=+$TR($E(AN,(L-4),L),ALPHA) ; just the #
S TNUM=+$P($P(IN,D,5),U,4)
Q:'TNUM Q:'AN ; no AxSYM test or Accn Num
S TST60=$$ACCN ; get file 60 test num (TST60)
Q:'TST60 ; invalid test
S PTYPE=$P(IN,D,12) ; ""=pt, Q=QC
Q:$P(IN,D,26)'="F" ; 'F'inal, X=could not run tst
S (ID,IDE)=AN ; should be OK
Q
;
R ; Results node
Q:'ID ; no accn to put results to!
N TST,TNUM,TRES,V,DEC,FLAG
S FLAG=$P(IN,D,7) Q:FLAG="<" Q:FLAG=">" ; test out of range
;
S TST=$P(IN,D,3) ; eg., TST = "^^^211^GLUCOSE^UNDILUTED"
S TNUM=+$P(TST,U,4) ; AxSYM's internal test number
Q:'$D(LATEST(TNUM,TST60)) ; invalid AxSYM/DHCP test match
;
S TRES=$P(TST,U,8),V=$P(IN,D,4)
I TRES="X" S ^LA(INST,"ERX",$H)=IN Q ; Xception results (error msg)
Q:"F"'[TRES ; type result should be "F"inal or NULL
Q:V="" ; no result!
;
S DEC=TC(+LATEST(TNUM,TST60),3)
I $L(DEC) S V=$J(V,1,DEC) ; # dec'mls (Param 2)
X:$L(TC(+LATEST(TNUM,TST60),2)) TC(+LATEST(TNUM,TST60),2) ; use param 1
S @TC(+LATEST(TNUM,TST60),1)=V ; save to TV array
Q
;
L ; Packet termination node
Q
;
C ; Comments node. type = G if result comment, = I if Exception string
S (RMK,RESCOM)=$P(IN,D,4),RESTYPE=$P(IN,D,5)
Q
;
Q ; Set-up Query node
N LRAN,LRAA,LRDT,LRNAME,SSN,LRFRM,BAD,LRAD,INST
S LRAA=WL,(LRDT,LRAD)=LADT,LRNAME="",LRFRM=0,BAD=0,INST=TSK
S LRAN=$P($P(IN,D,3),U,2)
D PNM^LAXSYMBL
; chk for valid request
I LRNAME=""!('$F(IN,"^^ALL")) S $P(IN,"|",13)="X",BAD=1
D HQSET^LAXSYMHQ ; builds H/Q/L frames for downloading
S X="TRAP^"_LANM,@^%ZOSF("TRAP") ; reset error trap
Q
;
M ; Manufacturer node
Q
;
S ; Scientific (not used)
Q
;
ACCN() ; Chk file 68 for Accn'd test (file 60)
N I,J,N S (I,J,N)=0
F S I=$O(LATEST(TNUM,I)) Q:'I I $D(^LRO(68,WL,1,LADT,1,AN,4,I)) Q
I 'I F S J=$O(^LRO(68,WL,1,LADT,1,AN,4,J)) Q:'J S I=0 D I N S I=N Q
.F S I=$O(^LAB(60,J,2,I)) Q:'I I $D(LATEST(TNUM,^(I,0))) S N=^(0) Q
Q +I
;
NUM ;- not used here - IN+3,4 replaces this (slower) code /mld
S X="" F JJ=1:1:$L(V) S:$A(V,JJ)>32 X=X_$E(V,JJ)
S V=X
Q
;
IN S CNT=^LA(TSK,"I",0)+1 IF '$D(^(CNT)) S TOUT=TOUT+1 Q:TOUT>5 H 5 G IN
S ^LA(TSK,"I",0)=CNT,IN=^(CNT),TOUT=0
; strip contl chars, get FRame num and hdr node (H,P,O,R,L)
; NOTE: $TR(IN,LANOCTL1) replaces 'D NUM' code in template routine /mld
S IN=$TR(IN,LANOCTL1),FR=+IN,V1=$TR($P(IN,D),FR)
Q
;
QUIT L +^LA(TSK,"I")
K ^LA(TSK,"I"),^LA("LOCK",TSK),^TMP($J),^TMP("LA",$J)
I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
L -^LA(TSK,"I")
Q
;
TRAP ; Process errors
D ^LABERR S T=TSK
S ^LA(TSK,"I",0)=+$G(HCNT) ; keeps last HDR frame location
D SET^LAB G LA2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAXSYM 4267 printed Apr 09, 2024@20:47:27 Page 2
LAXSYM ;MLD/ABBOTT/SLC/RAF - TEMPLATE ROUTINE FOR AUTOMATED DATA ;6/13/96 0900 ;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**11,19**;Sep 27, 1994
+2 ;CROSS LINK BY ID OR IDE
+3 ;
LAPX ; orig routine name, copied to LAXSYM (for Abbott AxSYM) 5/3/94 /mld
+1 ;
+2 NEW FR,LANM,TSK,LANM,A,I,X,Y,TC,TV,V1,TOUT,BAD,ID,IDE,TRAY,CUP,LANOCTL1,TP
+3 NEW LATEST,RMK,DATE,CNT,LAGEN,RESCOM,RESTYPE,HCNT,DFN,HTYPE,IN,OUT,D
+4 NEW LALCT,LAZZ,LINK,LOG,LRDFN,LROVER,LWL,METH,NOW,WL,ALPHA,TST60,TSK
+5 NEW ISQN,LADT
+6 ;
LA1 ; Init vars/arrays
+1 SET LANM=$TEXT(+0)
SET TSK=$ORDER(^LAB(62.4,"C",LANM,0))
if TSK<1
QUIT
+2 KILL LATOP
DO ^LASET
if 'TSK
QUIT
+3 ; init vars in util routine
DO LA1INIT^LAXSYMU
+4 ;
LA2 ; Begin here to parse out data
+1 KILL TV,Y
+2 SET (TST60,TOUT)=0
SET (A,TRAY)=1
SET (CUP,ID,IDE,RMK)=""
SET D="|"
+3 ; get data
DO IN
+4 ; 'H' is start of packet
if TOUT
GOTO QUIT
if IN=""!(V1'="H")
GOTO LA2
+5 ; frame hdr = line tag
if $FIND("HPORLCQMS",V1)<2
GOTO LA2
+6 ; get hdr count for error trapping
IF V1="H"
SET HCNT=CNT-1
+7 ; get hdr info
DO @V1
+8 ;
+9 ; loop thru single packet, L=end of packet
+10 ; bypass HP
FOR A=2:1
DO IN
if TOUT!(V1="L")
QUIT
IF $FIND("ORLCQMS",V1)>1
DO @V1
+11 ;
LA3 ; Now process the packet
+1 ; not valid or incomplete record
if '$GET(ID)
GOTO LA2
+2 ; Can be changed by the cross-link code
XECUTE LAGEN
if 'ISQN
GOTO LA2
+3 FOR I=0:0
SET I=$ORDER(TV(I))
if I<1
QUIT
if TV(I,1)]""
SET ^LAH(LWL,1,ISQN,I)=TV(I,1)
+4 IF RMK]""
DO RMK^LASET
+5 GOTO LA2
+6 ;
H ; Header node TYPE: P=pt, Q=qc
+1 SET HTYPE=$PIECE(IN,D,12)
+2 QUIT
+3 ;
P ; Patient node
+1 SET DFN=$PIECE($PIECE(IN,D,5),U)
+2 QUIT
+3 ;
O ; Order node.
+1 NEW SPECID,TNUM,PTYPE,X,AN,L
+2 SET SPECID=$PIECE(IN,D,4)
SET AN=$PIECE(SPECID,U)
SET L=$LENGTH(AN)
+3 ; AN is the numeric value of the last 4 characters of SID field!
+4 ; just the #
SET AN=+$TRANSLATE($EXTRACT(AN,(L-4),L),ALPHA)
+5 SET TNUM=+$PIECE($PIECE(IN,D,5),U,4)
+6 ; no AxSYM test or Accn Num
if 'TNUM
QUIT
if 'AN
QUIT
+7 ; get file 60 test num (TST60)
SET TST60=$$ACCN
+8 ; invalid test
if 'TST60
QUIT
+9 ; ""=pt, Q=QC
SET PTYPE=$PIECE(IN,D,12)
+10 ; 'F'inal, X=could not run tst
if $PIECE(IN,D,26)'="F"
QUIT
+11 ; should be OK
SET (ID,IDE)=AN
+12 QUIT
+13 ;
R ; Results node
+1 ; no accn to put results to!
if 'ID
QUIT
+2 NEW TST,TNUM,TRES,V,DEC,FLAG
+3 ; test out of range
SET FLAG=$PIECE(IN,D,7)
if FLAG="<"
QUIT
if FLAG=">"
QUIT
+4 ;
+5 ; eg., TST = "^^^211^GLUCOSE^UNDILUTED"
SET TST=$PIECE(IN,D,3)
+6 ; AxSYM's internal test number
SET TNUM=+$PIECE(TST,U,4)
+7 ; invalid AxSYM/DHCP test match
if '$DATA(LATEST(TNUM,TST60))
QUIT
+8 ;
+9 SET TRES=$PIECE(TST,U,8)
SET V=$PIECE(IN,D,4)
+10 ; Xception results (error msg)
IF TRES="X"
SET ^LA(INST,"ERX",$HOROLOG)=IN
QUIT
+11 ; type result should be "F"inal or NULL
if "F"'[TRES
QUIT
+12 ; no result!
if V=""
QUIT
+13 ;
+14 SET DEC=TC(+LATEST(TNUM,TST60),3)
+15 ; # dec'mls (Param 2)
IF $LENGTH(DEC)
SET V=$JUSTIFY(V,1,DEC)
+16 ; use param 1
if $LENGTH(TC(+LATEST(TNUM,TST60),2))
XECUTE TC(+LATEST(TNUM,TST60),2)
+17 ; save to TV array
SET @TC(+LATEST(TNUM,TST60),1)=V
+18 QUIT
+19 ;
L ; Packet termination node
+1 QUIT
+2 ;
C ; Comments node. type = G if result comment, = I if Exception string
+1 SET (RMK,RESCOM)=$PIECE(IN,D,4)
SET RESTYPE=$PIECE(IN,D,5)
+2 QUIT
+3 ;
Q ; Set-up Query node
+1 NEW LRAN,LRAA,LRDT,LRNAME,SSN,LRFRM,BAD,LRAD,INST
+2 SET LRAA=WL
SET (LRDT,LRAD)=LADT
SET LRNAME=""
SET LRFRM=0
SET BAD=0
SET INST=TSK
+3 SET LRAN=$PIECE($PIECE(IN,D,3),U,2)
+4 DO PNM^LAXSYMBL
+5 ; chk for valid request
+6 IF LRNAME=""!('$FIND(IN,"^^ALL"))
SET $PIECE(IN,"|",13)="X"
SET BAD=1
+7 ; builds H/Q/L frames for downloading
DO HQSET^LAXSYMHQ
+8 ; reset error trap
SET X="TRAP^"_LANM
SET @^%ZOSF("TRAP")
+9 QUIT
+10 ;
M ; Manufacturer node
+1 QUIT
+2 ;
S ; Scientific (not used)
+1 QUIT
+2 ;
ACCN() ; Chk file 68 for Accn'd test (file 60)
+1 NEW I,J,N
SET (I,J,N)=0
+2 FOR
SET I=$ORDER(LATEST(TNUM,I))
if 'I
QUIT
IF $DATA(^LRO(68,WL,1,LADT,1,AN,4,I))
QUIT
+3 IF 'I
FOR
SET J=$ORDER(^LRO(68,WL,1,LADT,1,AN,4,J))
if 'J
QUIT
SET I=0
Begin DoDot:1
+4 FOR
SET I=$ORDER(^LAB(60,J,2,I))
if 'I
QUIT
IF $DATA(LATEST(TNUM,^(I,0)))
SET N=^(0)
QUIT
End DoDot:1
IF N
SET I=N
QUIT
+5 QUIT +I
+6 ;
NUM ;- not used here - IN+3,4 replaces this (slower) code /mld
+1 SET X=""
FOR JJ=1:1:$LENGTH(V)
if $ASCII(V,JJ)>32
SET X=X_$EXTRACT(V,JJ)
+2 SET V=X
+3 QUIT
+4 ;
IN SET CNT=^LA(TSK,"I",0)+1
IF '$DATA(^(CNT))
SET TOUT=TOUT+1
if TOUT>5
QUIT
HANG 5
GOTO IN
+1 SET ^LA(TSK,"I",0)=CNT
SET IN=^(CNT)
SET TOUT=0
+2 ; strip contl chars, get FRame num and hdr node (H,P,O,R,L)
+3 ; NOTE: $TR(IN,LANOCTL1) replaces 'D NUM' code in template routine /mld
+4 SET IN=$TRANSLATE(IN,LANOCTL1)
SET FR=+IN
SET V1=$TRANSLATE($PIECE(IN,D),FR)
+5 QUIT
+6 ;
QUIT LOCK +^LA(TSK,"I")
+1 KILL ^LA(TSK,"I"),^LA("LOCK",TSK),^TMP($JOB),^TMP("LA",$JOB)
+2 IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+3 LOCK -^LA(TSK,"I")
+4 QUIT
+5 ;
TRAP ; Process errors
+1 DO ^LABERR
SET T=TSK
+2 ; keeps last HDR frame location
SET ^LA(TSK,"I",0)=+$GET(HCNT)
+3 DO SET^LAB
GOTO LA2
