LRTSTSET ;DALOI/STAFF - JAM TESTS ONTO (OR OFF) ACCESSIONS ; 19 Jun 2017 12:20 PM
;;5.2;LAB SERVICE;**65,100,121,153,201,202,263,291,350,492**;Sep 27, 1994;Build 3
;
;Formerly apart of LRTSTJAM
;
EN ;
; Called from LRTSTJAM, LRPHSET2
I '($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2) D Q
. W !?10,"Sorry This accession "_LRAN_" No longer exist"
. W !?10," Accession may have been deleted.",!,$C(7)
;
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=+LRTS
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTS,LRTS)="",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)=""
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=LRTS,$P(^(0),U,4)=$P(^(0),U,4)+1
;
I $P(LRPARAM,U,14),$P(^LRO(68,LRAA,0),U,16) D CAP^LRWLST12
;
S LRACD=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3),LRTSAD(1,LRTS)=""
I LRACD,LRACD'=LRAD D
. S ^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=+LRTS
. S ^LRO(68,LRAA,1,LRACD,1,LRAN,4,"B",LRTS,LRTS)="",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",4)=""
. I $P(LRPARAM,U,14),$P(^LRO(68,LRAA,0),U,16) D CAP^LRWLST12
;
;In certain cases, the order number in file 68 may need to be updated.
;MFLG = set by LRPHSET2 for those cases
;
I $G(MFLG) D
. I LRODT=""!(LRSN="") Q
. S ^LRO(68,LRAA,1,LRAD,1,LRAN,.1)=$G(^LRO(69,LRODT,1,LRSN,.1))
;
D ORUT^LRTSTJM1(LRDFN,LRAA,LRAD,LRAN,LRTS,LRORDTYP,LRURG,LRODT,LRSN)
;
S LRADL=1
;
F L +^LRO(69,LRODT,1,LRSN):DILOCKTM Q:$T W !?7,"Someone else is editing this order",!,$C(7) H 20
;
; Add stub entry for new test.
K DA,DIC,DIE,DINUM,DO,DR
;
;The stub may already exist.
;
I $D(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS)) S Y=$O(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,0))_"^"_+LRTS_"^1"
;
I '$D(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS)) D
. S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DA(2)=LRODT,DA(1)=LRSN
. S DIC(0)="F",X=+LRTS
. D FILE^DICN
;
69 ; Called by LR7OMERG
I Y>0 D
. N LRDIE,LRFDA,LRIENS,I
. S LRXDA=+Y,LRIENS=LRXDA_","_LRSN_","_LRODT_","
. S LRXDA(3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
. S LRFDA(1,69.03,LRIENS,1)=LRURG
. S LRFDA(1,69.03,LRIENS,2)=LRAODT
. S LRFDA(1,69.03,LRIENS,3)=LRAA
. S LRFDA(1,69.03,LRIENS,4)=LRAN
. S LRFDA(1,69.03,LRIENS,8)="IP"
. S LRFDA(1,69.03,LRIENS,9)="L"
. I $P(LRXDA(3),"^")'="" D
. . S LRFDA(1,69.03,LRIENS,13)=$P(LRXDA(3),"^")
. . I $P(LRXDA(3),"^",2) F I=2:1:5 S LRFDA(1,69.03,LRIENS,I+12)=$P(LRXDA(3),"^",I)
. D FILE^DIE("","LRFDA(1)","LRDIE(1)")
. D:$G(LRTSP)
. . S LRBETN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRTSP,""))
. . I LRBETN D DADD^LRBEBA31(LRODT,LRSN,LRBETN,LRXDA,LRTS,$G(LRBERF))
. K LRBETN,LRBERF
;
I $G(LRXDA),'$G(MFLG) D
. ;MFLG = comments are added in LRPHSET2 instead
. N X
. S X=1+$S($D(^LRO(69,LRODT,1,LRSN,2,LRXDA,1,0)):$P(^(0),"^",3),1:0),^(0)="^^"_X_"^"_DT,^(X,0)=" Added by "_$G(DUZ)_" on "_$$HTE^XLFDT($H,"M")
. S ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
;
I '$D(LRFLG) K DLAYGO,DA,DIC,DIE,DR,LRXDA L -^LRO(69,LRODT,1,LRSN) Q
;
SETOR ;
N LTS S LTS(LRTS)=""
D NEW^LR7OB1(LRODT,LRSN,"SN",$G(LRNATURE),.LTS,6)
K DLAYGO,DA,DIC,DIE,DR,LRBERF,LRBEFN,LRBEX
L -^LRO(69,LRODT,1,LRSN)
;
B Q:$D(LRPHSET)
W !?5,$P(^LAB(60,LRTS,0),U,1)," ADDED" ;K DIC("B") Q:$D(LRTSAD(2)) G ADDTST^LRTSTJAM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRTSTSET 3243 printed Dec 13, 2024@02:21:10 Page 2
LRTSTSET ;DALOI/STAFF - JAM TESTS ONTO (OR OFF) ACCESSIONS ; 19 Jun 2017 12:20 PM
+1 ;;5.2;LAB SERVICE;**65,100,121,153,201,202,263,291,350,492**;Sep 27, 1994;Build 3
+2 ;
+3 ;Formerly apart of LRTSTJAM
+4 ;
EN ;
+1 ; Called from LRTSTJAM, LRPHSET2
+2 IF '($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2)
Begin DoDot:1
+3 WRITE !?10,"Sorry This accession "_LRAN_" No longer exist"
+4 WRITE !?10," Accession may have been deleted.",!,$CHAR(7)
End DoDot:1
QUIT
+5 ;
+6 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG
SET $PIECE(^(0),U,9)=+LRTS
+7 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTS,LRTS)=""
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)=""
+8 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=LRTS
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
+9 ;
+10 IF $PIECE(LRPARAM,U,14)
IF $PIECE(^LRO(68,LRAA,0),U,16)
DO CAP^LRWLST12
+11 ;
+12 SET LRACD=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3)
SET LRTSAD(1,LRTS)=""
+13 IF LRACD
IF LRACD'=LRAD
Begin DoDot:1
+14 SET ^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG
SET $PIECE(^(0),U,9)=+LRTS
+15 SET ^LRO(68,LRAA,1,LRACD,1,LRAN,4,"B",LRTS,LRTS)=""
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",4)=""
+16 IF $PIECE(LRPARAM,U,14)
IF $PIECE(^LRO(68,LRAA,0),U,16)
DO CAP^LRWLST12
End DoDot:1
+17 ;
+18 ;In certain cases, the order number in file 68 may need to be updated.
+19 ;MFLG = set by LRPHSET2 for those cases
+20 ;
+21 IF $GET(MFLG)
Begin DoDot:1
+22 IF LRODT=""!(LRSN="")
QUIT
+23 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,.1)=$GET(^LRO(69,LRODT,1,LRSN,.1))
End DoDot:1
+24 ;
+25 DO ORUT^LRTSTJM1(LRDFN,LRAA,LRAD,LRAN,LRTS,LRORDTYP,LRURG,LRODT,LRSN)
+26 ;
+27 SET LRADL=1
+28 ;
+29 FOR
LOCK +^LRO(69,LRODT,1,LRSN):DILOCKTM
if $TEST
QUIT
WRITE !?7,"Someone else is editing this order",!,$CHAR(7)
HANG 20
+30 ;
+31 ; Add stub entry for new test.
+32 KILL DA,DIC,DIE,DINUM,DO,DR
+33 ;
+34 ;The stub may already exist.
+35 ;
+36 IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS))
SET Y=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,0))_"^"_+LRTS_"^1"
+37 ;
+38 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS))
Begin DoDot:1
+39 SET DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET DA(2)=LRODT
SET DA(1)=LRSN
+40 SET DIC(0)="F"
SET X=+LRTS
+41 DO FILE^DICN
End DoDot:1
+42 ;
69 ; Called by LR7OMERG
+1 IF Y>0
Begin DoDot:1
+2 NEW LRDIE,LRFDA,LRIENS,I
+3 SET LRXDA=+Y
SET LRIENS=LRXDA_","_LRSN_","_LRODT_","
+4 SET LRXDA(3)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+5 SET LRFDA(1,69.03,LRIENS,1)=LRURG
+6 SET LRFDA(1,69.03,LRIENS,2)=LRAODT
+7 SET LRFDA(1,69.03,LRIENS,3)=LRAA
+8 SET LRFDA(1,69.03,LRIENS,4)=LRAN
+9 SET LRFDA(1,69.03,LRIENS,8)="IP"
+10 SET LRFDA(1,69.03,LRIENS,9)="L"
+11 IF $PIECE(LRXDA(3),"^")'=""
Begin DoDot:2
+12 SET LRFDA(1,69.03,LRIENS,13)=$PIECE(LRXDA(3),"^")
+13 IF $PIECE(LRXDA(3),"^",2)
FOR I=2:1:5
SET LRFDA(1,69.03,LRIENS,I+12)=$PIECE(LRXDA(3),"^",I)
End DoDot:2
+14 DO FILE^DIE("","LRFDA(1)","LRDIE(1)")
+15 if $GET(LRTSP)
Begin DoDot:2
+16 SET LRBETN=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRTSP,""))
+17 IF LRBETN
DO DADD^LRBEBA31(LRODT,LRSN,LRBETN,LRXDA,LRTS,$GET(LRBERF))
End DoDot:2
+18 KILL LRBETN,LRBERF
End DoDot:1
+19 ;
+20 IF $GET(LRXDA)
IF '$GET(MFLG)
Begin DoDot:1
+21 ;MFLG = comments are added in LRPHSET2 instead
+22 NEW X
+23 SET X=1+$SELECT($DATA(^LRO(69,LRODT,1,LRSN,2,LRXDA,1,0)):$PIECE(^(0),"^",3),1:0)
SET ^(0)="^^"_X_"^"_DT
SET ^(X,0)=" Added by "_$GET(DUZ)_" on "_$$HTE^XLFDT($HOROLOG,"M")
+24 SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
End DoDot:1
+25 ;
+26 IF '$DATA(LRFLG)
KILL DLAYGO,DA,DIC,DIE,DR,LRXDA
LOCK -^LRO(69,LRODT,1,LRSN)
QUIT
+27 ;
SETOR ;
+1 NEW LTS
SET LTS(LRTS)=""
+2 DO NEW^LR7OB1(LRODT,LRSN,"SN",$GET(LRNATURE),.LTS,6)
+3 KILL DLAYGO,DA,DIC,DIE,DR,LRBERF,LRBEFN,LRBEX
+4 LOCK -^LRO(69,LRODT,1,LRSN)
+5 ;
B if $DATA(LRPHSET)
QUIT
+1 ;K DIC("B") Q:$D(LRTSAD(2)) G ADDTST^LRTSTJAM
WRITE !?5,$PIECE(^LAB(60,LRTS,0),U,1)," ADDED"
+2 QUIT
