LAGEN ;DALOI/STAFF - LAB AUTOMATED DATA ;11/18/11 15:03
;;5.2;AUTOMATED LAB INSTRUMENTS;**1,17,22,27,47,46,64,67,74**;Sep 27, 1994;Build 229
;
Q
;
LOG ; Run by accession number.
S LINK="",LRDFN=0,DPF=2
I $G(LOG)<1 G LG2
; If overlay data -> find if accession exists in LAH
I LROVER D Q:ISQN>0
. N I,X
. S (ISQN,I)=0
. F S I=$O(^LAH(LWL,1,"C",LOG,I)) Q:I<1 D Q:ISQN
. . S X=$G(^LAH(LWL,1,I,0))
. . ; Quit if different accession area.
. . I $P(X,"^",3)'=WL Q
. . ; Quit if different accession date and not a rollover accession (same original accession date).
. . I $P(X,"^",4)'=LADT,$P($G(^LRO(68,WL,1,LADT,1,LOG,0)),"^",3)'=$P($G(^LRO(68,WL,1,$P(X,"^",4),1,LOG,0)),"^",3) Q
. . S ISQN=I
. . D UPDT(LWL,ISQN)
I '$D(^LRO(68,WL,1,LADT,1,LOG,0)) S LINK="^^"_+LOG G LG2
S X=^LRO(68,WL,1,LADT,1,LOG,0),LINK=WL_U_LADT_U_LOG,LRDFN=+X,DPF=$P(X,U,2)
LG2 D ISQN
I $G(LOG)>0 S ^LAH(LWL,1,"C",LOG,ISQN)="",$P(^LAH(LWL,1,ISQN,0),U,3,5)=LINK
I $G(CENUM)>0 S $P(^LAH(LWL,1,ISQN,0),U,6)=CENUM,^LAH(LWL,1,"D",+CENUM,ISQN)=""
I $D(^LRO(68.2,LWL,1,+TRAY,1,+CUP,0)) S ^(4,ISQN)=""
Q
;
;
ISQN ;
L +^LAH(LWL):99999
;
F S (^LAH(LWL),ISQN)=1+$G(^LAH(LWL)) Q:'$D(^LAH(LWL,1,ISQN))
;
S:CUP="" TRAY=1,CUP=ISQN
S ^LAH(LWL,1,ISQN,0)=TRAY_U_CUP_"^^^^^"_METH_"^"_+$G(IDE)
;
D UPDT(LWL,ISQN)
;
S ^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP),ISQN)=""
;
; IDE xref added to enable correct identifier for CX4/CX5 instruments
S ^LAH(LWL,1,"E",+$G(IDE),ISQN)=""
;
; Set UID xref and .3 node, used to verify by unique identifier (UID).
I $G(LA7UID)'="" D UID(LWL,ISQN,LA7UID)
;
L -^LAH(LWL)
Q
;
;
LLIST ;
S LRDFN=0,DPF=2
;
I LROVER D Q:ISQN>0
. S ISQN=+$O(^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP),0))
. I ISQN D UPDT(LWL,ISQN)
;
; Run by load/work list number sent.
D ISQN S LINK="^^"
;
I $D(^LRO(68.2,LWL,1,TRAY,1,CUP,0)) S LINK=$P(^(0),"^",1,3),^(4,ISQN)=""
;
S $P(^LAH(LWL,1,ISQN,0),U,3,5)=LINK
;
S DPF=2
Q:LINK="^^"
S WL=+$P(LINK,"^",1),WDT=+$P(LINK,"^",2),LOG=+$P(LINK,"^",3),^LAH(LWL,1,"C",LOG,ISQN)=""
S X=$S($D(^LRO(68,WL,1,WDT,1,LOG,0)):^(0),1:"0^2"),DPF=+$P(X,U,2),LRDFN=+X
;
Q
;
;
SEQN ;
; Run by the order data received
S CUP=""
D LLIST
Q
;
;
CENUM ;
S DPF=2,LRDFN=0,LOG=$O(^LRO(68,WL,1,DT,1,"D",+CENUM,0))
G LOG:LOG>0 ;for martinez only
;IF CENUM?1A.ANP S Y=CENUM D CEPACK I Y?.ANP S DFN=$O(^LAB(62.3,"B",Y,0)) I DFN S DPF=62.3
;
D ISQN
;
S ^LAH(LWL,1,"C",LOG,ISQN)="",^LAH(LWL,1,"D",+CENUM,ISQN)="",$P(^LAH(LWL,1,ISQN,0),U,6)=CENUM
;
I $D(^LRO(68.2,LWL,1,TRAY,1,CUP,0)) S ^(4,ISQN)=""
Q
;
;
IDENT ;
S DPF=2,LRDFN=0,LOG=$O(^LRO(68,WL,1,DT,1,"C",IDENT,0))
I LOG>0 D LOG Q
D ISQN
Q
;
;
POC ; Entry point for POC interfaces to setup LAH using "E" x-ref
; IDE xref used to identify for POC specimen
I $G(IDE)'="" D Q:ISQN
. S ISQN=$O(^LAH(LWL,1,"E",IDE,0))
. I ISQN D UPDT(LWL,ISQN) Q
D LOG
Q
;
;
CONTROL ; Verify control's
;
Q:'$D(^LRO(68,WL,1,DT,1,LOG,0)) Q:$P(^(0),U,2)'=62.3
;
S LRDFN=+^LRO(68,WL,1,DT,1,LOG,0)
S IDT=+$P($G(^LRO(68,WL,1,DT,1,LOG,3)),"^",3)
I IDT<1 Q
I '$D(^LR(LRDFN,"CH",IDT,0)) Q
S $P(^LRO(68,WL,1,DT,1,LOG,3),U,4)=NOW
S $P(^LR(LRDFN,"CH",IDT,0),U,3)=NOW
;
F I=1:0 S I=$O(^LAH(LWL,1,ISQN,I)) Q:I<1 S ^LR(LRDFN,"CH",IDT,I)=^LAH(LWL,1,ISQN,I)
;
S:'$D(LRTEC) LRTEC=$P(^VA(200,DUZ,0),U,2)
;
F I=0:0 S I=$O(^LRO(68,WL,1,DT,1,LOG,4,I)) Q:I<1 I +$P(^(I,0),U,3)[LWL,'$P(^(0),U,5) S $P(^(0),U,5)=NOW,$P(^(0),U,4)=LRTEC,^LRO(68,WL,1,DT,1,"AC",NOW,LOG)="",^LRO(68,WL,1,DT,1,"AD",NOW\1,LOG)=""
D CONTXREF
K:$G(LOG) ^LAH(LWL,1,"C",+LOG)
K ^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP)),^LAH(LWL,1,ISQN)
;
Q
;
;
CEPACK S Y=$P(Y,"\",1),YY="" F I=1:1:$L(Y) S:$A(Y,I)>32 YY=YY_$E(Y,I)
S Y=YY
K YY
Q
;
;
CONTXREF ; Set up verification X-Ref for controls
;
N DA,LRTEST,LRTN,I,LRGTN,X1,X,S1,J,J1
;
S LRTEST=""
F LRTN=0:0 S LRTN=$O(^LRO(68,WL,1,DT,1,LOG,4,LRTN)) Q:LRTN<1 I $D(^(LRTN,0)),+$P(^(0),U,3)[LWL,+$P(^(0),U,5) S:LRTEST'="" LRTEST=LRTEST_"^"_LRTN S:LRTEST="" LRTEST=LRTN
AC ;
K ^TMP("LR",$J,"T")
D ^LREXPD
F X=0:0 S X=$O(^TMP("LR",$J,"T",X)) Q:X<1 S X1=$P(^(X),";",2) I X1,$D(^LR(LRDFN,"CH",IDT,X1)) S:'$D(^LRO(68,"AC",LRDFN,IDT,X1)) ^(X1)=""
K ^TMP("LR",$J,"T")
Q
;
;
UPDT(LWL,ISQN) ; Set/update date/time this entry in LAH has data added.
; Used by clear instrument data option to allow selective clearing based on date/time criteria.
; Call with LWL = ien of load/list in LAH
; ISQN = ien of sequence
N LANOW,LAX
;
S LANOW=$$NOW^XLFDT
S LAX=$P($G(^LAH(LWL,1,ISQN,0)),"^",10,11)
;
; Created date/time_"^"_update date/time.
S LAX=$S($P(LAX,"^",1):$P(LAX,"^",1),1:LANOW)_"^"_LANOW
S $P(^LAH(LWL,1,ISQN,0),"^",10,11)=LAX
Q
;
;
UID(LWL,ISQN,UID) ; Set .3 node and "U" xref with accession's UID.
; Used to verify by unique identifier (UID).
; Call with LWL = ien of load/list in LAH
; ISQN = ien of sequence
; UID = accession's UID
; Called from above, LRVR1, LRVRW
;
N X
;
S X=$P($G(^LAH(LWL,1,ISQN,.3)),"^")
; Kill x-ref if existing value different than new value.
I X]"",X'=UID K ^LAH(LWL,1,"U",X,ISQN)
;
S $P(^LAH(LWL,1,ISQN,.3),"^")=UID
S ^LAH(LWL,1,"U",UID,ISQN)=""
Q
;
;
POI(LWL,ISQN,NODE,LAID) ; Set .1 node with patient/order info
; Call with LWL = ien of load/list in LAH
; ISQN = ien of sequence
; NODE = node to store data on (PID, OBR)
; LAID = array containing values
; PID - "DFN","DOB","ICN","LRDFN","LRTDFN","PNM","SEX","SSN"
; OBR - "EOL","FID","ORCDT","ORDNLT","ORDP","PON","SID","PEB","PVB"
;
; ^LAH(LWL,1,ISQN,.1,"OBR","ARI") = assistant result interpreter (DUZ or id^last name, first name, mi [id]) (OBR-33)
; ^LAH(LWL,1,ISQN,.1,"OBR","EOL") = enterer's ordering location
; ^LAH(LWL,1,ISQN,.1,"OBR","FID") = filler specimen id
; ^LAH(LWL,1,ISQN,.1,"OBR","ORCDT") = order date/time (FileMan d/t)
; ^LAH(LWL,1,ISQN,.1,"OBR","ORDNLT") = order NLT (multiple separated by "^")
; ^LAH(LWL,1,ISQN,.1,"OBR","ORDP") = ordering provider (DUZ or id^last name, first name, mi [id]) (OBR-16)
; ^LAH(LWL,1,ISQN,.1,"OBR","PEB") = placer entered by (DUZ or id^last name, first name, mi [id])
; ^LAH(LWL,1,ISQN,.1,"OBR","PON") = placer order number
; ^LAH(LWL,1,ISQN,.1,"OBR","PRI") = principle result interpreter (DUZ or id^last name, first name, mi [id]) (OBR-32)
; ^LAH(LWL,1,ISQN,.1,"OBR","PVB") = placer verified by (DUZ or id^last name, first name, mi [id])
; ^LAH(LWL,1,ISQN,.1,"OBR","SID") = placer specimen id
; ^LAH(LWL,1,ISQN,.1,"OBR","TECH") = technican (DUZ or id^last name, first name, mi [id]) (OBR-34)
; ^LAH(LWL,1,ISQN,.1,"PID","DFN") = patient's DFN in file #2
; ^LAH(LWL,1,ISQN,.1,"PID","DOB") = date of birth (FileMan d/t)
; ^LAH(LWL,1,ISQN,.1,"PID","ICN") = patient's ICN
; ^LAH(LWL,1,ISQN,.1,"PID","LRDFN") = patient's LRDFN in file #63
; ^LAH(LWL,1,ISQN,.1,"PID","LRTDFN") = patient's LRTDFN in file #67
; ^LAH(LWL,1,ISQN,.1,"PID","PNM") = patient's name
; ^LAH(LWL,1,ISQN,.1,"PID","SEX") = patient's sex
; ^LAH(LWL,1,ISQN,.1,"PID","SSN") = patient's SSN
;
N LAX,LAY,LAZ
;
S LAX=""
F S LAX=$O(LAID(LAX)) Q:LAX="" D
. S LAY=LAID(LAX)
. I LAY="" Q
. S LAZ=$G(^LAH(LWL,1,ISQN,.1,NODE,LAX))
. I LAY=LAZ Q
. ; Remove old data and cross-references.
. I LAZ'="" D
. . K ^LAH(LWL,1,ISQN,.1,NODE,LAX)
. . I $P(LAZ,"^")]"" K ^LAH(LWL,1,"A"_LAX,$P(LAZ,"^"),ISQN)
. ; Set new values and cross-references.
. S ^LAH(LWL,1,ISQN,.1,NODE,LAX)=LAY
. I $P(LAY,"^")'="" S ^LAH(LWL,1,"A"_LAX,$P(LAY,"^"),ISQN)=""
;
Q
;
;
LATYP(LWL,ISQN,LAX) ; Set type of interface for this entry
; Call with LWL = ien of load/list in LAH
; ISQN = ien of sequence
; LAX = type of interface
;
S $P(^LAH(LWL,1,ISQN,0),"^",12)=LAX
Q
;
;
LAMSGID(LWL,ISQN,LAX) ; Set pointer to file #62.49 for this entry.
; Call with LWL = ien of load/list in LAH
; ISQN = ien of sequence
; LAX = ien of entry in file #62.49 that is source of these results
;
S $P(^LAH(LWL,1,ISQN,0),"^",13)=LAX
S ^LAH(LWL,1,ISQN,.01,LAX)=""
Q
;
;
METH(LWL,ISQN,LAX) ; Save instrument name/method for this entry
; Call with LWL = ien of load/list in LAH
; ISQN = ien of sequence
; LAX = method text
;
N X
S X=$P(^LAH(LWL,1,ISQN,0),"^",7)
I X'[LAX S X=LAX_";"_X,$P(^LAH(LWL,1,ISQN,0),"^",7)=X
Q
;
;
SUBID(LWL,ISQN,LRSS,NODE,SUBID) ; Set/lookup entry for a sub-id (isolate id)
; Call with LWL = ien of load/list in LAH
; ISQN = ien of sequence
; LRSS = subscript in LAH
; NODE = data node in LAH
; SUBID = sub-id to lookup/use to link entry
;
; Returns ISQN2 = entry linked to sub-id
;
N ISQN2
Q:SUBID="" -1
S ISQN2=$O(^LAH(LWL,1,ISQN,LRSS,NODE,"C",SUBID,0))
I 'ISQN2 D
. S ISQN2=$O(^LAH(LWL,1,ISQN,LRSS,NODE,"A"),-1)
. S ISQN2=ISQN2+1
. S ^LAH(LWL,1,ISQN,LRSS,NODE,"C",SUBID,ISQN2)=""
. S ^LAH(LWL,1,ISQN,LRSS,"C",SUBID,NODE,ISQN2)=""
Q ISQN2
;
LAH(LAWL,LADA,LASS,LASUB,LAP,LAVAL) ;
; sets data into LAH
; Inputs
; LAWL : WorkLoad List
; LADA :
; LASS : SubScript
; LASUB :
; LAP : Data position ($Piece of node)
; : if -1 will set the entire node=LAVAL (for WP type data)
; LAVAL : The VALue to set
N NODE
I LAVAL="@" S LAVAL=""
I LAVAL="""""" S LAVAL=""
I LAP'=-1 I LAVAL["^" S LAVAL=$TR(LAVAL,"^"," ")
S LAWL=+$G(LAWL)
S LADA=+$G(LADA)
S LASS=$G(LASS)
S LASUB=$G(LASUB)
S NODE="^LAH(LAWL,1,LADA,"""_LASS_""","
S NODE=NODE_LASUB
S:$E(NODE,$L(NODE),$L(NODE))'=")" NODE=NODE_")"
I LAP>0 S $P(@NODE,"^",+$G(LAP))=LAVAL
I LAP=-1 S @NODE=LAVAL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAGEN 9843 printed Apr 09, 2024@20:44:34 Page 2
LAGEN ;DALOI/STAFF - LAB AUTOMATED DATA ;11/18/11 15:03
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1,17,22,27,47,46,64,67,74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
LOG ; Run by accession number.
+1 SET LINK=""
SET LRDFN=0
SET DPF=2
+2 IF $GET(LOG)<1
GOTO LG2
+3 ; If overlay data -> find if accession exists in LAH
+4 IF LROVER
Begin DoDot:1
+5 NEW I,X
+6 SET (ISQN,I)=0
+7 FOR
SET I=$ORDER(^LAH(LWL,1,"C",LOG,I))
if I<1
QUIT
Begin DoDot:2
+8 SET X=$GET(^LAH(LWL,1,I,0))
+9 ; Quit if different accession area.
+10 IF $PIECE(X,"^",3)'=WL
QUIT
+11 ; Quit if different accession date and not a rollover accession (same original accession date).
+12 IF $PIECE(X,"^",4)'=LADT
IF $PIECE($GET(^LRO(68,WL,1,LADT,1,LOG,0)),"^",3)'=$PIECE($GET(^LRO(68,WL,1,$PIECE(X,"^",4),1,LOG,0)),"^",3)
QUIT
+13 SET ISQN=I
+14 DO UPDT(LWL,ISQN)
End DoDot:2
if ISQN
QUIT
End DoDot:1
if ISQN>0
QUIT
+15 IF '$DATA(^LRO(68,WL,1,LADT,1,LOG,0))
SET LINK="^^"_+LOG
GOTO LG2
+16 SET X=^LRO(68,WL,1,LADT,1,LOG,0)
SET LINK=WL_U_LADT_U_LOG
SET LRDFN=+X
SET DPF=$PIECE(X,U,2)
LG2 DO ISQN
+1 IF $GET(LOG)>0
SET ^LAH(LWL,1,"C",LOG,ISQN)=""
SET $PIECE(^LAH(LWL,1,ISQN,0),U,3,5)=LINK
+2 IF $GET(CENUM)>0
SET $PIECE(^LAH(LWL,1,ISQN,0),U,6)=CENUM
SET ^LAH(LWL,1,"D",+CENUM,ISQN)=""
+3 IF $DATA(^LRO(68.2,LWL,1,+TRAY,1,+CUP,0))
SET ^(4,ISQN)=""
+4 QUIT
+5 ;
+6 ;
ISQN ;
+1 LOCK +^LAH(LWL):99999
+2 ;
+3 FOR
SET (^LAH(LWL),ISQN)=1+$GET(^LAH(LWL))
if '$DATA(^LAH(LWL,1,ISQN))
QUIT
+4 ;
+5 if CUP=""
SET TRAY=1
SET CUP=ISQN
+6 SET ^LAH(LWL,1,ISQN,0)=TRAY_U_CUP_"^^^^^"_METH_"^"_+$GET(IDE)
+7 ;
+8 DO UPDT(LWL,ISQN)
+9 ;
+10 SET ^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP),ISQN)=""
+11 ;
+12 ; IDE xref added to enable correct identifier for CX4/CX5 instruments
+13 SET ^LAH(LWL,1,"E",+$GET(IDE),ISQN)=""
+14 ;
+15 ; Set UID xref and .3 node, used to verify by unique identifier (UID).
+16 IF $GET(LA7UID)'=""
DO UID(LWL,ISQN,LA7UID)
+17 ;
+18 LOCK -^LAH(LWL)
+19 QUIT
+20 ;
+21 ;
LLIST ;
+1 SET LRDFN=0
SET DPF=2
+2 ;
+3 IF LROVER
Begin DoDot:1
+4 SET ISQN=+$ORDER(^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP),0))
+5 IF ISQN
DO UPDT(LWL,ISQN)
End DoDot:1
if ISQN>0
QUIT
+6 ;
+7 ; Run by load/work list number sent.
+8 DO ISQN
SET LINK="^^"
+9 ;
+10 IF $DATA(^LRO(68.2,LWL,1,TRAY,1,CUP,0))
SET LINK=$PIECE(^(0),"^",1,3)
SET ^(4,ISQN)=""
+11 ;
+12 SET $PIECE(^LAH(LWL,1,ISQN,0),U,3,5)=LINK
+13 ;
+14 SET DPF=2
+15 if LINK="^^"
QUIT
+16 SET WL=+$PIECE(LINK,"^",1)
SET WDT=+$PIECE(LINK,"^",2)
SET LOG=+$PIECE(LINK,"^",3)
SET ^LAH(LWL,1,"C",LOG,ISQN)=""
+17 SET X=$SELECT($DATA(^LRO(68,WL,1,WDT,1,LOG,0)):^(0),1:"0^2")
SET DPF=+$PIECE(X,U,2)
SET LRDFN=+X
+18 ;
+19 QUIT
+20 ;
+21 ;
SEQN ;
+1 ; Run by the order data received
+2 SET CUP=""
+3 DO LLIST
+4 QUIT
+5 ;
+6 ;
CENUM ;
+1 SET DPF=2
SET LRDFN=0
SET LOG=$ORDER(^LRO(68,WL,1,DT,1,"D",+CENUM,0))
+2 ;for martinez only
if LOG>0
GOTO LOG
+3 ;IF CENUM?1A.ANP S Y=CENUM D CEPACK I Y?.ANP S DFN=$O(^LAB(62.3,"B",Y,0)) I DFN S DPF=62.3
+4 ;
+5 DO ISQN
+6 ;
+7 SET ^LAH(LWL,1,"C",LOG,ISQN)=""
SET ^LAH(LWL,1,"D",+CENUM,ISQN)=""
SET $PIECE(^LAH(LWL,1,ISQN,0),U,6)=CENUM
+8 ;
+9 IF $DATA(^LRO(68.2,LWL,1,TRAY,1,CUP,0))
SET ^(4,ISQN)=""
+10 QUIT
+11 ;
+12 ;
IDENT ;
+1 SET DPF=2
SET LRDFN=0
SET LOG=$ORDER(^LRO(68,WL,1,DT,1,"C",IDENT,0))
+2 IF LOG>0
DO LOG
QUIT
+3 DO ISQN
+4 QUIT
+5 ;
+6 ;
POC ; Entry point for POC interfaces to setup LAH using "E" x-ref
+1 ; IDE xref used to identify for POC specimen
+2 IF $GET(IDE)'=""
Begin DoDot:1
+3 SET ISQN=$ORDER(^LAH(LWL,1,"E",IDE,0))
+4 IF ISQN
DO UPDT(LWL,ISQN)
QUIT
End DoDot:1
if ISQN
QUIT
+5 DO LOG
+6 QUIT
+7 ;
+8 ;
CONTROL ; Verify control's
+1 ;
+2 if '$DATA(^LRO(68,WL,1,DT,1,LOG,0))
QUIT
if $PIECE(^(0),U,2)'=62.3
QUIT
+3 ;
+4 SET LRDFN=+^LRO(68,WL,1,DT,1,LOG,0)
+5 SET IDT=+$PIECE($GET(^LRO(68,WL,1,DT,1,LOG,3)),"^",3)
+6 IF IDT<1
QUIT
+7 IF '$DATA(^LR(LRDFN,"CH",IDT,0))
QUIT
+8 SET $PIECE(^LRO(68,WL,1,DT,1,LOG,3),U,4)=NOW
+9 SET $PIECE(^LR(LRDFN,"CH",IDT,0),U,3)=NOW
+10 ;
+11 FOR I=1:0
SET I=$ORDER(^LAH(LWL,1,ISQN,I))
if I<1
QUIT
SET ^LR(LRDFN,"CH",IDT,I)=^LAH(LWL,1,ISQN,I)
+12 ;
+13 if '$DATA(LRTEC)
SET LRTEC=$PIECE(^VA(200,DUZ,0),U,2)
+14 ;
+15 FOR I=0:0
SET I=$ORDER(^LRO(68,WL,1,DT,1,LOG,4,I))
if I<1
QUIT
IF +$PIECE(^(I,0),U,3)[LWL
IF '$PIECE(^(0),U,5)
SET $PIECE(^(0),U,5)=NOW
SET $PIECE(^(0),U,4)=LRTEC
SET ^LRO(68,WL,1,DT,1,"AC",NOW,LOG)=""
SET ^LRO(68,WL,1,DT,1,"AD",NOW\1,LOG)=""
+16 DO CONTXREF
+17 if $GET(LOG)
KILL ^LAH(LWL,1,"C",+LOG)
+18 KILL ^LAH(LWL,1,"B",(+TRAY)_";"_(+CUP)),^LAH(LWL,1,ISQN)
+19 ;
+20 QUIT
+21 ;
+22 ;
CEPACK SET Y=$PIECE(Y,"\",1)
SET YY=""
FOR I=1:1:$LENGTH(Y)
if $ASCII(Y,I)>32
SET YY=YY_$EXTRACT(Y,I)
+1 SET Y=YY
+2 KILL YY
+3 QUIT
+4 ;
+5 ;
CONTXREF ; Set up verification X-Ref for controls
+1 ;
+2 NEW DA,LRTEST,LRTN,I,LRGTN,X1,X,S1,J,J1
+3 ;
+4 SET LRTEST=""
+5 FOR LRTN=0:0
SET LRTN=$ORDER(^LRO(68,WL,1,DT,1,LOG,4,LRTN))
if LRTN<1
QUIT
IF $DATA(^(LRTN,0))
IF +$PIECE(^(0),U,3)[LWL
IF +$PIECE(^(0),U,5)
if LRTEST'=""
SET LRTEST=LRTEST_"^"_LRTN
if LRTEST=""
SET LRTEST=LRTN
AC ;
+1 KILL ^TMP("LR",$JOB,"T")
+2 DO ^LREXPD
+3 FOR X=0:0
SET X=$ORDER(^TMP("LR",$JOB,"T",X))
if X<1
QUIT
SET X1=$PIECE(^(X),";",2)
IF X1
IF $DATA(^LR(LRDFN,"CH",IDT,X1))
if '$DATA(^LRO(68,"AC",LRDFN,IDT,X1))
SET ^(X1)=""
+4 KILL ^TMP("LR",$JOB,"T")
+5 QUIT
+6 ;
+7 ;
UPDT(LWL,ISQN) ; Set/update date/time this entry in LAH has data added.
+1 ; Used by clear instrument data option to allow selective clearing based on date/time criteria.
+2 ; Call with LWL = ien of load/list in LAH
+3 ; ISQN = ien of sequence
+4 NEW LANOW,LAX
+5 ;
+6 SET LANOW=$$NOW^XLFDT
+7 SET LAX=$PIECE($GET(^LAH(LWL,1,ISQN,0)),"^",10,11)
+8 ;
+9 ; Created date/time_"^"_update date/time.
+10 SET LAX=$SELECT($PIECE(LAX,"^",1):$PIECE(LAX,"^",1),1:LANOW)_"^"_LANOW
+11 SET $PIECE(^LAH(LWL,1,ISQN,0),"^",10,11)=LAX
+12 QUIT
+13 ;
+14 ;
UID(LWL,ISQN,UID) ; Set .3 node and "U" xref with accession's UID.
+1 ; Used to verify by unique identifier (UID).
+2 ; Call with LWL = ien of load/list in LAH
+3 ; ISQN = ien of sequence
+4 ; UID = accession's UID
+5 ; Called from above, LRVR1, LRVRW
+6 ;
+7 NEW X
+8 ;
+9 SET X=$PIECE($GET(^LAH(LWL,1,ISQN,.3)),"^")
+10 ; Kill x-ref if existing value different than new value.
+11 IF X]""
IF X'=UID
KILL ^LAH(LWL,1,"U",X,ISQN)
+12 ;
+13 SET $PIECE(^LAH(LWL,1,ISQN,.3),"^")=UID
+14 SET ^LAH(LWL,1,"U",UID,ISQN)=""
+15 QUIT
+16 ;
+17 ;
POI(LWL,ISQN,NODE,LAID) ; Set .1 node with patient/order info
+1 ; Call with LWL = ien of load/list in LAH
+2 ; ISQN = ien of sequence
+3 ; NODE = node to store data on (PID, OBR)
+4 ; LAID = array containing values
+5 ; PID - "DFN","DOB","ICN","LRDFN","LRTDFN","PNM","SEX","SSN"
+6 ; OBR - "EOL","FID","ORCDT","ORDNLT","ORDP","PON","SID","PEB","PVB"
+7 ;
+8 ; ^LAH(LWL,1,ISQN,.1,"OBR","ARI") = assistant result interpreter (DUZ or id^last name, first name, mi [id]) (OBR-33)
+9 ; ^LAH(LWL,1,ISQN,.1,"OBR","EOL") = enterer's ordering location
+10 ; ^LAH(LWL,1,ISQN,.1,"OBR","FID") = filler specimen id
+11 ; ^LAH(LWL,1,ISQN,.1,"OBR","ORCDT") = order date/time (FileMan d/t)
+12 ; ^LAH(LWL,1,ISQN,.1,"OBR","ORDNLT") = order NLT (multiple separated by "^")
+13 ; ^LAH(LWL,1,ISQN,.1,"OBR","ORDP") = ordering provider (DUZ or id^last name, first name, mi [id]) (OBR-16)
+14 ; ^LAH(LWL,1,ISQN,.1,"OBR","PEB") = placer entered by (DUZ or id^last name, first name, mi [id])
+15 ; ^LAH(LWL,1,ISQN,.1,"OBR","PON") = placer order number
+16 ; ^LAH(LWL,1,ISQN,.1,"OBR","PRI") = principle result interpreter (DUZ or id^last name, first name, mi [id]) (OBR-32)
+17 ; ^LAH(LWL,1,ISQN,.1,"OBR","PVB") = placer verified by (DUZ or id^last name, first name, mi [id])
+18 ; ^LAH(LWL,1,ISQN,.1,"OBR","SID") = placer specimen id
+19 ; ^LAH(LWL,1,ISQN,.1,"OBR","TECH") = technican (DUZ or id^last name, first name, mi [id]) (OBR-34)
+20 ; ^LAH(LWL,1,ISQN,.1,"PID","DFN") = patient's DFN in file #2
+21 ; ^LAH(LWL,1,ISQN,.1,"PID","DOB") = date of birth (FileMan d/t)
+22 ; ^LAH(LWL,1,ISQN,.1,"PID","ICN") = patient's ICN
+23 ; ^LAH(LWL,1,ISQN,.1,"PID","LRDFN") = patient's LRDFN in file #63
+24 ; ^LAH(LWL,1,ISQN,.1,"PID","LRTDFN") = patient's LRTDFN in file #67
+25 ; ^LAH(LWL,1,ISQN,.1,"PID","PNM") = patient's name
+26 ; ^LAH(LWL,1,ISQN,.1,"PID","SEX") = patient's sex
+27 ; ^LAH(LWL,1,ISQN,.1,"PID","SSN") = patient's SSN
+28 ;
+29 NEW LAX,LAY,LAZ
+30 ;
+31 SET LAX=""
+32 FOR
SET LAX=$ORDER(LAID(LAX))
if LAX=""
QUIT
Begin DoDot:1
+33 SET LAY=LAID(LAX)
+34 IF LAY=""
QUIT
+35 SET LAZ=$GET(^LAH(LWL,1,ISQN,.1,NODE,LAX))
+36 IF LAY=LAZ
QUIT
+37 ; Remove old data and cross-references.
+38 IF LAZ'=""
Begin DoDot:2
+39 KILL ^LAH(LWL,1,ISQN,.1,NODE,LAX)
+40 IF $PIECE(LAZ,"^")]""
KILL ^LAH(LWL,1,"A"_LAX,$PIECE(LAZ,"^"),ISQN)
End DoDot:2
+41 ; Set new values and cross-references.
+42 SET ^LAH(LWL,1,ISQN,.1,NODE,LAX)=LAY
+43 IF $PIECE(LAY,"^")'=""
SET ^LAH(LWL,1,"A"_LAX,$PIECE(LAY,"^"),ISQN)=""
End DoDot:1
+44 ;
+45 QUIT
+46 ;
+47 ;
LATYP(LWL,ISQN,LAX) ; Set type of interface for this entry
+1 ; Call with LWL = ien of load/list in LAH
+2 ; ISQN = ien of sequence
+3 ; LAX = type of interface
+4 ;
+5 SET $PIECE(^LAH(LWL,1,ISQN,0),"^",12)=LAX
+6 QUIT
+7 ;
+8 ;
LAMSGID(LWL,ISQN,LAX) ; Set pointer to file #62.49 for this entry.
+1 ; Call with LWL = ien of load/list in LAH
+2 ; ISQN = ien of sequence
+3 ; LAX = ien of entry in file #62.49 that is source of these results
+4 ;
+5 SET $PIECE(^LAH(LWL,1,ISQN,0),"^",13)=LAX
+6 SET ^LAH(LWL,1,ISQN,.01,LAX)=""
+7 QUIT
+8 ;
+9 ;
METH(LWL,ISQN,LAX) ; Save instrument name/method for this entry
+1 ; Call with LWL = ien of load/list in LAH
+2 ; ISQN = ien of sequence
+3 ; LAX = method text
+4 ;
+5 NEW X
+6 SET X=$PIECE(^LAH(LWL,1,ISQN,0),"^",7)
+7 IF X'[LAX
SET X=LAX_";"_X
SET $PIECE(^LAH(LWL,1,ISQN,0),"^",7)=X
+8 QUIT
+9 ;
+10 ;
SUBID(LWL,ISQN,LRSS,NODE,SUBID) ; Set/lookup entry for a sub-id (isolate id)
+1 ; Call with LWL = ien of load/list in LAH
+2 ; ISQN = ien of sequence
+3 ; LRSS = subscript in LAH
+4 ; NODE = data node in LAH
+5 ; SUBID = sub-id to lookup/use to link entry
+6 ;
+7 ; Returns ISQN2 = entry linked to sub-id
+8 ;
+9 NEW ISQN2
+10 if SUBID=""
QUIT -1
+11 SET ISQN2=$ORDER(^LAH(LWL,1,ISQN,LRSS,NODE,"C",SUBID,0))
+12 IF 'ISQN2
Begin DoDot:1
+13 SET ISQN2=$ORDER(^LAH(LWL,1,ISQN,LRSS,NODE,"A"),-1)
+14 SET ISQN2=ISQN2+1
+15 SET ^LAH(LWL,1,ISQN,LRSS,NODE,"C",SUBID,ISQN2)=""
+16 SET ^LAH(LWL,1,ISQN,LRSS,"C",SUBID,NODE,ISQN2)=""
End DoDot:1
+17 QUIT ISQN2
+18 ;
LAH(LAWL,LADA,LASS,LASUB,LAP,LAVAL) ;
+1 ; sets data into LAH
+2 ; Inputs
+3 ; LAWL : WorkLoad List
+4 ; LADA :
+5 ; LASS : SubScript
+6 ; LASUB :
+7 ; LAP : Data position ($Piece of node)
+8 ; : if -1 will set the entire node=LAVAL (for WP type data)
+9 ; LAVAL : The VALue to set
+10 NEW NODE
+11 IF LAVAL="@"
SET LAVAL=""
+12 IF LAVAL=""""""
SET LAVAL=""
+13 IF LAP'=-1
IF LAVAL["^"
SET LAVAL=$TRANSLATE(LAVAL,"^"," ")
+14 SET LAWL=+$GET(LAWL)
+15 SET LADA=+$GET(LADA)
+16 SET LASS=$GET(LASS)
+17 SET LASUB=$GET(LASUB)
+18 SET NODE="^LAH(LAWL,1,LADA,"""_LASS_""","
+19 SET NODE=NODE_LASUB
+20 if $EXTRACT(NODE,$LENGTH(NODE),$LENGTH(NODE))'=")"
SET NODE=NODE_")"
+21 IF LAP>0
SET $PIECE(@NODE,"^",+$GET(LAP))=LAVAL
+22 IF LAP=-1
SET @NODE=LAVAL
+23 QUIT
