LR7OB69 ;slc/dcm/JAH - Get Lab order data from 69 - 68 - 63 ;8/10/04
;;5.2;LAB SERVICE;**121,187,224,291,373**;Sep 27, 1994;Build 1
;
69(ODT,SN) ;Get data from file 69
;ODT=Order Date subscript in file 69
;SN=Specimen number subscript in file 69
;Y1=Lab order number
;Y2=Start date
;Y3=Sample
;Y4=Collection type/Specimen Action code
;Y5=Order date
;Y6=Provider
;Y7=Routing Location
;Y8=Lab arrival time
;Y9=Date/Time Results Available
;Y10=Specimen
;Y11=OERR Order #
;Y12=Entering person
;^TMP("LRX",$J,69)=Y1^Y2^Y3^Y4^Y5^Y6^Y7^Y8^Y9^Y10^Y11^Y12
;^TMP("LRX",$J,69,i)=Test^Urgency^Accession Date^Accession area^Accession #^Combined on order^ORIFN^Panel exploded
;^TMP("LRX",$J,69,"N",i)=Specimen level comments (6 node)
;^TMP("LRX",$J,69,i,"N",ifn)=Comments by test
;^TMP("LRX",$J,69,i,"NC",ifn)=Free text cancel reason
;^TMP("LRX",$J,69,i,"DGX",ifn)=diagnosis^SC^CV^AO^IR^EC^HNC^MST
;^TMP("LRX",$J,69,i,63,ifn)=
;Test subscript^Result^Flag^Units^Ref Range^Result status^Observation Sub ID^Value type^Natl Procedure code^Natl Procedure Name^Natl Coding System^Verified by^^Theraputic flag (T or "")^Print name^Accession^Order #^Link to 63
;^TMP("LRX",$J,69,i,63,"N",ifn)=Result Comments
;^TMP("LRX",$J,69,i,68)=Lab Order #^LRDFN^Accession^Draw Time^Lab Arrival time^DT Results Available^Inverse Date
;^TMP("LRX",$J,69,i,68,ifn)=Test^Urgency^Technologist^Complete Date
;^TMP("LRX",$J,69,"N",i)= Ward comments on specimen
N X,X0,XP1,X1,X4,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,IFN,TSTY,NOTE,GOTCOM K ^TMP("LRX",$J,69)
Q:'$D(^LRO(69,+ODT,1,+SN,0)) S X0=^(0),XP1=$G(^(.1)),X1=$G(^(1)),X3=$G(^(3)),X4=$O(^(4,0))
Q:'$D(^LR(+X0,0)) ;No matching entry in ^LR
S:'$D(DFN) DFN=$P(^LR(+X0,0),"^",3) S:'$D(LRDFN) LRDFN=+X0 S:'$D(LRDPF) LRDPF=$P(^LR(+X0,0),"^",2)_$G(^DIC(+$P(^LR(+X0,0),"^",2),0,"GL"))
S Y1=+XP1,Y2=$S($P(X1,"^"):$P(X1,"^"),1:$P(X0,"^",8)),Y3=$P(X0,"^",3),Y4=$P(X0,"^",4),Y5=$P(X0,"^",5),Y6=$P(X0,"^",6),Y7=$P(X0,"^",9),Y8=$P(X3,"^"),Y9=$P(X3,"^",2),Y11=$P(X0,"^",11),Y12=$P(X0,"^",2)
;canceled entries are skipped, so calls to this routine from options
;that are removing tests need to make the call before setting the pieces
;that cancel the test: $P(^LRO(69,ODT,1,SN,2,IFN,0),"^",11)
;See DOUT^LRTSTJAN
S IFN=0 F S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1 S X=$G(^(IFN,0)) I X,'$P(X,"^",11) D
. I $G(LRNIFN),$D(LRTMPO("LRIFN",LRNIFN)) Q:+X'=+LRTMPO("LRIFN",LRNIFN)
. S ^TMP("LRX",$J,69,IFN)=X,I=0
. D GDG1^LRBEBA2(ODT,SN,IFN)
. F S I=$O(^LRO(69,ODT,1,SN,2,IFN,1,I)) Q:I<1 S X=^(I,0) D
.. S ^TMP("LRX",$J,69,IFN,"N",I)=X
. S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,IFN,1.1,I)) Q:I<1 S X=^(I,0) D
.. S ^TMP("LRX",$J,69,IFN,"NC",I)=X
S IFN=0 F S IFN=$O(^LRO(69,ODT,1,SN,6,IFN)) Q:IFN<1 S X=^(IFN,0) D
. Q:X["removed ==>" Q:X["deleted by"
. S ^TMP("LRX",$J,69,"N",IFN)=X
S Y10=$O(^LRO(69,ODT,1,SN,4,0)),Y10=$S(Y10:$P(^(Y10,0),"^"),1:"")
S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
S IFN=0 F S IFN=$O(^TMP("LRX",$J,69,IFN)) Q:IFN<1 S X=^TMP("LRX",$J,69,IFN) S X1=$P(X,"^",3),X2=$P(X,"^",4),X3=$P(X,"^",5) K TSTY D EN^LR7OU1(+X,$P(^LAB(60,+X,0),"^",5)) D 68^LR7OB68(IFN,X1,X2,X3,+X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OB69 3255 printed Dec 13, 2024@02:04:54 Page 2
LR7OB69 ;slc/dcm/JAH - Get Lab order data from 69 - 68 - 63 ;8/10/04
+1 ;;5.2;LAB SERVICE;**121,187,224,291,373**;Sep 27, 1994;Build 1
+2 ;
69(ODT,SN) ;Get data from file 69
+1 ;ODT=Order Date subscript in file 69
+2 ;SN=Specimen number subscript in file 69
+3 ;Y1=Lab order number
+4 ;Y2=Start date
+5 ;Y3=Sample
+6 ;Y4=Collection type/Specimen Action code
+7 ;Y5=Order date
+8 ;Y6=Provider
+9 ;Y7=Routing Location
+10 ;Y8=Lab arrival time
+11 ;Y9=Date/Time Results Available
+12 ;Y10=Specimen
+13 ;Y11=OERR Order #
+14 ;Y12=Entering person
+15 ;^TMP("LRX",$J,69)=Y1^Y2^Y3^Y4^Y5^Y6^Y7^Y8^Y9^Y10^Y11^Y12
+16 ;^TMP("LRX",$J,69,i)=Test^Urgency^Accession Date^Accession area^Accession #^Combined on order^ORIFN^Panel exploded
+17 ;^TMP("LRX",$J,69,"N",i)=Specimen level comments (6 node)
+18 ;^TMP("LRX",$J,69,i,"N",ifn)=Comments by test
+19 ;^TMP("LRX",$J,69,i,"NC",ifn)=Free text cancel reason
+20 ;^TMP("LRX",$J,69,i,"DGX",ifn)=diagnosis^SC^CV^AO^IR^EC^HNC^MST
+21 ;^TMP("LRX",$J,69,i,63,ifn)=
+22 ;Test subscript^Result^Flag^Units^Ref Range^Result status^Observation Sub ID^Value type^Natl Procedure code^Natl Procedure Name^Natl Coding System^Verified by^^Theraputic flag (T or "")^Print name^Accession^Order #^Link to 63
+23 ;^TMP("LRX",$J,69,i,63,"N",ifn)=Result Comments
+24 ;^TMP("LRX",$J,69,i,68)=Lab Order #^LRDFN^Accession^Draw Time^Lab Arrival time^DT Results Available^Inverse Date
+25 ;^TMP("LRX",$J,69,i,68,ifn)=Test^Urgency^Technologist^Complete Date
+26 ;^TMP("LRX",$J,69,"N",i)= Ward comments on specimen
+27 NEW X,X0,XP1,X1,X4,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,IFN,TSTY,NOTE,GOTCOM
KILL ^TMP("LRX",$JOB,69)
+28 if '$DATA(^LRO(69,+ODT,1,+SN,0))
QUIT
SET X0=^(0)
SET XP1=$GET(^(.1))
SET X1=$GET(^(1))
SET X3=$GET(^(3))
SET X4=$ORDER(^(4,0))
+29 ;No matching entry in ^LR
if '$DATA(^LR(+X0,0))
QUIT
+30 if '$DATA(DFN)
SET DFN=$PIECE(^LR(+X0,0),"^",3)
if '$DATA(LRDFN)
SET LRDFN=+X0
if '$DATA(LRDPF)
SET LRDPF=$PIECE(^LR(+X0,0),"^",2)_$GET(^DIC(+$PIECE(^LR(+X0,0),"^",2),0,"GL"))
+31 SET Y1=+XP1
SET Y2=$SELECT($PIECE(X1,"^"):$PIECE(X1,"^"),1:$PIECE(X0,"^",8))
SET Y3=$PIECE(X0,"^",3)
SET Y4=$PIECE(X0,"^",4)
SET Y5=$PIECE(X0,"^",5)
SET Y6=$PIECE(X0,"^",6)
SET Y7=$PIECE(X0,"^",9)
SET Y8=$PIECE(X3,"^")
SET Y9=$PIECE(X3,"^",2)
SET Y11=$PIECE(X0,"^",11)
SET Y12=$PIECE(X0,"^",2)
+32 ;canceled entries are skipped, so calls to this routine from options
+33 ;that are removing tests need to make the call before setting the pieces
+34 ;that cancel the test: $P(^LRO(69,ODT,1,SN,2,IFN,0),"^",11)
+35 ;See DOUT^LRTSTJAN
+36 SET IFN=0
FOR
SET IFN=$ORDER(^LRO(69,ODT,1,SN,2,IFN))
if IFN<1
QUIT
SET X=$GET(^(IFN,0))
IF X
IF '$PIECE(X,"^",11)
Begin DoDot:1
+37 IF $GET(LRNIFN)
IF $DATA(LRTMPO("LRIFN",LRNIFN))
if +X'=+LRTMPO("LRIFN",LRNIFN)
QUIT
+38 SET ^TMP("LRX",$JOB,69,IFN)=X
SET I=0
+39 DO GDG1^LRBEBA2(ODT,SN,IFN)
+40 FOR
SET I=$ORDER(^LRO(69,ODT,1,SN,2,IFN,1,I))
if I<1
QUIT
SET X=^(I,0)
Begin DoDot:2
+41 SET ^TMP("LRX",$JOB,69,IFN,"N",I)=X
End DoDot:2
+42 SET I=0
FOR
SET I=$ORDER(^LRO(69,ODT,1,SN,2,IFN,1.1,I))
if I<1
QUIT
SET X=^(I,0)
Begin DoDot:2
+43 SET ^TMP("LRX",$JOB,69,IFN,"NC",I)=X
End DoDot:2
End DoDot:1
+44 SET IFN=0
FOR
SET IFN=$ORDER(^LRO(69,ODT,1,SN,6,IFN))
if IFN<1
QUIT
SET X=^(IFN,0)
Begin DoDot:1
+45 if X["removed ==>"
QUIT
if X["deleted by"
QUIT
+46 SET ^TMP("LRX",$JOB,69,"N",IFN)=X
End DoDot:1
+47 SET Y10=$ORDER(^LRO(69,ODT,1,SN,4,0))
SET Y10=$SELECT(Y10:$PIECE(^(Y10,0),"^"),1:"")
+48 SET ^TMP("LRX",$JOB,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
+49 SET IFN=0
FOR
SET IFN=$ORDER(^TMP("LRX",$JOB,69,IFN))
if IFN<1
QUIT
SET X=^TMP("LRX",$JOB,69,IFN)
SET X1=$PIECE(X,"^",3)
SET X2=$PIECE(X,"^",4)
SET X3=$PIECE(X,"^",5)
KILL TSTY
DO EN^LR7OU1(+X,$PIECE(^LAB(60,+X,0),"^",5))
DO 68^LR7OB68(IFN,X1,X2,X3,+X)
+50 QUIT
