- 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 Feb 18, 2025@23:39:19 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
