LR7OFAA ;slc/dcm - Setup Accession for AP orders ;8/11/97
;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
;
EN D DT K ZTSK S LRORDR=LRXZ
F LRSAMP=-1:0 S LRSAMP=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP)) Q:LRSAMP="" S ORIFN=^(LRSAMP,0) D ZX
K ZTSK Q
ZX ;
S J=0 F LRJ=1:1 S J=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,J)) Q:J<1 D
. S LRTSTS=+^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRASMP,J),LRORIFN=^(J,0) D
.. Q:'$D(DUZ(2)) Q:'$D(^LAB(60,+LRTSTS,8,+DUZ(2),0)) S LRAA=$P(^(0),"^",2)
.. I 'LRAA D ACK^LR7OF0("DE","","Missing accession area for lab test: "_LRTSTS) Q
.. S LRAD=$E(LRSDT,1,3)_"0000",LRH(2)=$E(LRSDT,1,3)
.. S:'$D(^LRO(68,LRAA,1,0)) ^(0)="^68.01DA^^0"
.. S:'$D(^LRO(68,LRAA,1,LRAD,0)) ^(0)=LRAD,^LRO(68,LRAA,1,0)=$P(^LRO(68,LRAA,1,0),"^",1,2)_"^"_LRAD_"^"_($P(^(0),"^",4)+1)
.. S:'$D(^LRO(68,LRAA,1,LRAD,1,0)) ^(0)="^68.02PA^^"
.. F L +^LRO(68,LRAA,1,LRAD):360 Q:$T
.. S LRAN=$P(^LRO(68,LRAA,1,LRAD,1,0),"^",3) F X=0:0 S LRAN=LRAN+1 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
.. I $D(^LR(LRXREF,LRH(2),LRAN)) F X=0:0 S LRAN=LRAN+1 Q:'$D(^LR(LRXREF,LRH(2),LRAN))
.. S X=^LRO(68,LRAA,1,LRAD,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1),^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN
.. L -^LRO(68,LRAA,1,LRAD)
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[HLR7OFAA 1331 printed Dec 13, 2024@02:05:04 Page 2
LR7OFAA ;slc/dcm - Setup Accession for AP orders ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
+2 ;
EN DO DT
KILL ZTSK
SET LRORDR=LRXZ
+1 FOR LRSAMP=-1:0
SET LRSAMP=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP))
if LRSAMP=""
QUIT
SET ORIFN=^(LRSAMP,0)
DO ZX
+2 KILL ZTSK
QUIT
ZX ;
+1 SET J=0
FOR LRJ=1:1
SET J=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,J))
if J<1
QUIT
Begin DoDot:1
+2 SET LRTSTS=+^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRASMP,J)
SET LRORIFN=^(J,0)
Begin DoDot:2
+3 if '$DATA(DUZ(2))
QUIT
if '$DATA(^LAB(60,+LRTSTS,8,+DUZ(2),0))
QUIT
SET LRAA=$PIECE(^(0),"^",2)
+4 IF 'LRAA
DO ACK^LR7OF0("DE","","Missing accession area for lab test: "_LRTSTS)
QUIT
+5 SET LRAD=$EXTRACT(LRSDT,1,3)_"0000"
SET LRH(2)=$EXTRACT(LRSDT,1,3)
+6 if '$DATA(^LRO(68,LRAA,1,0))
SET ^(0)="^68.01DA^^0"
+7 if '$DATA(^LRO(68,LRAA,1,LRAD,0))
SET ^(0)=LRAD
SET ^LRO(68,LRAA,1,0)=$PIECE(^LRO(68,LRAA,1,0),"^",1,2)_"^"_LRAD_"^"_($PIECE(^(0),"^",4)+1)
+8 if '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
SET ^(0)="^68.02PA^^"
+9 FOR
LOCK +^LRO(68,LRAA,1,LRAD):360
if $TEST
QUIT
+10 SET LRAN=$PIECE(^LRO(68,LRAA,1,LRAD,1,0),"^",3)
FOR X=0:0
SET LRAN=LRAN+1
if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+11 IF $DATA(^LR(LRXREF,LRH(2),LRAN))
FOR X=0:0
SET LRAN=LRAN+1
if '$DATA(^LR(LRXREF,LRH(2),LRAN))
QUIT
+12 SET X=^LRO(68,LRAA,1,LRAD,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN
+13 LOCK -^LRO(68,LRAA,1,LRAD)
End DoDot:2
End DoDot:1
+14 QUIT
DT SET DT=$$DT^XLFDT()
+1 SET LRNT=$PIECE($HOROLOG,",",2)
SET LRNT=LRNT\3600*100+(LRNT\60#60)/10000+DT
+2 QUIT
