LRTSTSET ;SLC/CJS/JAH - JAM TESTS ONTO (OR OFF) ACCESSIONS ; 04-Feb-2014 15:40 ; MKK
;;5.2;LAB SERVICE;**65,100,121,153,201,202,263,1018,291,1031,1033**;NOV 1, 1997
;
;Formerly apart of LRTSTJAM
EN ;
I '($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2) W !?10,"Sorry This accession "_LRAN_" No longer exist",!?10," Accession may have been deleted.",!,$C(7) G ADDTST^LRTSTJAM
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=$G(LRTSP),^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)=""
D EN^LA7ADL($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),0),"^")) ;Check for automatic downloading
I LRACD,LRACD'=LRAD S ^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=+LRTS D
.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
F L +^LRO(69,LRODT,1,LRSN):1 Q:$T W !?7,"Someone else is editing this order",!,$C(7) H 20
K LRXDA,DA,DIC,DIE,DR
S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DA(2)=LRODT,DA(1)=LRSN
S DIC(0)="LOX",DLAYGO=69,X=$P(^LAB(60,LRTS,0),"^") D ^DIC
;
D:Y<1 TRYAGAIN ; IHS/MSC/MKK - LR*5.2*1033
;
69 I Y>0 D
. S LRXDA(3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
. S (LRXDA,DA)=+Y,DIE=DIC,DR="1///^S X=LRURG;2///^S X=LRAODT;3///^S X=LRAA;4///^S X=LRAN;8///^S X=""IP"";9///^S X=""L"""
. I $L($P(LRXDA(3),U)) D
. . S DR=DR_";13///^S X=$P(LRXDA(3),U)"
. . S:$P(LRXDA(3),U,2) DR=DR_";14////^S X=$P(LRXDA(3),U,2);15////^S X=$P(LRXDA(3),U,3);16///^S X=$P(LRXDA(3),U,4);17///^S X=$P(LRXDA(3),U,5)"
. D ^DIE
. 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) D
. N X,Y
. S Y=$P($$FMTE^XLFDT($$NOW^XLFDT,"5Z"),":",1,2)
. 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 "_Y
. S ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
. ;
. D ADDTST^BLRDIAG(LRODT,LRSN,LRTS) ; IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
. ;
I '$D(LRFLG) K DLAYGO,DA,DIC,DIE,DR,LRXDA L -^LRO(69,LRODT,1,LRSN) Q
;
SETOR ; EP
I $G(LRXDA),$$VER^LR7OU1<3 D ;OE/RR 2.5
. I '$D(ORNATR) S ORNATR=$S($D(LRNATURE):LRNATURE,1:"") I '$D(LRNATURE) D:$P($G(^ORD(100.99,1,2)),"^",2) OT^LROR6 S LRNATURE=ORNATR
. S X=^LRO(69,LRODT,1,LRSN,0),LRLB=$P(^(.1),"^"),X1=$S($D(^(1)):^(1),1:$P(X,"^",8)),ORVP=$P(^LR(+X,0),"^",3)_";"_$P(^DIC($P(^LR(+X,0),"^",2),0,"GL"),"^",2)
. I ORNATR="C" S OREPDUZ=$P(X,"^",2),ORLOG=$P(X,"^",5),ORNATR=""
. S LRORSAMP=$P(X,"^",3),LRORTYPE=$P(X,"^",4),ORNP=$P(X,"^",6),ORL=$S($L($P(X,"^",7)):$P(X,"^",7),1:"UNKNOWN")
. S ORL=$S($O(^SC("C",ORL,0))'="":$O(^(0))_";SC(",1:""),ORSTRT=$P(X1,"^"),X=^LRO(69,LRODT,1,LRSN,2,LRXDA,0),ORIT=+X_";LAB(60,",LRORSPEC=$O(^LRO(69,LRODT,1,LRSN,4,0)),LRORSPEC=$S(LRORSPEC>0:$P(^(LRORSPEC,0),"^"),1:"")
. S X=$S($D(LRORSAMP):$S($D(^LAB(62,+LRORSAMP,0)):$P(^(0),"^"),1:""),1:""),Y=$S($D(LRORSPEC):$S($D(^LAB(61,+LRORSPEC,0)):$P(^(0),"^"),1:""),1:"")
. S ORTX(1)=$P(^LAB(60,+LRTS,0),"^")_$S(Y'[X!(X=Y):" "_X,1:"")_$S(X'[Y:" "_Y,1:"")
. S ORTX(1)=ORTX(1)_" LB #"_LRLB_" "_$S($D(LRORTYPE):LRORTYPE,1:"")_$S(LRURG=9!('LRURG):"",1:" "_$P(^LAB(62.05,LRURG,0),"^"))
. S ORPCL=$P(^LAB(69.9,1,1),"^",6),ORSTS=6,ORTO=$P(^LAB(60,+ORIT,0),"^",6) S:$P(^LAB(69.9,1,0),"^",9) ORPURG=$P(^(0),"^",9)
. S ORPCL=$P(^LAB(69.9,1,1),"^",6)_";ORD(101,",ORPK=LRODT_"^"_LRSN_"^"_DA,DA=LRXDA
. D FILE^ORX
. S:$D(ORIFN) $P(^LRO(69,LRODT,1,LRSN,2,LRXDA,0),"^",7)=ORIFN
. K LRLB,LRXDA,LRFLG,LRORSPEC,LRORSAMP,LRORTYPE
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
;
;----- BEGIN IHS MODIFICATION LR*5.2*1018
Q:$D(LRPHSET)
S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="ADDACC",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 3/4/97
I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5),LRSS=$P($G(^LRO(68,LRAA,0)),U,2) D ^BLRALAF ;IHS/ITSC/TPF 12/04/01 ADDITIONAL CHANGE FOR E-SIG
;
W !?5,$P(^LAB(60,LRTS,0),U,1)," ADDED" D:BLRLOG ^BLREVTQ("C","A",BLROPT,,LRODT_","_LRSN_","_LRAA_","_LRAD_","_LRAN) K DIC("B") Q:$D(LRTSAD(2)) G ADDTST^LRTSTJAM ;IHS/OIRM TUC/AAB 11/14/96
;----- END IHS MODIFICATION LR*5.2*1018
Q
;
; ----- IHS/MSC/MKK - LR*5.2*1033
; If D ^DIC fails with Y=-1, try using UDPATE^DIE call
TRYAGAIN ; EP
NEW ERRS,FDA,IENS,IENARRAY
S IENS="?+1,"_LRSN_","_LRODT_","
S FDA(69.03,IENS,.01)=LRTS
D UPDATE^DIE("EKS","FDA","IENARRAY","ERRS")
I $D(ERRS) S Y=-1 Q
;
S Y=$G(IENARRAY(1))_"^"_LRTS_"^1"
;
Q
;
S NOW=$H
S ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS)=""
M ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"FDA")=FDA
M ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"IENARRAY")=IENARRAY
S ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"Y")=Y
S ^XTMP("LRTSTSET",0)=$$HTFM^XLFDT(+$H+365)_"^"_$$DT^XLFDT_"^LRTSTSET TRYAGAIN Call"
;
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
LRTSTSET ;SLC/CJS/JAH - JAM TESTS ONTO (OR OFF) ACCESSIONS ; 04-Feb-2014 15:40 ; MKK
+1 ;;5.2;LAB SERVICE;**65,100,121,153,201,202,263,1018,291,1031,1033**;NOV 1, 1997
+2 ;
+3 ;Formerly apart of LRTSTJAM
EN ;
+1 IF '($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2)
WRITE !?10,"Sorry This accession "_LRAN_" No longer exist",!?10," Accession may have been deleted.",!,$CHAR(7)
GOTO ADDTST^LRTSTJAM
+2 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG
SET $PIECE(^(0),U,9)=$GET(LRTSP)
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTS,LRTS)=""
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)=""
+3 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=LRTS
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
IF $PIECE(LRPARAM,U,14)
IF $PIECE(^LRO(68,LRAA,0),U,16)
DO CAP^LRWLST12
+4 SET LRACD=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3)
SET LRTSAD(1,LRTS)=""
+5 ;Check for automatic downloading
DO EN^LA7ADL($PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),0),"^"))
+6 IF LRACD
IF LRACD'=LRAD
SET ^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG
SET $PIECE(^(0),U,9)=+LRTS
Begin DoDot:1
+7 SET ^LRO(68,LRAA,1,LRACD,1,LRAN,4,"B",LRTS,LRTS)=""
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",4)=""
IF $PIECE(LRPARAM,U,14)
IF $PIECE(^LRO(68,LRAA,0),U,16)
DO CAP^LRWLST12
End DoDot:1
+8 FOR
LOCK +^LRO(69,LRODT,1,LRSN):1
IF $TEST
QUIT
WRITE !?7,"Someone else is editing this order",!,$CHAR(7)
HANG 20
+9 KILL LRXDA,DA,DIC,DIE,DR
+10 SET DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET DA(2)=LRODT
SET DA(1)=LRSN
+11 SET DIC(0)="LOX"
SET DLAYGO=69
SET X=$PIECE(^LAB(60,LRTS,0),"^")
DO ^DIC
+12 ;
+13 ; IHS/MSC/MKK - LR*5.2*1033
IF Y<1
DO TRYAGAIN
+14 ;
69 IF Y>0
Begin DoDot:1
+1 SET LRXDA(3)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+2 SET (LRXDA,DA)=+Y
SET DIE=DIC
SET DR="1///^S X=LRURG;2///^S X=LRAODT;3///^S X=LRAA;4///^S X=LRAN;8///^S X=""IP"";9///^S X=""L"""
+3 IF $LENGTH($PIECE(LRXDA(3),U))
Begin DoDot:2
+4 SET DR=DR_";13///^S X=$P(LRXDA(3),U)"
+5 IF $PIECE(LRXDA(3),U,2)
SET DR=DR_";14////^S X=$P(LRXDA(3),U,2);15////^S X=$P(LRXDA(3),U,3);16///^S X=$P(LRXDA(3),U,4);17///^S X=$P(LRXDA(3),U,5)"
End DoDot:2
+6 DO ^DIE
+7 IF $GET(LRTSP)
Begin DoDot:2
+8 SET LRBETN=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRTSP,""))
+9 IF LRBETN
DO DADD^LRBEBA31(LRODT,LRSN,LRBETN,LRXDA,LRTS,$GET(LRBERF))
End DoDot:2
+10 KILL LRBETN,LRBERF
End DoDot:1
+11 IF $GET(LRXDA)
Begin DoDot:1
+12 NEW X,Y
+13 SET Y=$PIECE($$FMTE^XLFDT($$NOW^XLFDT,"5Z"),":",1,2)
+14 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 "_Y
+15 SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
+16 ;
+17 ; IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
DO ADDTST^BLRDIAG(LRODT,LRSN,LRTS)
+18 ;
End DoDot:1
+19 IF '$DATA(LRFLG)
KILL DLAYGO,DA,DIC,DIE,DR,LRXDA
LOCK -^LRO(69,LRODT,1,LRSN)
QUIT
+20 ;
SETOR ; EP
+1 ;OE/RR 2.5
IF $GET(LRXDA)
IF $$VER^LR7OU1<3
Begin DoDot:1
+2 IF '$DATA(ORNATR)
SET ORNATR=$SELECT($DATA(LRNATURE):LRNATURE,1:"")
IF '$DATA(LRNATURE)
IF $PIECE($GET(^ORD(100.99,1,2)),"^",2)
DO OT^LROR6
SET LRNATURE=ORNATR
+3 SET X=^LRO(69,LRODT,1,LRSN,0)
SET LRLB=$PIECE(^(.1),"^")
SET X1=$SELECT($DATA(^(1)):^(1),1:$PIECE(X,"^",8))
SET ORVP=$PIECE(^LR(+X,0),"^",3)_";"_$PIECE(^DIC($PIECE(^LR(+X,0),"^",2),0,"GL"),"^",2)
+4 IF ORNATR="C"
SET OREPDUZ=$PIECE(X,"^",2)
SET ORLOG=$PIECE(X,"^",5)
SET ORNATR=""
+5 SET LRORSAMP=$PIECE(X,"^",3)
SET LRORTYPE=$PIECE(X,"^",4)
SET ORNP=$PIECE(X,"^",6)
SET ORL=$SELECT($LENGTH($PIECE(X,"^",7)):$PIECE(X,"^",7),1:"UNKNOWN")
+6 SET ORL=$SELECT($ORDER(^SC("C",ORL,0))'="":$ORDER(^(0))_";SC(",1:"")
SET ORSTRT=$PIECE(X1,"^")
SET X=^LRO(69,LRODT,1,LRSN,2,LRXDA,0)
SET ORIT=+X_";LAB(60,"
SET LRORSPEC=$ORDER(^LRO(69,LRODT,1,LRSN,4,0))
SET LRORSPEC=$SELECT(LRORSPEC>0:$PIECE(^(LRORSPEC,0),"^"),1:"")
+7 SET X=$SELECT($DATA(LRORSAMP):$SELECT($DATA(^LAB(62,+LRORSAMP,0)):$PIECE(^(0),"^"),1:""),1:"")
SET Y=$SELECT($DATA(LRORSPEC):$SELECT($DATA(^LAB(61,+LRORSPEC,0)):$PIECE(^(0),"^"),1:""),1:"")
+8 SET ORTX(1)=$PIECE(^LAB(60,+LRTS,0),"^")_$SELECT(Y'[X!(X=Y):" "_X,1:"")_$SELECT(X'[Y:" "_Y,1:"")
+9 SET ORTX(1)=ORTX(1)_" LB #"_LRLB_" "_$SELECT($DATA(LRORTYPE):LRORTYPE,1:"")_$SELECT(LRURG=9!('LRURG):"",1:" "_$PIECE(^LAB(62.05,LRURG,0),"^"))
+10 SET ORPCL=$PIECE(^LAB(69.9,1,1),"^",6)
SET ORSTS=6
SET ORTO=$PIECE(^LAB(60,+ORIT,0),"^",6)
IF $PIECE(^LAB(69.9,1,0),"^",9)
SET ORPURG=$PIECE(^(0),"^",9)
+11 SET ORPCL=$PIECE(^LAB(69.9,1,1),"^",6)_";ORD(101,"
SET ORPK=LRODT_"^"_LRSN_"^"_DA
SET DA=LRXDA
+12 DO FILE^ORX
+13 IF $DATA(ORIFN)
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRXDA,0),"^",7)=ORIFN
+14 KILL LRLB,LRXDA,LRFLG,LRORSPEC,LRORSAMP,LRORTYPE
End DoDot:1
+15 NEW LTS
SET LTS(LRTS)=""
+16 DO NEW^LR7OB1(LRODT,LRSN,"SN",$GET(LRNATURE),.LTS,6)
+17 KILL DLAYGO,DA,DIC,DIE,DR,LRBERF,LRBEFN,LRBEX
LOCK -^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
+1 ;
+2 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
+3 IF $DATA(LRPHSET)
QUIT
+4 ;IHS/OIRM TUC/AAB 3/4/97
IF $GET(BLROPT)=""!($GET(BLROPT(0))'=$PIECE(XQY0,U))
SET BLROPT="ADDACC"
SET BLROPT(0)=$PIECE(XQY0,U)
+5 ;IHS/ITSC/TPF 12/04/01 ADDITIONAL CHANGE FOR E-SIG
IF $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))
SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),U,2)
DO ^BLRALAF
+6 ;
+7 ;IHS/OIRM TUC/AAB 11/14/96
WRITE !?5,$PIECE(^LAB(60,LRTS,0),U,1)," ADDED"
IF BLRLOG
DO ^BLREVTQ("C","A",BLROPT,,LRODT_","_LRSN_","_LRAA_","_LRAD_","_LRAN)
KILL DIC("B")
IF $DATA(LRTSAD(2))
QUIT
GOTO ADDTST^LRTSTJAM
+8 ;----- END IHS MODIFICATION LR*5.2*1018
+9 QUIT
+10 ;
+11 ; ----- IHS/MSC/MKK - LR*5.2*1033
+12 ; If D ^DIC fails with Y=-1, try using UDPATE^DIE call
TRYAGAIN ; EP
+1 NEW ERRS,FDA,IENS,IENARRAY
+2 SET IENS="?+1,"_LRSN_","_LRODT_","
+3 SET FDA(69.03,IENS,.01)=LRTS
+4 DO UPDATE^DIE("EKS","FDA","IENARRAY","ERRS")
+5 IF $DATA(ERRS)
SET Y=-1
QUIT
+6 ;
+7 SET Y=$GET(IENARRAY(1))_"^"_LRTS_"^1"
+8 ;
+9 QUIT
+10 ;
+11 SET NOW=$HOROLOG
+12 SET ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS)=""
+13 MERGE ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"FDA")=FDA
+14 MERGE ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"IENARRAY")=IENARRAY
+15 SET ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"Y")=Y
+16 SET ^XTMP("LRTSTSET",0)=$$HTFM^XLFDT(+$HOROLOG+365)_"^"_$$DT^XLFDT_"^LRTSTSET TRYAGAIN Call"
+17 ;
+18 QUIT
+19 ; ----- END IHS/MSC/MKK - LR*5.2*1033
