- 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 Feb 18, 2025@23:08:52 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