LROW2A ;SLC/FHS/JAH - CONTINUING TEST & SAMPLE VERIFICATION ; 22-Oct-2013 09:22 ; MKK
;;5.2;LAB SERVICE;**1031,1033**;NOV 1, 1997
;
;;VA LR Patch(s): 20,40,100,107,121,291
;
; Modified slc/jer to include set/kill for "D" cross-reference
;from LROW2
DUP ; L +^LRO(69,LRODT,1) S LRSN=1+$S($D(^LRO(69,LRODT,1,0)):$P(^(0),"^",3),1:0)
L +^LRO(69,LRODT,1):5 ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout
S LRSN=1+$S($D(^LRO(69,LRODT,1,0)):$P(^(0),"^",3),1:0)
I '$D(LR2ORD) F LRSN=LRSN:1 Q:'$D(^LRO(69,LRODT,1,LRSN,0))
E S LRSAME=-1 D ADD I LRSAME=-1 L -^LRO(69,LRODT,1) Q
S ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_U_LRSN,LRSN(LRSN)=""
S LRTN=$S($D(LR2ORD)&$D(^LRO(69,LRODT,1,LRSN,2,0)):$P(^(0),U,3),1:0)
S LRSAMP=LRSSP S:LRSAMP=0 LRSAMP=""
S ^LRO(69,LRODT,1,LRSN,0)=$P(LRSNO,U,1,2)_U_LRSAMP_U_$P(LRSNO,U,4,8),$P(^(0),U,9)=LROLLOC,^(.1)=LRORD,^LRO(69,"C",+LRORD,LRODT,LRSN)=""
L -^LRO(69,LRODT,1)
;
S:LRLLOC="" LRLLOC="." ;IHS/ANMC/CLS 08/18/96
S ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)="",^LRO(69,"D",LRDFN,LRODT,LRSN)="" S:$L(LRLLOC) ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
S:LRLLOC="." LRLLOC="" ;IHS/ANMC/CLS 08/18/96
S LRI=0
F S LRI=$O(LRXS(LRSSP,LRSPEC,LRI)) Q:LRI<1 D
. D SET
. D OR^LROW2 ;OE/RR 2.5
. S ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTEST(LRI),^LRO(69,LRODT,1,LRSN,2,"B",+LRTEST(LRI),LRTN)="",^LRO(69,"AT",LRDFN,+LRTEST(LRI),LRSPEC,LRODT)="",^(-LRODT)=""
. S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",9,10)="IP^L" D:$O(LRTCOM(+LRTEST(LRI),0)) TCOM(+LRTEST(LRI))
. D:+LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) AQ2^LRBEBA3 ; CIDC
S ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRTN_U_LRTN
S ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1",^(1,0)=LRSPEC
I $D(LRCOM(LRSSP,LRSPEC)),LRCOM(LRSSP,LRSPEC) S X=LRCOM(LRSSP,LRSPEC),^LRO(69,LRODT,1,LRSN,6,0)="^69.04^"_X_U_X F J=1:1:X S ^LRO(69,LRODT,1,LRSN,6,J,0)=LRCOM(LRSSP,LRSPEC,J)
N TSTZ S TSTZ=0 F S TSTZ=$O(LRTEST(TSTZ)) Q:TSTZ<1 S TSTZ(+LRTEST(TSTZ))=""
;
D:BLRLOG ^BLREVTQ("C","O",$G(BLROPT),,LRODT_","_LRSN)
;
I $D(^LRO(69,LRODT,1,LRSN,2,0)) D ADDTST^BLRDIAG(LRODT,LRSN,+$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0))) ;IHS/ITSC/TPF 11/06/02 'SIGN OR SYMPTOM' LAB POV **1015**
;
D ENTRYAUD^BLRUTIL("DUP^LROW2A 8.0")
; D GETCCDTO^BLRCCPED(LRODT,LRSN,LRTN) ; IHS/MSC/MKK - LR*5.2*1033
;
D NEW^LR7OB1(LRODT,LRSN,"SN",$G(LRNATURE),.TSTZ)
I $D(LRLWC),LRLWC="LC" S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2) S:ION="" ION=$P(^LAB(69.9,1,3),U,4) I ION]"" D ^LROW2P
I $D(LRLWC),LRLWC="I" S ION=$P(^LAB(69.9,1,7,DUZ(2),0),U,3) I ION]"" D ^LROW2P
WCP Q:$D(LRNCWL) Q:'$D(LRORDER) S ION=LRORDER
I $G(LRPIX)'=LRORD D PAUSE S LRPIX=LRORD
I IO(0)=$G(IO) S IOP=LRORDER,%ZIS="Q" D ^%ZIS Q:POP I '$D(IO("Q")) U IO D ENT2^LROW2P Q
I $G(IO)'=IO(0)!($D(IO("Q"))) D ^LROW2P Q
Q
ADD S LRSN1="" F ZZ=0:0 S LRSN1=$O(^LRO(69,LRODT,1,"AA",LRDFN,LRSN1)) Q:LRSN1="" I ^LRO(69,LRODT,1,LRSN1,.1)=LRORD S LROLLOC=$P(^LRO(69,LRODT,1,LRSN1,0),U,9),LRSAME=$S(LRSSP=$P(^(0),U,3)&(LRSPEC=^(4,1,0)):1,1:0) I LRSAME=1 S LRSN=LRSN1 Q
I LRSAME=0 F LRSN=LRSN:1 Q:'$D(^LRO(69,LRODT,1,LRSN,0))
Q
PAUSE ;
R !!,"Press RETURN to continue...",X:DTIME
Q
SET ;
S LRTN=LRTN+1 I $D(^LRO(69,LRODT,1,LRSN,2,LRTN)) G SET
Q
TCOM(TEST) ;Insert test comments
N J
S ^LRO(69,LRODT,1,LRSN,2,LRTN,1,0)="^^"_LRTCOM(TEST)_"^"_DT_"^"
S J=0 F S J=$O(LRTCOM(TEST,J)) Q:J<1 S ^LRO(69,LRODT,1,LRSN,2,LRTN,1,J,0)=LRTCOM(TEST,J)
Q
LROW2A ;SLC/FHS/JAH - CONTINUING TEST & SAMPLE VERIFICATION ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1031,1033**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 20,40,100,107,121,291
+4 ;
+5 ; Modified slc/jer to include set/kill for "D" cross-reference
+6 ;from LROW2
DUP ; L +^LRO(69,LRODT,1) S LRSN=1+$S($D(^LRO(69,LRODT,1,0)):$P(^(0),"^",3),1:0)
+1 ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout
LOCK +^LRO(69,LRODT,1):5
+2 SET LRSN=1+$SELECT($DATA(^LRO(69,LRODT,1,0)):$PIECE(^(0),"^",3),1:0)
+3 IF '$DATA(LR2ORD)
FOR LRSN=LRSN:1
IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+4 IF '$TEST
SET LRSAME=-1
DO ADD
IF LRSAME=-1
LOCK -^LRO(69,LRODT,1)
QUIT
+5 SET ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_U_LRSN
SET LRSN(LRSN)=""
+6 SET LRTN=$SELECT($DATA(LR2ORD)&$DATA(^LRO(69,LRODT,1,LRSN,2,0)):$PIECE(^(0),U,3),1:0)
+7 SET LRSAMP=LRSSP
IF LRSAMP=0
SET LRSAMP=""
+8 SET ^LRO(69,LRODT,1,LRSN,0)=$PIECE(LRSNO,U,1,2)_U_LRSAMP_U_$PIECE(LRSNO,U,4,8)
SET $PIECE(^(0),U,9)=LROLLOC
SET ^(.1)=LRORD
SET ^LRO(69,"C",+LRORD,LRODT,LRSN)=""
+9 LOCK -^LRO(69,LRODT,1)
+10 ;
+11 ;IHS/ANMC/CLS 08/18/96
IF LRLLOC=""
SET LRLLOC="."
+12 SET ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
SET ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
IF $LENGTH(LRLLOC)
SET ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
+13 ;IHS/ANMC/CLS 08/18/96
IF LRLLOC="."
SET LRLLOC=""
+14 SET LRI=0
+15 FOR
SET LRI=$ORDER(LRXS(LRSSP,LRSPEC,LRI))
IF LRI<1
QUIT
Begin DoDot:1
+16 DO SET
+17 ;OE/RR 2.5
DO OR^LROW2
+18 SET ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTEST(LRI)
SET ^LRO(69,LRODT,1,LRSN,2,"B",+LRTEST(LRI),LRTN)=""
SET ^LRO(69,"AT",LRDFN,+LRTEST(LRI),LRSPEC,LRODT)=""
SET ^(-LRODT)=""
+19 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",9,10)="IP^L"
IF $ORDER(LRTCOM(+LRTEST(LRI),0))
DO TCOM(+LRTEST(LRI))
+20 ; CIDC
IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
DO AQ2^LRBEBA3
End DoDot:1
+21 SET ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRTN_U_LRTN
+22 SET ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1"
SET ^(1,0)=LRSPEC
+23 IF $DATA(LRCOM(LRSSP,LRSPEC))
IF LRCOM(LRSSP,LRSPEC)
SET X=LRCOM(LRSSP,LRSPEC)
SET ^LRO(69,LRODT,1,LRSN,6,0)="^69.04^"_X_U_X
FOR J=1:1:X
SET ^LRO(69,LRODT,1,LRSN,6,J,0)=LRCOM(LRSSP,LRSPEC,J)
+24 NEW TSTZ
SET TSTZ=0
FOR
SET TSTZ=$ORDER(LRTEST(TSTZ))
IF TSTZ<1
QUIT
SET TSTZ(+LRTEST(TSTZ))=""
+25 ;
+26 IF BLRLOG
DO ^BLREVTQ("C","O",$GET(BLROPT),,LRODT_","_LRSN)
+27 ;
+28 ;IHS/ITSC/TPF 11/06/02 'SIGN OR SYMPTOM' LAB POV **1015**
IF $DATA(^LRO(69,LRODT,1,LRSN,2,0))
DO ADDTST^BLRDIAG(LRODT,LRSN,+$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0)))
+29 ;
+30 DO ENTRYAUD^BLRUTIL("DUP^LROW2A 8.0")
+31 ; D GETCCDTO^BLRCCPED(LRODT,LRSN,LRTN) ; IHS/MSC/MKK - LR*5.2*1033
+32 ;
+33 DO NEW^LR7OB1(LRODT,LRSN,"SN",$GET(LRNATURE),.TSTZ)
+34 IF $DATA(LRLWC)
IF LRLWC="LC"
SET ION=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
IF ION=""
SET ION=$PIECE(^LAB(69.9,1,3),U,4)
IF ION]""
DO ^LROW2P
+35 IF $DATA(LRLWC)
IF LRLWC="I"
SET ION=$PIECE(^LAB(69.9,1,7,DUZ(2),0),U,3)
IF ION]""
DO ^LROW2P
WCP IF $DATA(LRNCWL)
QUIT
IF '$DATA(LRORDER)
QUIT
SET ION=LRORDER
+1 IF $GET(LRPIX)'=LRORD
DO PAUSE
SET LRPIX=LRORD
+2 IF IO(0)=$GET(IO)
SET IOP=LRORDER
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
IF '$DATA(IO("Q"))
USE IO
DO ENT2^LROW2P
QUIT
+3 IF $GET(IO)'=IO(0)!($DATA(IO("Q")))
DO ^LROW2P
QUIT
+4 QUIT
ADD SET LRSN1=""
FOR ZZ=0:0
SET LRSN1=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,LRSN1))
IF LRSN1=""
QUIT
IF ^LRO(69,LRODT,1,LRSN1,.1)=LRORD
SET LROLLOC=$PIECE(^LRO(69,LRODT,1,LRSN1,0),U,9)
SET LRSAME=$SELECT(LRSSP=$PIECE(^(0),U,3)&(LRSPEC=^(4,1,0)):1,1:0)
IF LRSAME=1
SET LRSN=LRSN1
QUIT
+1 IF LRSAME=0
FOR LRSN=LRSN:1
IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+2 QUIT
PAUSE ;
+1 READ !!,"Press RETURN to continue...",X:DTIME
+2 QUIT
SET ;
+1 SET LRTN=LRTN+1
IF $DATA(^LRO(69,LRODT,1,LRSN,2,LRTN))
GOTO SET
+2 QUIT
TCOM(TEST) ;Insert test comments
+1 NEW J
+2 SET ^LRO(69,LRODT,1,LRSN,2,LRTN,1,0)="^^"_LRTCOM(TEST)_"^"_DT_"^"
+3 SET J=0
FOR
SET J=$ORDER(LRTCOM(TEST,J))
IF J<1
QUIT
SET ^LRO(69,LRODT,1,LRSN,2,LRTN,1,J,0)=LRTCOM(TEST,J)
+4 QUIT
