- LR7OB3 ;DALOI/DCM/JAH - Build message, backdoor from Lab order #;Sep 27, 2018@10:00:00
- ;;5.2;LAB SERVICE;**121,187,272,291,462,512,541**;Sep 27, 1994;Build 7
- 69 K ^TMP("LRX",$J)
- D 69^LR7OB69(ODT,SN) Q:'$D(^TMP("LRX",$J,69)) G OUT:'$D(DFN) D:LRFIRST FIRST^LR7OB0 S LRFIRST=0
- SNEAK ;
- N Y,Y9,Y10,Y11,GRP,L1,L2,L3,END,LROR100
- S IFN=0 F S IFN=$O(^TMP("LRX",$J,69,IFN)) Q:IFN<1 S (COBR,COBX)=0 D
- . I $O(^TMP("LRX",$J,69,IFN,68,0)) S Z=^TMP("LRX",$J,69,IFN,68) D Q
- .. S IFN1=0 F S IFN1=$O(^TMP("LRX",$J,69,IFN,68,IFN1)) Q:IFN1<1 S Z1=^TMP("LRX",$J,69,IFN,68,IFN1) D
- ... S (Y9,Y10,Y11)="" I $P($G(^LAB(60,+Z1,64)),"^") S Y9=$P(^(64),"^"),Y10=$P(^LAM(Y9,0),"^"),Y9=$P(^(0),"^",2),Y11="99NLT"
- ... S X1=$$UVID^LR7OU0($P(Z1,"^"),$P(^TMP("LRX",$J,69),"^",10),Y9,Y11,Y10,.MSG,$G(SS))
- ... S X2=$$HL7DT^LR7OU0($P(Z,"^",4)) ;Obs Start date
- ... S X3=$$ACTCODE^LR7OU0($P(^TMP("LRX",$J,69),"^",4)) ;Specimen Act Code
- ... S X4=$$HL7DT^LR7OU0($P(Z,"^",5)) ;Specimen Received D/T
- ... S X5=$$SAMP^LR7OU0($P(^TMP("LRX",$J,69),"^",3),$P(^TMP("LRX",$J,69),"^",10)) ;Specimen Source
- ... S X6=$P(Z,"^",3) ;Filler Fld 1 (Accession)
- ... S X7=$$HL7DT^LR7OU0($P(Z,"^",6)) ;Results rpt/Sts Change D/T
- ... ;CPRS order number:
- ... S LROR100=$P($G(^TMP("LRX",$J,69,IFN)),"^",7)
- ... ;
- ... ;Check to see if the CPRS order number matches the ORC order number
- ... I $P($P(@MSG@(ORCMSG),"|",3),"^")'=LROR100 D
- .... N LRORC
- .... S LRORC=$P(@MSG@(ORCMSG),"|",3)
- .... S $P(LRORC,"^")=LROR100
- .... S $P(@MSG@(ORCMSG),"|",3)=LRORC
- ... S (GRP,END)=0
- ... I '$G(CORRECT),$P(Z,"^",6) S GRP=1
- ... ;LR*5.2*512 change on line below so that status of each panel and/or
- ... ;atomic test is evaluated: added $P(Z1,"^",4):"F"
- ... ;Variables:
- ... ; Z = (1) Lab order number ^ (2) LRDFN ^ (3) accession ^ (4) draw time ^
- ... ; (5) lab arrival time ^ (6) date/time results available (i.e. accession complete date)
- ... ; (7) inverse date (i.e. file 63 subscript corresponding to this accession)
- ... ;
- ... ; Z1 = (1) test number ^ (2) test urgency ^ (3) technologist ^ (4) complete date/time ^
- ... ;
- ... S X8=$S($G(CORRECT):"C",$P(Z,"^",6):$S(GRP:"F",1:"I"),$P(Z1,"^",4):"F",$P(Z,"^",5):"I",1:"O") ;Result Status
- ... D AX8
- ... S X10=$P(^TMP("LRX",$J,69),"^",7),$P(@MSG@(3),"|",4)=X10 ;Routing Location
- ... S X9="^^^^^"_$$URG^LR7OU0($P(^TMP("LRX",$J,69,IFN),"^",2))
- ... I $O(LINK(0)) S CTR=CTR+1 D NTE^LR7OU01(2,"L","LINK(",CTR) K LINK
- ... I $O(^TMP("LRX",$J,69,IFN,"NC",0)) S CTR=CTR+1 D NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",""NC"",",CTR)
- ... I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- ... I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- ... S CTR=CTR+1,COBR=COBR+1,OBRMSG=CTR D OBR^LR7OU01(CTR)
- ... S CTR=CTR+1 D SDG1^LRBEBA2(IFN,.CTR,.MSG)
- ... I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- ... I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- .. S IFN1=0 F S IFN1=$O(^TMP("LRX",$J,69,IFN,63,IFN1)) Q:IFN1<1 S Z1=^TMP("LRX",$J,69,IFN,63,IFN1) D
- ... S X1=$S($L($P(Z1,"^",8)):$P(Z1,"^",8),1:"ST") ;Value type
- ... S X2=$$UVID^LR7OU0($P(Z1,"^"),$P(^TMP("LRX",$J,69),"^",10),$P(Z1,"^",9),$P(Z1,"^",11),$P(Z1,"^",10),.MSG,$G(SS))
- ... S X3=$P(Z1,"^",7) ;Obs SubID
- ... S X4=$P(Z1,"^",2) S:$L($P(Z1,"^",9))&(MSG["LRAP") X4=$P(Z1,"^",9)_"^"_$P(Z1,"^",2)_"^"_$P(Z1,"^",10) ;Value
- ... S X5=$P(Z1,"^",4) ;Units
- ... S X6=$P(Z1,"^",5) ;Ref Ranges
- ... S X7=$$FLAG^LR7OU0($P(Z1,"^",3)) ;Flag
- ... S (GRP,END)=0
- ... I '$G(CORRECT),$P(Z1,"^",6)="F"!($P(Z,"^",6)) S GRP=1
- ... S X8=$S($G(CORRECT):"C",$P(Z1,"^",6)="F"!($P(Z,"^",6)):$S(GRP:"F",1:"I"),$L($P(Z1,"^",6)):$S($P(Z1,"^",6)'="F":$P(Z1,"^",6),1:"R"),1:"R")
- ... S $P(@MSG@(OBRMSG),"|",26)=X8 ;Result Status
- ... I @MSG@(OBRMSG)'?.E1"|",$O(@MSG@(OBRMSG,0))]"" S @MSG@(OBRMSG)=@MSG@(OBRMSG)_"|" ;RLM
- ... ;LR*5.2*512 commenting out line below
- ... ;because a single result status should not update
- ... ;the overall order status in the ORC segment
- ... ;LR*5.2*541: invoking line below only if:
- ... ; (1) not in full edit mode logic (as in LEDI or if user elects not to do full edit)
- ... ; (2) and if status of a test is preliminary. Any preliminary test should cause an
- ... ; order to remain at "active" status.
- ... I $D(LREDITTYPE),LREDITTYPE<3 S:X8="P" X8="I" D AX8
- ... I $L($P(Z1,"^",18)) S X=$P(@MSG@(ORCMSG),"|",4),Y=$P(X,"^",2),X=$P(X,"^")_$P(Z1,"^",18) S $P(@MSG@(ORCMSG),"|",4)=X_"^"_Y ;Append 63 ptr to placer ID
- ... I "SPCYEM"[$P($G(X),";",4)&($L($P(X,";",5))) S $P(@MSG@(ORCMSG),"|",4)=X_"^LRAP" ;;* added to correct result update to CPRS where the package reference was not being updated properly for AP results
- ... ; X=ORD#;LRODT;LRSN;LRSS;LRIDT, indirect set of ^TMP("LRAP",$J
- ... S X10=$P(Z1,"^",14) ;Theraputic flag
- ... S X11=$P(Z1,"^",12) ;Verified by
- ... S CTR=CTR+1,COBX=COBX+1 D OBX^LR7OU01(CTR)
- .. I $O(^TMP("LRX",$J,69,IFN,63,0)),$O(^("N",0)) S CTR=CTR+1 D NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",63,""N"",",CTR)
- . ;
- . ;Note to anyone researching this routine in the future:
- . ;The lines below are not called because of the quit after the loop at SNEAK+3
- . ;(not deleting them in case the lines are needed in the future.)
- . ;
- . S Z=$G(^TMP("LRX",$J,69,IFN))
- . S (Y9,Y10,Y11)="" I $P($G(^LAB(60,+Z,64)),"^") S Y9=$P(^(64),"^"),Y10=$P(^LAM(Y9,0),"^"),Y9=$P(^(0),"^",2),Y11="99NLT"
- . S X1=$$UVID^LR7OU0($P(Z,"^"),$P(^TMP("LRX",$J,69),"^",10),Y9,Y11,Y10,.MSG,$G(SS))
- . S X2="" ;Obs Start date
- . S X3=$$ACTCODE^LR7OU0($P(^TMP("LRX",$J,69),"^",4)) ;Specimen Action Code
- . S X4="" ;Specimen Received D/T
- . S X5=$$SAMP^LR7OU0($P(^TMP("LRX",$J,69),"^",3),$P(^TMP("LRX",$J,69),"^",10)) ;Specimen Source
- . S X6="" ;Filler Fld 1 (Accession)
- . S X7="" ;Results rpt/Sts change D/T
- . S X8="O"
- . I $G(CONTROL)="RE",$P(Z,"^",8) S X8=$S($G(CORRECT):"C",1:"F"),$P(@MSG@(ORCMSG),"|",6)="CM" ;Status
- . S X10=$P(^TMP("LRX",$J,69),"^",7),$P(@MSG@(3),"|",4)=X10 ;Routing Location
- . S X9="^^^^^"_$$URG^LR7OU0($P($G(^TMP("LRX",$J,69,IFN)),"^",2))
- . I $O(LINK(0)) S CTR=CTR+1 D NTE^LR7OU01(2,"L","LINK(",CTR) K LINK
- . I $O(^TMP("LRX",$J,69,IFN,"NC",0)) S CTR=CTR+1 D NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",""NC"",",CTR)
- . I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- . I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- . S CTR=CTR+1,COBR=COBR+1,OBRMSG=CTR D OBR^LR7OU01(CTR)
- . S CTR=CTR+1 D SDG1^LRBEBA2(IFN,.CTR,.MSG)
- . I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- . I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- OUT ;Exit here
- K ^TMP("LRX",$J)
- Q
- AX8 ;Modify order status based on result status
- ;LR*5.2*512 added three lines below for panels
- ;Routine LRVER3A sets ^TMP("LR",$J,"PANEL",order number)=status (final or active)
- I $G(LROR100)]"",$D(^TMP("LR",$J,"PANEL",LROR100)) D Q
- . Q:$P($P(@MSG@(ORCMSG),"|",3),"^")'=LROR100
- . S $P(@MSG@(ORCMSG),"|",6)=$S($G(^TMP("LR",$J,"PANEL",LROR100)):"CM",1:"SC")
- I X8="F"!(X8="C")!($G(LRSTATI)=2) S $P(@MSG@(ORCMSG),"|",6)="CM" Q ;Order Status
- I X8="I" S $P(@MSG@(ORCMSG),"|",6)="SC"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OB3 7423 printed Mar 13, 2025@21:09:07 Page 2
- LR7OB3 ;DALOI/DCM/JAH - Build message, backdoor from Lab order #;Sep 27, 2018@10:00:00
- +1 ;;5.2;LAB SERVICE;**121,187,272,291,462,512,541**;Sep 27, 1994;Build 7
- 69 KILL ^TMP("LRX",$JOB)
- +1 DO 69^LR7OB69(ODT,SN)
- if '$DATA(^TMP("LRX",$JOB,69))
- QUIT
- if '$DATA(DFN)
- GOTO OUT
- if LRFIRST
- DO FIRST^LR7OB0
- SET LRFIRST=0
- SNEAK ;
- +1 NEW Y,Y9,Y10,Y11,GRP,L1,L2,L3,END,LROR100
- +2 SET IFN=0
- FOR
- SET IFN=$ORDER(^TMP("LRX",$JOB,69,IFN))
- if IFN<1
- QUIT
- SET (COBR,COBX)=0
- Begin DoDot:1
- +3 IF $ORDER(^TMP("LRX",$JOB,69,IFN,68,0))
- SET Z=^TMP("LRX",$JOB,69,IFN,68)
- Begin DoDot:2
- +4 SET IFN1=0
- FOR
- SET IFN1=$ORDER(^TMP("LRX",$JOB,69,IFN,68,IFN1))
- if IFN1<1
- QUIT
- SET Z1=^TMP("LRX",$JOB,69,IFN,68,IFN1)
- Begin DoDot:3
- +5 SET (Y9,Y10,Y11)=""
- IF $PIECE($GET(^LAB(60,+Z1,64)),"^")
- SET Y9=$PIECE(^(64),"^")
- SET Y10=$PIECE(^LAM(Y9,0),"^")
- SET Y9=$PIECE(^(0),"^",2)
- SET Y11="99NLT"
- +6 SET X1=$$UVID^LR7OU0($PIECE(Z1,"^"),$PIECE(^TMP("LRX",$JOB,69),"^",10),Y9,Y11,Y10,.MSG,$GET(SS))
- +7 ;Obs Start date
- SET X2=$$HL7DT^LR7OU0($PIECE(Z,"^",4))
- +8 ;Specimen Act Code
- SET X3=$$ACTCODE^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",4))
- +9 ;Specimen Received D/T
- SET X4=$$HL7DT^LR7OU0($PIECE(Z,"^",5))
- +10 ;Specimen Source
- SET X5=$$SAMP^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",3),$PIECE(^TMP("LRX",$JOB,69),"^",10))
- +11 ;Filler Fld 1 (Accession)
- SET X6=$PIECE(Z,"^",3)
- +12 ;Results rpt/Sts Change D/T
- SET X7=$$HL7DT^LR7OU0($PIECE(Z,"^",6))
- +13 ;CPRS order number:
- +14 SET LROR100=$PIECE($GET(^TMP("LRX",$JOB,69,IFN)),"^",7)
- +15 ;
- +16 ;Check to see if the CPRS order number matches the ORC order number
- +17 IF $PIECE($PIECE(@MSG@(ORCMSG),"|",3),"^")'=LROR100
- Begin DoDot:4
- +18 NEW LRORC
- +19 SET LRORC=$PIECE(@MSG@(ORCMSG),"|",3)
- +20 SET $PIECE(LRORC,"^")=LROR100
- +21 SET $PIECE(@MSG@(ORCMSG),"|",3)=LRORC
- End DoDot:4
- +22 SET (GRP,END)=0
- +23 IF '$GET(CORRECT)
- IF $PIECE(Z,"^",6)
- SET GRP=1
- +24 ;LR*5.2*512 change on line below so that status of each panel and/or
- +25 ;atomic test is evaluated: added $P(Z1,"^",4):"F"
- +26 ;Variables:
- +27 ; Z = (1) Lab order number ^ (2) LRDFN ^ (3) accession ^ (4) draw time ^
- +28 ; (5) lab arrival time ^ (6) date/time results available (i.e. accession complete date)
- +29 ; (7) inverse date (i.e. file 63 subscript corresponding to this accession)
- +30 ;
- +31 ; Z1 = (1) test number ^ (2) test urgency ^ (3) technologist ^ (4) complete date/time ^
- +32 ;
- +33 ;Result Status
- SET X8=$SELECT($GET(CORRECT):"C",$PIECE(Z,"^",6):$SELECT(GRP:"F",1:"I"),$PIECE(Z1,"^",4):"F",$PIECE(Z,"^",5):"I",1:"O")
- +34 DO AX8
- +35 ;Routing Location
- SET X10=$PIECE(^TMP("LRX",$JOB,69),"^",7)
- SET $PIECE(@MSG@(3),"|",4)=X10
- +36 SET X9="^^^^^"_$$URG^LR7OU0($PIECE(^TMP("LRX",$JOB,69,IFN),"^",2))
- +37 IF $ORDER(LINK(0))
- SET CTR=CTR+1
- DO NTE^LR7OU01(2,"L","LINK(",CTR)
- KILL LINK
- +38 IF $ORDER(^TMP("LRX",$JOB,69,IFN,"NC",0))
- SET CTR=CTR+1
- DO NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",""NC"",",CTR)
- +39 IF CONTROL'="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- +40 IF CONTROL'="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- +41 SET CTR=CTR+1
- SET COBR=COBR+1
- SET OBRMSG=CTR
- DO OBR^LR7OU01(CTR)
- +42 SET CTR=CTR+1
- DO SDG1^LRBEBA2(IFN,.CTR,.MSG)
- +43 IF CONTROL="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- +44 IF CONTROL="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- End DoDot:3
- +45 SET IFN1=0
- FOR
- SET IFN1=$ORDER(^TMP("LRX",$JOB,69,IFN,63,IFN1))
- if IFN1<1
- QUIT
- SET Z1=^TMP("LRX",$JOB,69,IFN,63,IFN1)
- Begin DoDot:3
- +46 ;Value type
- SET X1=$SELECT($LENGTH($PIECE(Z1,"^",8)):$PIECE(Z1,"^",8),1:"ST")
- +47 SET X2=$$UVID^LR7OU0($PIECE(Z1,"^"),$PIECE(^TMP("LRX",$JOB,69),"^",10),$PIECE(Z1,"^",9),$PIECE(Z1,"^",11),$PIECE(Z1,"^",10),.MSG,$GET(SS))
- +48 ;Obs SubID
- SET X3=$PIECE(Z1,"^",7)
- +49 ;Value
- SET X4=$PIECE(Z1,"^",2)
- if $LENGTH($PIECE(Z1,"^",9))&(MSG["LRAP")
- SET X4=$PIECE(Z1,"^",9)_"^"_$PIECE(Z1,"^",2)_"^"_$PIECE(Z1,"^",10)
- +50 ;Units
- SET X5=$PIECE(Z1,"^",4)
- +51 ;Ref Ranges
- SET X6=$PIECE(Z1,"^",5)
- +52 ;Flag
- SET X7=$$FLAG^LR7OU0($PIECE(Z1,"^",3))
- +53 SET (GRP,END)=0
- +54 IF '$GET(CORRECT)
- IF $PIECE(Z1,"^",6)="F"!($PIECE(Z,"^",6))
- SET GRP=1
- +55 SET X8=$SELECT($GET(CORRECT):"C",$PIECE(Z1,"^",6)="F"!($PIECE(Z,"^",6)):$SELECT(GRP:"F",1:"I"),$LENGTH($PIECE(Z1,"^",6)):$SELECT($PIECE(Z1,"^",6)'="F":$PIECE(Z1,"^",6),1:"R"),1:"R")
- +56 ;Result Status
- SET $PIECE(@MSG@(OBRMSG),"|",26)=X8
- +57 ;RLM
- IF @MSG@(OBRMSG)'?.E1"|"
- IF $ORDER(@MSG@(OBRMSG,0))]""
- SET @MSG@(OBRMSG)=@MSG@(OBRMSG)_"|"
- +58 ;LR*5.2*512 commenting out line below
- +59 ;because a single result status should not update
- +60 ;the overall order status in the ORC segment
- +61 ;LR*5.2*541: invoking line below only if:
- +62 ; (1) not in full edit mode logic (as in LEDI or if user elects not to do full edit)
- +63 ; (2) and if status of a test is preliminary. Any preliminary test should cause an
- +64 ; order to remain at "active" status.
- +65 IF $DATA(LREDITTYPE)
- IF LREDITTYPE<3
- if X8="P"
- SET X8="I"
- DO AX8
- +66 ;Append 63 ptr to placer ID
- IF $LENGTH($PIECE(Z1,"^",18))
- SET X=$PIECE(@MSG@(ORCMSG),"|",4)
- SET Y=$PIECE(X,"^",2)
- SET X=$PIECE(X,"^")_$PIECE(Z1,"^",18)
- SET $PIECE(@MSG@(ORCMSG),"|",4)=X_"^"_Y
- +67 ;;* added to correct result update to CPRS where the package reference was not being updated properly for AP results
- IF "SPCYEM"[$PIECE($GET(X),";",4)&($LENGTH($PIECE(X,";",5)))
- SET $PIECE(@MSG@(ORCMSG),"|",4)=X_"^LRAP"
- +68 ; X=ORD#;LRODT;LRSN;LRSS;LRIDT, indirect set of ^TMP("LRAP",$J
- +69 ;Theraputic flag
- SET X10=$PIECE(Z1,"^",14)
- +70 ;Verified by
- SET X11=$PIECE(Z1,"^",12)
- +71 SET CTR=CTR+1
- SET COBX=COBX+1
- DO OBX^LR7OU01(CTR)
- End DoDot:3
- +72 IF $ORDER(^TMP("LRX",$JOB,69,IFN,63,0))
- IF $ORDER(^("N",0))
- SET CTR=CTR+1
- DO NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",63,""N"",",CTR)
- End DoDot:2
- QUIT
- +73 ;
- +74 ;Note to anyone researching this routine in the future:
- +75 ;The lines below are not called because of the quit after the loop at SNEAK+3
- +76 ;(not deleting them in case the lines are needed in the future.)
- +77 ;
- +78 SET Z=$GET(^TMP("LRX",$JOB,69,IFN))
- +79 SET (Y9,Y10,Y11)=""
- IF $PIECE($GET(^LAB(60,+Z,64)),"^")
- SET Y9=$PIECE(^(64),"^")
- SET Y10=$PIECE(^LAM(Y9,0),"^")
- SET Y9=$PIECE(^(0),"^",2)
- SET Y11="99NLT"
- +80 SET X1=$$UVID^LR7OU0($PIECE(Z,"^"),$PIECE(^TMP("LRX",$JOB,69),"^",10),Y9,Y11,Y10,.MSG,$GET(SS))
- +81 ;Obs Start date
- SET X2=""
- +82 ;Specimen Action Code
- SET X3=$$ACTCODE^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",4))
- +83 ;Specimen Received D/T
- SET X4=""
- +84 ;Specimen Source
- SET X5=$$SAMP^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",3),$PIECE(^TMP("LRX",$JOB,69),"^",10))
- +85 ;Filler Fld 1 (Accession)
- SET X6=""
- +86 ;Results rpt/Sts change D/T
- SET X7=""
- +87 SET X8="O"
- +88 ;Status
- IF $GET(CONTROL)="RE"
- IF $PIECE(Z,"^",8)
- SET X8=$SELECT($GET(CORRECT):"C",1:"F")
- SET $PIECE(@MSG@(ORCMSG),"|",6)="CM"
- +89 ;Routing Location
- SET X10=$PIECE(^TMP("LRX",$JOB,69),"^",7)
- SET $PIECE(@MSG@(3),"|",4)=X10
- +90 SET X9="^^^^^"_$$URG^LR7OU0($PIECE($GET(^TMP("LRX",$JOB,69,IFN)),"^",2))
- +91 IF $ORDER(LINK(0))
- SET CTR=CTR+1
- DO NTE^LR7OU01(2,"L","LINK(",CTR)
- KILL LINK
- +92 IF $ORDER(^TMP("LRX",$JOB,69,IFN,"NC",0))
- SET CTR=CTR+1
- DO NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",""NC"",",CTR)
- +93 IF CONTROL'="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- +94 IF CONTROL'="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- +95 SET CTR=CTR+1
- SET COBR=COBR+1
- SET OBRMSG=CTR
- DO OBR^LR7OU01(CTR)
- +96 SET CTR=CTR+1
- DO SDG1^LRBEBA2(IFN,.CTR,.MSG)
- +97 IF CONTROL="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR)
- +98 IF CONTROL="SN"
- SET CTR=CTR+1
- DO NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR)
- End DoDot:1
- OUT ;Exit here
- +1 KILL ^TMP("LRX",$JOB)
- +2 QUIT
- AX8 ;Modify order status based on result status
- +1 ;LR*5.2*512 added three lines below for panels
- +2 ;Routine LRVER3A sets ^TMP("LR",$J,"PANEL",order number)=status (final or active)
- +3 IF $GET(LROR100)]""
- IF $DATA(^TMP("LR",$JOB,"PANEL",LROR100))
- Begin DoDot:1
- +4 if $PIECE($PIECE(@MSG@(ORCMSG),"|",3),"^")'=LROR100
- QUIT
- +5 SET $PIECE(@MSG@(ORCMSG),"|",6)=$SELECT($GET(^TMP("LR",$JOB,"PANEL",LROR100)):"CM",1:"SC")
- End DoDot:1
- QUIT
- +6 ;Order Status
- IF X8="F"!(X8="C")!($GET(LRSTATI)=2)
- SET $PIECE(@MSG@(ORCMSG),"|",6)="CM"
- QUIT
- +7 IF X8="I"
- SET $PIECE(@MSG@(ORCMSG),"|",6)="SC"
- +8 QUIT
