LR7OF1 ;DALOI/STAFF - Setup new order from OE/RR ;Jan 27, 2008
;;5.2;LAB SERVICE;**121,187,223,256,299,291,350**;Sep 27, 1994;Build 230
;
EN ; Setup NEW orders from OE/RR messages
; [^TMP("OR",$J,"LRES") DOCUMENTATION]
; 'Combining of Orders' functionality depends on this TMP global
; Set and Killed when BHS and BTS batch message headers are received
; Global contains a list of lab orders for a session
; Lab adds elements to the global array as orders are processed:
; ^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$J,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
; ^TMP("OR",$J,"LRES","CTR")=Count
;
N ZTSK,LRORDR,X,UNEEK,LRNT ;UNEEK forces a unique entry (Micro tests), set when ^..."LROT" built
D DT
S LRORDR=LRXZ
S:'$D(^TMP("OR",$J,"LRES","CTR")) ^("CTR")=0
F LRSAMP=-1:0 S LRSAMP=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP)) Q:LRSAMP="" D
. F LRSPEC=-1:0 S LRSPEC=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC)) Q:LRSPEC="" S X=^(LRSPEC,0) D
. . S ORIFN=+X,UNEEK=$P(X,"^",2)
. . D ZX
Q
;
;
ZX ;
N COMBINE,X,NEWORD
I '$D(^LRO(69,LRODT,0)) S ^(0)=$P(^LRO(69,0),U,1,2)_"^"_LRODT_"^"_(1+$P(^(0),U,4)),^LRO(69,LRODT,0)=LRODT,^LRO(69,"B",LRODT,LRODT)=""
S COMBINE=""
;
I 'UNEEK D
. S COMBINE=$$ORES^LR7OF5(LRDFN,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
. I COMBINE="" S COMBINE=$$FIND^LR7OF5(LRDFN,LRODT,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
;
I COMBINE="" S (NEWORD,LRQUIET)=1 D ORDER^LROW2 K ZTSK,ZTQUEUED,ZTREQ G LOCK
;
I $E(COMBINE,1,2)="S." S LRSN=$P(COMBINE,".",2),LRORD=$P(COMBINE,".",3) G ADD ;Combine on specimen
I $E(COMBINE,1,2)="O."!($E(COMBINE,1,2)="C.") S LRORD=$S($E(COMBINE,1,2)="O.":$P(COMBINE,".",2),1:$P(COMBINE,".",3)) ;Combine on order #
;
LOCK ;
L +^LRO(69,LRODT,1):360
I '$T G LOCK
S LRSN=1+$O(^LRO(69,LRODT,1,999999999),-1),LRSUM=1+$S($D(^LRO(69,LRODT,1,0)):$P(^(0),U,4),1:0)
;
ZSN ;
I $D(^LRO(69,LRODT,1,LRSN,0)) S LRSN=LRSN+1 G ZSN
S ^LRO(69,LRODT,1,LRSN,0)=LRDFN_"^"_LRDUZ_"^"_+LRSAMP_"^"_LRORDR_"^"_LRNT_"^"_LRPRAC_"^"_LRLLOC_"^"_LRSDT_"^"_LROLLOC_"^^"_ORIFN
S ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_"^"_LRSUM
L -^LRO(69,LRODT,1)
;
S ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
S ^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,"SN")=LRSN
S ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
;
I LRLLOC'="" S ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
I LRSPEC'="" S ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1",^(1,0)=LRSPEC
;
S ^LRO(69,LRODT,1,LRSN,.1)=LRORD,^LRO(69,"C",+LRORD,LRODT,LRSN)=""
;I $G(NEWORD) L -^LRO(69,$E(DT,1,3)_"0000",2)
;
ADD ;
N I,J,LRJ,LRSXN,LRORIFN,NODE,STATUS
S ^TMP("OR",$J,"LRES","CTR")=^TMP("OR",$J,"LRES","CTR")+1,^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$J,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
S LRORIFN=+$G(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,0))
;
S J=0
F LRJ=1:1 S J=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J)) Q:J<1 S NODE=^(J),STATUS=$G(^(J,1)) D ZSN1(NODE,STATUS)
;
S (LRSXN,I)=0
F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S LRSXN=LRSXN+1
S:LRSXN ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
;
I $E(COMBINE,1,2)="C." D
. S (LRSXN,I)=0 F S I=$O(^LRO(69,LRODT,1,+$P(COMBINE,".",2),2,I)) Q:I<1 S LRSXN=LRSXN+1
. S:LRSXN ^LRO(69,LRODT,1,+$P(COMBINE,".",2),2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
Q
;
;
ZSN1(NODE,STATUS) ;Add tests
N CNT,XI,X,I,C,TCNT
S CNT=+$O(^LRO(69,LRODT,1,LRSN,2,99999),-1)
S LRTSTS=+NODE,LRQUANT=$P(NODE,"^",2)
;
I $D(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS)) S REJECT(LRTSTS)="" Q
S ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0)=LRTSTS_"^"_$S($L(STATUS):STATUS,1:LROUTINE)_"^^^^^"_LRORIFN
;
D SDGX69^LRBEBA2(J,(CNT+LRJ)_","_LRSN_","_LRODT_",")
;
; Add "~" to comment lines, when needed, to insure that "~" is stored with comments
; to distinguish order and result comments when moved to file #63.
I $O(^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,0)) D
. S X=^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J)+$S($P($G(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)),"^",4):$P(^(0),"^",4),1:0)
. S ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)="^^"_X_"^"_X_"^"_DT
. S TCNT=+$O(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,99999),-1),(C,I)=0
. F S I=$O(^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I)) Q:I<1 D
. . S X=^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I)
. . I $E(X,1)'="~" S X="~"_X
. . S C=C+1
. . S ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,C+TCNT,0)=X
;
S ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,CNT+LRJ)=""
S ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)="",^(-LRODT)=""
;
I $E(COMBINE,1,2)="C." D
. S X=^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0),$P(^(0),"^",6)=LRORD
. S XI=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)
. S XI=XI_LRORD_"/",$P(^(1),"^",7)=XI
. N CNT1
. S CNT1=$O(^LRO(69,LRODT,1,+$P(COMBINE,".",2),2,99999),-1)+1,^(CNT1,0)=X,$P(^(0),"^",14)=LRODT_";"_LRSN_";"_(CNT+LRJ)
. S ^LRO(69,LRODT,1,$P(COMBINE,".",2),2,"B",LRTSTS,CNT1)=""
Q
;
;
DT ;
S DT=$$DT^XLFDT
S LRNT=$P($H,",",2),LRNT=LRNT\3600*100+(LRNT\60#60)/10000+DT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OF1 4982 printed Dec 13, 2024@02:04:57 Page 2
LR7OF1 ;DALOI/STAFF - Setup new order from OE/RR ;Jan 27, 2008
+1 ;;5.2;LAB SERVICE;**121,187,223,256,299,291,350**;Sep 27, 1994;Build 230
+2 ;
EN ; Setup NEW orders from OE/RR messages
+1 ; [^TMP("OR",$J,"LRES") DOCUMENTATION]
+2 ; 'Combining of Orders' functionality depends on this TMP global
+3 ; Set and Killed when BHS and BTS batch message headers are received
+4 ; Global contains a list of lab orders for a session
+5 ; Lab adds elements to the global array as orders are processed:
+6 ; ^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$J,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
+7 ; ^TMP("OR",$J,"LRES","CTR")=Count
+8 ;
+9 ;UNEEK forces a unique entry (Micro tests), set when ^..."LROT" built
NEW ZTSK,LRORDR,X,UNEEK,LRNT
+10 DO DT
+11 SET LRORDR=LRXZ
+12 if '$DATA(^TMP("OR",$JOB,"LRES","CTR"))
SET ^("CTR")=0
+13 FOR LRSAMP=-1:0
SET LRSAMP=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP))
if LRSAMP=""
QUIT
Begin DoDot:1
+14 FOR LRSPEC=-1:0
SET LRSPEC=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC))
if LRSPEC=""
QUIT
SET X=^(LRSPEC,0)
Begin DoDot:2
+15 SET ORIFN=+X
SET UNEEK=$PIECE(X,"^",2)
+16 DO ZX
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
+19 ;
ZX ;
+1 NEW COMBINE,X,NEWORD
+2 IF '$DATA(^LRO(69,LRODT,0))
SET ^(0)=$PIECE(^LRO(69,0),U,1,2)_"^"_LRODT_"^"_(1+$PIECE(^(0),U,4))
SET ^LRO(69,LRODT,0)=LRODT
SET ^LRO(69,"B",LRODT,LRODT)=""
+3 SET COMBINE=""
+4 ;
+5 IF 'UNEEK
Begin DoDot:1
+6 SET COMBINE=$$ORES^LR7OF5(LRDFN,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
+7 IF COMBINE=""
SET COMBINE=$$FIND^LR7OF5(LRDFN,LRODT,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
End DoDot:1
+8 ;
+9 IF COMBINE=""
SET (NEWORD,LRQUIET)=1
DO ORDER^LROW2
KILL ZTSK,ZTQUEUED,ZTREQ
GOTO LOCK
+10 ;
+11 ;Combine on specimen
IF $EXTRACT(COMBINE,1,2)="S."
SET LRSN=$PIECE(COMBINE,".",2)
SET LRORD=$PIECE(COMBINE,".",3)
GOTO ADD
+12 ;Combine on order #
IF $EXTRACT(COMBINE,1,2)="O."!($EXTRACT(COMBINE,1,2)="C.")
SET LRORD=$SELECT($EXTRACT(COMBINE,1,2)="O.":$PIECE(COMBINE,".",2),1:$PIECE(COMBINE,".",3))
+13 ;
LOCK ;
+1 LOCK +^LRO(69,LRODT,1):360
+2 IF '$TEST
GOTO LOCK
+3 SET LRSN=1+$ORDER(^LRO(69,LRODT,1,999999999),-1)
SET LRSUM=1+$SELECT($DATA(^LRO(69,LRODT,1,0)):$PIECE(^(0),U,4),1:0)
+4 ;
ZSN ;
+1 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET LRSN=LRSN+1
GOTO ZSN
+2 SET ^LRO(69,LRODT,1,LRSN,0)=LRDFN_"^"_LRDUZ_"^"_+LRSAMP_"^"_LRORDR_"^"_LRNT_"^"_LRPRAC_"^"_LRLLOC_"^"_LRSDT_"^"_LROLLOC_"^^"_ORIFN
+3 SET ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_"^"_LRSUM
+4 LOCK -^LRO(69,LRODT,1)
+5 ;
+6 SET ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
+7 SET ^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,"SN")=LRSN
+8 SET ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
+9 ;
+10 IF LRLLOC'=""
SET ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
+11 IF LRSPEC'=""
SET ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1"
SET ^(1,0)=LRSPEC
+12 ;
+13 SET ^LRO(69,LRODT,1,LRSN,.1)=LRORD
SET ^LRO(69,"C",+LRORD,LRODT,LRSN)=""
+14 ;I $G(NEWORD) L -^LRO(69,$E(DT,1,3)_"0000",2)
+15 ;
ADD ;
+1 NEW I,J,LRJ,LRSXN,LRORIFN,NODE,STATUS
+2 SET ^TMP("OR",$JOB,"LRES","CTR")=^TMP("OR",$JOB,"LRES","CTR")+1
SET ^TMP("OR",$JOB,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$JOB,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
+3 SET LRORIFN=+$GET(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,0))
+4 ;
+5 SET J=0
+6 FOR LRJ=1:1
SET J=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J))
if J<1
QUIT
SET NODE=^(J)
SET STATUS=$GET(^(J,1))
DO ZSN1(NODE,STATUS)
+7 ;
+8 SET (LRSXN,I)=0
+9 FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
if I<1
QUIT
SET LRSXN=LRSXN+1
+10 if LRSXN
SET ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
+11 ;
+12 IF $EXTRACT(COMBINE,1,2)="C."
Begin DoDot:1
+13 SET (LRSXN,I)=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,+$PIECE(COMBINE,".",2),2,I))
if I<1
QUIT
SET LRSXN=LRSXN+1
+14 if LRSXN
SET ^LRO(69,LRODT,1,+$PIECE(COMBINE,".",2),2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
End DoDot:1
+15 QUIT
+16 ;
+17 ;
ZSN1(NODE,STATUS) ;Add tests
+1 NEW CNT,XI,X,I,C,TCNT
+2 SET CNT=+$ORDER(^LRO(69,LRODT,1,LRSN,2,99999),-1)
+3 SET LRTSTS=+NODE
SET LRQUANT=$PIECE(NODE,"^",2)
+4 ;
+5 IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS))
SET REJECT(LRTSTS)=""
QUIT
+6 SET ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0)=LRTSTS_"^"_$SELECT($LENGTH(STATUS):STATUS,1:LROUTINE)_"^^^^^"_LRORIFN
+7 ;
+8 DO SDGX69^LRBEBA2(J,(CNT+LRJ)_","_LRSN_","_LRODT_",")
+9 ;
+10 ; Add "~" to comment lines, when needed, to insure that "~" is stored with comments
+11 ; to distinguish order and result comments when moved to file #63.
+12 IF $ORDER(^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,0))
Begin DoDot:1
+13 SET X=^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J)+$SELECT($PIECE($GET(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)),"^",4):$PIECE(^(0),"^",4),1:0)
+14 SET ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)="^^"_X_"^"_X_"^"_DT
+15 SET TCNT=+$ORDER(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,99999),-1)
SET (C,I)=0
+16 FOR
SET I=$ORDER(^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I))
if I<1
QUIT
Begin DoDot:2
+17 SET X=^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I)
+18 IF $EXTRACT(X,1)'="~"
SET X="~"_X
+19 SET C=C+1
+20 SET ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,C+TCNT,0)=X
End DoDot:2
End DoDot:1
+21 ;
+22 SET ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,CNT+LRJ)=""
+23 SET ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)=""
SET ^(-LRODT)=""
+24 ;
+25 IF $EXTRACT(COMBINE,1,2)="C."
Begin DoDot:1
+26 SET X=^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0)
SET $PIECE(^(0),"^",6)=LRORD
+27 SET XI=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
+28 SET XI=XI_LRORD_"/"
SET $PIECE(^(1),"^",7)=XI
+29 NEW CNT1
+30 SET CNT1=$ORDER(^LRO(69,LRODT,1,+$PIECE(COMBINE,".",2),2,99999),-1)+1
SET ^(CNT1,0)=X
SET $PIECE(^(0),"^",14)=LRODT_";"_LRSN_";"_(CNT+LRJ)
+31 SET ^LRO(69,LRODT,1,$PIECE(COMBINE,".",2),2,"B",LRTSTS,CNT1)=""
End DoDot:1
+32 QUIT
+33 ;
+34 ;
DT ;
+1 SET DT=$$DT^XLFDT
+2 SET LRNT=$PIECE($HOROLOG,",",2)
SET LRNT=LRNT\3600*100+(LRNT\60#60)/10000+DT
+3 QUIT
