LRCAPV1 ;SLC/FHS-DETERMINE CAP AND STUFF INTO LRO(68 PART 1 ;12/3/1997
;;5.2;LAB SERVICE;**42,119,153,221**;Sep 27, 1994
LOOK ;from LRVER3,LRVR3,LAMIAUT4,LRMIV1,LRMIV2
Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) I $D(XRTL) S XRTN="LRCAPV1" D T0^%ZOSV ; START RESPONSE TIME LOGGING
Q:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
S LRSSC=$G(^LRO(68,+LRAA,1,LRAD,1,LRAN,5,1,0)) Q:'$L(LRSSC) L +^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
I $D(LRSB) S A1=0 F S A1=$O(LRSB(A1)) Q:A1<1 S LRT=+$G(^TMP("LR",$J,"TMP",A1)),LRT("P")=$G(^TMP("LR",$J,"TMP",A1,"P")) I LRT D L60A
N LRURGW
K LRT S (LRTT,LRT)=0,LRURGW=9
F S LRTT=$O(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT)) Q:LRTT<.5 I $D(^(LRTT,0))#2,$E($P(^(0),U,6))'="*" S LRURGW=$S($P(^(0),U,2)<LRURGW:$P(^(0),U,2),1:LRURGW) D
. I LRSS'="MI",'$P(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0),U,7) S LRTS(LRTT)=LRTT D RES S LRT=LRTT D L78 Q
. S LRTS(LRTT)=LRTT D RES S LRT=LRTT D L78 Q
D:LRSS="MI" ^LRCAPVM S LRADD=0 I $D(LRSB),$O(LRSB(0)) F LRT=0:0 S LRT=$O(LRCDEF(LRT)) Q:'LRT D L60
K A1,NODE,LRADD,LRSSC,LRTIME,NODE,ADDX,A,LRCODE,P,LRP,LRCNT,NODE0,X,LRPN L -^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
I $D(XRT0) S XRTN="LOOK^LRCAPV1" D T1^%ZOSV ; STOP RESPONSE TIME LOGGING
Q
RES K LRTIME Q:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
Q:$E($P(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0),U,6))="*"
I $G(LRSS)'="MI" Q:$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0))#2&('$P(^(0),U,5)) S LRTIME=$P(^(0),U,5)
S LRT=LRTT S:'$D(LRTIME) LRTIME=$$NOW^XLFDT
S:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,1,0))#2 ^(0)="^68.14P^" S NODE=^(0)
I $D(^LAB(60,LRTT,0)),'$L($P(^(0),U,5)) S LRT=LRTT D L60,ETIO3
;D L78
OUT Q
L60A Q:$P(LRSB(A1),U)=""!($P(LRSB(A1),U)="canc")!($P(LRSB(A1),U)="pending") D L60,ETIOY
Q
L60 F A=0:0 S A=$O(^LAB(60,LRT,9,A)) Q:A<1 I $G(^(A,0)) S LRCODE=^(0),P=+$P(LRCODE,U,4),LRP=+LRCODE,LRCNT=$S($P(LRCODE,U,3):$P(LRCODE,U,3),1:1),LRCODE=$P(LRCODE,U,2),LRNOCODE=0 D:'$P(LRCODE,".",2)&(LRCDEF>0)&('P) SET^LRCAPV1A D STUF
Q
L78 I $D(LRT),$D(LRCDEF)#2,$P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,5) S X=^(0) I '$P(X,U,7) S $P(X,U,7)=1,$P(X,U,8)=LRCDEF,^(0)=X Q
Q
STUF I $D(LRNOCODE) Q:LRNOCODE I $G(LRSS)'="MI",$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),'$P(^(0),U,5) Q
;I $L($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,8)) Q
I $G(LRSS)="MI",'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)) Q
STUFE ;
Q:$E($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,6))="*"
S LRNOCODE=0 I '$D(LRADD),$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0))#2,'$P(^(0),U,5) Q
Q:'$D(LRADD)&($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,7))
D SET^LRCAPV1S
STUFI ;from LRVER3A,LRWLST12
Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
Q
ETIO ;from LRMIBUG
Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) L +^LRO(68,+LRAA,1,LRAD,1,LRAN,4):1 I '$T W !!?10,"Someone else is editing this entry",$C(7),!! Q
DIY S LRT=LRTS,LRADD="" Q:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
S:'$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,1,0))#2 ^(0)="^68.14PA^" S NODE0=^(0) S LRTIME=$$NOW^XLFDT,GLB="^LAB(61.2,+LRBG1,9,A)" D ETIOL,L78
K LRADD L -^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
Q
ETIOY Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) S:$G(LRTT) LRT=+LRTT Q:'$G(LRT) I $D(LRT),$D(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),'$P(^(0),U,5) Q
Q:$E($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,$G(LRT),0)),U,6))="*"
ETIO3 Q:'$G(LRT) I $P($G(LRSSC),U,2) S LRSSCX=$O(^LAB(60,LRT,3,"B",$P(LRSSC,U,2),0)) I LRSSCX S GLB="^LAB(60,LRT,3,LRSSCX,9,A)" D ETIOL
Q
ETIOL F A=0:0 S A=$O(@(GLB)) Q:A<.5 I $D(^(A,0)) S LRCODE=^(0),LRP=+LRCODE,LRCNT=$S(+$P(LRCODE,U,3):$P(LRCODE,U,3),1:1),LRCODE=$P(LRCODE,U,2) D STUFE
Q
ENDIY ;Entry point for non microbiology accessions not using bacteria
;execute code. The calling point is the mumps x-ref on the .01 node
;each etiology selection field
1 ;
Q:'$P($G(LRPARAM),U,14)!('$P($G(^LRO(68,+$G(LRAA),0)),U,16))
Q:'$G(LRAA)!('$G(LRAN))!('$G(LRAD))!('$G(LRANOK))!('$G(DUZ(2)))!('$G(LRTS))
L +^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
S LRBG1=X I '$L($G(^LAB(61.2,+$G(LRBG1),0))) L -^LRO(68,+LRAA,1,LRAD,1,LRAN,4) K LRBG1 Q
N X,DIC,DIE,DA,D0,LRT,GLB,LRCODE,A,I,LRADD
D DIY K LRBG1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPV1 4191 printed Dec 13, 2024@02:13:26 Page 2
LRCAPV1 ;SLC/FHS-DETERMINE CAP AND STUFF INTO LRO(68 PART 1 ;12/3/1997
+1 ;;5.2;LAB SERVICE;**42,119,153,221**;Sep 27, 1994
LOOK ;from LRVER3,LRVR3,LAMIAUT4,LRMIV1,LRMIV2
+1 ; START RESPONSE TIME LOGGING
if '$PIECE(LRPARAM,U,14)!('$PIECE($GET(^LRO(68,+LRAA,0)),U,16))
QUIT
IF $DATA(XRTL)
SET XRTN="LRCAPV1"
DO T0^%ZOSV
+2 if '$DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
QUIT
+3 SET LRSSC=$GET(^LRO(68,+LRAA,1,LRAD,1,LRAN,5,1,0))
if '$LENGTH(LRSSC)
QUIT
LOCK +^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
+4 IF $DATA(LRSB)
SET A1=0
FOR
SET A1=$ORDER(LRSB(A1))
if A1<1
QUIT
SET LRT=+$GET(^TMP("LR",$JOB,"TMP",A1))
SET LRT("P")=$GET(^TMP("LR",$JOB,"TMP",A1,"P"))
IF LRT
DO L60A
+5 NEW LRURGW
+6 KILL LRT
SET (LRTT,LRT)=0
SET LRURGW=9
+7 FOR
SET LRTT=$ORDER(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT))
if LRTT<.5
QUIT
IF $DATA(^(LRTT,0))#2
IF $EXTRACT($PIECE(^(0),U,6))'="*"
SET LRURGW=$SELECT($PIECE(^(0),U,2)<LRURGW:$PIECE(^(0),U,2),1:LRURGW)
Begin DoDot:1
+8 IF LRSS'="MI"
IF '$PIECE(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0),U,7)
SET LRTS(LRTT)=LRTT
DO RES
SET LRT=LRTT
DO L78
QUIT
+9 SET LRTS(LRTT)=LRTT
DO RES
SET LRT=LRTT
DO L78
QUIT
End DoDot:1
+10 if LRSS="MI"
DO ^LRCAPVM
SET LRADD=0
IF $DATA(LRSB)
IF $ORDER(LRSB(0))
FOR LRT=0:0
SET LRT=$ORDER(LRCDEF(LRT))
if 'LRT
QUIT
DO L60
+11 KILL A1,NODE,LRADD,LRSSC,LRTIME,NODE,ADDX,A,LRCODE,P,LRP,LRCNT,NODE0,X,LRPN
LOCK -^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
+12 ; STOP RESPONSE TIME LOGGING
IF $DATA(XRT0)
SET XRTN="LOOK^LRCAPV1"
DO T1^%ZOSV
+13 QUIT
RES KILL LRTIME
if '$DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
QUIT
+1 if $EXTRACT($PIECE(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0),U,6))="*"
QUIT
+2 IF $GET(LRSS)'="MI"
if $DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,0))#2&('$PIECE(^(0),U,5))
QUIT
SET LRTIME=$PIECE(^(0),U,5)
+3 SET LRT=LRTT
if '$DATA(LRTIME)
SET LRTIME=$$NOW^XLFDT
+4 if '$DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRTT,1,0))#2
SET ^(0)="^68.14P^"
SET NODE=^(0)
+5 IF $DATA(^LAB(60,LRTT,0))
IF '$LENGTH($PIECE(^(0),U,5))
SET LRT=LRTT
DO L60
DO ETIO3
+6 ;D L78
OUT QUIT
L60A if $PIECE(LRSB(A1),U)=""!($PIECE(LRSB(A1),U)="canc")!($PIECE(LRSB(A1),U)="pending")
QUIT
DO L60
DO ETIOY
+1 QUIT
L60 FOR A=0:0
SET A=$ORDER(^LAB(60,LRT,9,A))
if A<1
QUIT
IF $GET(^(A,0))
SET LRCODE=^(0)
SET P=+$PIECE(LRCODE,U,4)
SET LRP=+LRCODE
SET LRCNT=$SELECT($PIECE(LRCODE,U,3):$PIECE(LRCODE,U,3),1:1)
SET LRCODE=$PIECE(LRCODE,U,2)
SET LRNOCODE=0
if '$PIECE(LRCODE,".",2)&(LRCDEF>0)&('P)
DO SET^LRCAPV1A
DO STUF
+1 QUIT
L78 IF $DATA(LRT)
IF $DATA(LRCDEF)#2
IF $PIECE($GET(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,5)
SET X=^(0)
IF '$PIECE(X,U,7)
SET $PIECE(X,U,7)=1
SET $PIECE(X,U,8)=LRCDEF
SET ^(0)=X
QUIT
+1 QUIT
STUF IF $DATA(LRNOCODE)
if LRNOCODE
QUIT
IF $GET(LRSS)'="MI"
IF $DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0))
IF '$PIECE(^(0),U,5)
QUIT
+1 ;I $L($P($G(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,8)) Q
+2 IF $GET(LRSS)="MI"
IF '$DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0))
QUIT
STUFE ;
+1 if $EXTRACT($PIECE($GET(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,6))="*"
QUIT
+2 SET LRNOCODE=0
IF '$DATA(LRADD)
IF $DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0))#2
IF '$PIECE(^(0),U,5)
QUIT
+3 if '$DATA(LRADD)&($PIECE($GET(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,7))
QUIT
+4 DO SET^LRCAPV1S
STUFI ;from LRVER3A,LRWLST12
+1 if '$PIECE(LRPARAM,U,14)!('$PIECE($GET(^LRO(68,+LRAA,0)),U,16))
QUIT
SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+2 QUIT
ETIO ;from LRMIBUG
+1 if '$PIECE(LRPARAM,U,14)!('$PIECE($GET(^LRO(68,+LRAA,0)),U,16))
QUIT
LOCK +^LRO(68,+LRAA,1,LRAD,1,LRAN,4):1
IF '$TEST
WRITE !!?10,"Someone else is editing this entry",$CHAR(7),!!
QUIT
DIY SET LRT=LRTS
SET LRADD=""
if '$DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,0))#2
QUIT
+1 if '$DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,1,0))#2
SET ^(0)="^68.14PA^"
SET NODE0=^(0)
SET LRTIME=$$NOW^XLFDT
SET GLB="^LAB(61.2,+LRBG1,9,A)"
DO ETIOL
DO L78
+2 KILL LRADD
LOCK -^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
+3 QUIT
ETIOY if '$PIECE(LRPARAM,U,14)!('$PIECE($GET(^LRO(68,+LRAA,0)),U,16))
QUIT
if $GET(LRTT)
SET LRT=+LRTT
if '$GET(LRT)
QUIT
IF $DATA(LRT)
IF $DATA(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,LRT,0))
IF '$PIECE(^(0),U,5)
QUIT
+1 if $EXTRACT($PIECE($GET(^LRO(68,+LRAA,1,LRAD,1,LRAN,4,$GET(LRT),0)),U,6))="*"
QUIT
ETIO3 if '$GET(LRT)
QUIT
IF $PIECE($GET(LRSSC),U,2)
SET LRSSCX=$ORDER(^LAB(60,LRT,3,"B",$PIECE(LRSSC,U,2),0))
IF LRSSCX
SET GLB="^LAB(60,LRT,3,LRSSCX,9,A)"
DO ETIOL
+1 QUIT
ETIOL FOR A=0:0
SET A=$ORDER(@(GLB))
if A<.5
QUIT
IF $DATA(^(A,0))
SET LRCODE=^(0)
SET LRP=+LRCODE
SET LRCNT=$SELECT(+$PIECE(LRCODE,U,3):$PIECE(LRCODE,U,3),1:1)
SET LRCODE=$PIECE(LRCODE,U,2)
DO STUFE
+1 QUIT
ENDIY ;Entry point for non microbiology accessions not using bacteria
+1 ;execute code. The calling point is the mumps x-ref on the .01 node
+2 ;each etiology selection field
1 ;
+1 if '$PIECE($GET(LRPARAM),U,14)!('$PIECE($GET(^LRO(68,+$GET(LRAA),0)),U,16))
QUIT
+2 if '$GET(LRAA)!('$GET(LRAN))!('$GET(LRAD))!('$GET(LRANOK))!('$GET(DUZ(2)))!('$GET(LRTS))
QUIT
+3 LOCK +^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
+4 SET LRBG1=X
IF '$LENGTH($GET(^LAB(61.2,+$GET(LRBG1),0)))
LOCK -^LRO(68,+LRAA,1,LRAD,1,LRAN,4)
KILL LRBG1
QUIT
+5 NEW X,DIC,DIE,DA,D0,LRT,GLB,LRCODE,A,I,LRADD
+6 DO DIY
KILL LRBG1
+7 QUIT
