- 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 Feb 18, 2025@23:30:58 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