LRBLPEW ;AVAMC/REG - BB WORKLOAD ;3/9/94 13:09
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S:LRLLOC="" LRLLOC="UNKNOWN"
I '$D(^LRO(69.2,LRAA,3,LRDFN,0)) S ^(0)=LRDFN_"^"_LRLLOC,^LRO(69.2,LRAA,3,"C",LRLLOC,LRDFN)="",X=^LRO(69.2,LRAA,3,0),^(0)=$P(X,"^",1,2)_"^"_LRDFN_"^"_($P(X,"^",4)+1)
S LRY=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),LRV=$P(LRY,"^",5)
I LRV,$O(^(0)),'LRW K ^LRO(68,LRAA,1,LRAD,1,"AD",$P(LRV,"."),LRAN),^LRO(68,LRAA,1,LRAD,1,"AC",LRV,LRAN) Q
D DT^LRBLU
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)=$P(LRY,"^")_"^"_$P(LRY,"^",2)_"^"_$P(LRY,"^",3)_"^"_DUZ_"^"_LRK_"^",$P(^LR(LRDFN,LRSS,LRI,0),"^",3)=LRK,^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
S ^LRO(68,LRAA,1,LRAD,1,"AD",$P(LRK,"."),LRAN)="",^LRO(68,LRAA,1,LRAD,1,"AC",LRK,LRAN)=""
S Y=^LRO(68,LRAA,1,LRAD,1,LRAN,0),Y(4)=$P(Y,"^",4),Y(5)=$P(Y,"^",5)
I Y(4),Y(5),$D(^LRO(69,Y(4),1,Y(5),3)) S $P(^(3),"^",2)=LRK
S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^" S LRF=^(0),(C,LRG)=0
F A=0:0 S A=$O(^LAB(60,LRT,9,A)) Q:'A I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0)) S ^(0)=A_"^1^0^^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA,LRG=LRG+1,C=A
I LRG S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)=$P(LRF,"^",1,2)_"^"_C_"^"_($P(LRF,"^",4)+LRG)
I 'LRW(2.1),$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRW(0,86250),0)) K ^(0) S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
D:LRW(2.4)!(LRW(2.6)) CMB D:DR="[LRBLPAG]" PH Q:'LRW
CAP K ^TMP($J)
W !!,"Enter Antibody Identification Workload"
S LR(62.07)=$P(LRT(LRT),U,3)
I '$O(^LAB(62.07,LR(62.07),9,0)) W $C(7),!!,"No WKLD CODES to select for ",$P(^LAB(62.07,LR(62.07),0),U)," in EXECUTE CODE file." Q
F LRA=0:0 S DIC="^LAB(62.07,LR(62.07),9,",DIC(0)="AEQM" D ^DIC K DIC Q:Y<1 D C S ^TMP($J,+Y)=X
I '$D(^TMP($J)) W $C(7),!,"No WKLD CODES selected." Q
W !!,"Count WKLD CODES Selected: " F A=0:0 S A=$O(^TMP($J,A)) Q:'A S B=^(A),X=^LAM(A,0) S:'B B=1 W !,$J(B,2),?6,$P(X,U,2),?16,$P(X,U)
W !,"WKLD CODES selected OK " S %=1 D YN^LRU Q:%<1 I %'=1 W !!,$C(7),"No WKLD codes selected. Try again." G CAP
S LRG=0 F A=0:0 S A=$O(^TMP($J,A)) Q:'A S B=^(A) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0)) S ^(0)=A_"^"_B_"^0^^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA,LRG=LRG+1,C=A
I LRG S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+LRG)
Q
CMB I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRW(0,86250),0)) S ^(0)=LRW(0,86250)_"^^0^^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_LRW(0,86250)_"^"_($P(X,"^",4)+1)
S X=1 S:LRW(2.4) X=X+1 S:LRW(2.6) X=X+1 S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRW(0,86250),0),"^",2)=X Q
;
C R !," Enter WKLD CODE COUNT if more than one: ",X:DTIME Q:X=""!(X[U) I +X'=X!(X<2)!(X>20) W $C(7),!,"Enter a number from 2 to 20" G C
Q
PH F A=1.1,1.2,1.3,1.4 F B=0:0 S B=$O(^LR(LRDFN,"BB",LRI,A,B)) Q:'B F C=0:0 S C=$O(^LAB(61.3,B,9,C)) Q:'C D STF
Q
STF I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)) S X=^(0),$P(X,"^",2)=$S($P(X,"^",3):1,1:$P(X,"^",2)+1),$P(X,"^",3)=0,^(0)=X Q
S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^" S X=^(0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1),^(C,0)=C Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPEW 3360 printed Dec 13, 2024@02:11:54 Page 2
LRBLPEW ;AVAMC/REG - BB WORKLOAD ;3/9/94 13:09
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 if LRLLOC=""
SET LRLLOC="UNKNOWN"
+4 IF '$DATA(^LRO(69.2,LRAA,3,LRDFN,0))
SET ^(0)=LRDFN_"^"_LRLLOC
SET ^LRO(69.2,LRAA,3,"C",LRLLOC,LRDFN)=""
SET X=^LRO(69.2,LRAA,3,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRDFN_"^"_($PIECE(X,"^",4)+1)
+5 SET LRY=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)
SET LRV=$PIECE(LRY,"^",5)
+6 IF LRV
IF $ORDER(^(0))
IF 'LRW
KILL ^LRO(68,LRAA,1,LRAD,1,"AD",$PIECE(LRV,"."),LRAN),^LRO(68,LRAA,1,LRAD,1,"AC",LRV,LRAN)
QUIT
+7 DO DT^LRBLU
+8 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)=$PIECE(LRY,"^")_"^"_$PIECE(LRY,"^",2)_"^"_$PIECE(LRY,"^",3)_"^"_DUZ_"^"_LRK_"^"
SET $PIECE(^LR(LRDFN,LRSS,LRI,0),"^",3)=LRK
SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+9 SET ^LRO(68,LRAA,1,LRAD,1,"AD",$PIECE(LRK,"."),LRAN)=""
SET ^LRO(68,LRAA,1,LRAD,1,"AC",LRK,LRAN)=""
+10 SET Y=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET Y(4)=$PIECE(Y,"^",4)
SET Y(5)=$PIECE(Y,"^",5)
+11 IF Y(4)
IF Y(5)
IF $DATA(^LRO(69,Y(4),1,Y(5),3))
SET $PIECE(^(3),"^",2)=LRK
+12 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))
SET ^(0)="^68.14P^^"
SET LRF=^(0)
SET (C,LRG)=0
+13 FOR A=0:0
SET A=$ORDER(^LAB(60,LRT,9,A))
if 'A
QUIT
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0))
SET ^(0)=A_"^1^0^^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
SET LRG=LRG+1
SET C=A
+14 IF LRG
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)=$PIECE(LRF,"^",1,2)_"^"_C_"^"_($PIECE(LRF,"^",4)+LRG)
+15 IF 'LRW(2.1)
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRW(0,86250),0))
KILL ^(0)
SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)
SET X(1)=$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
+16 if LRW(2.4)!(LRW(2.6))
DO CMB
if DR="[LRBLPAG]"
DO PH
if 'LRW
QUIT
CAP KILL ^TMP($JOB)
+1 WRITE !!,"Enter Antibody Identification Workload"
+2 SET LR(62.07)=$PIECE(LRT(LRT),U,3)
+3 IF '$ORDER(^LAB(62.07,LR(62.07),9,0))
WRITE $CHAR(7),!!,"No WKLD CODES to select for ",$PIECE(^LAB(62.07,LR(62.07),0),U)," in EXECUTE CODE file."
QUIT
+4 FOR LRA=0:0
SET DIC="^LAB(62.07,LR(62.07),9,"
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
if Y<1
QUIT
DO C
SET ^TMP($JOB,+Y)=X
+5 IF '$DATA(^TMP($JOB))
WRITE $CHAR(7),!,"No WKLD CODES selected."
QUIT
+6 WRITE !!,"Count WKLD CODES Selected: "
FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
if 'A
QUIT
SET B=^(A)
SET X=^LAM(A,0)
if 'B
SET B=1
WRITE !,$JUSTIFY(B,2),?6,$PIECE(X,U,2),?16,$PIECE(X,U)
+7 WRITE !,"WKLD CODES selected OK "
SET %=1
DO YN^LRU
if %<1
QUIT
IF %'=1
WRITE !!,$CHAR(7),"No WKLD codes selected. Try again."
GOTO CAP
+8 SET LRG=0
FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
if 'A
QUIT
SET B=^(A)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0))
SET ^(0)=A_"^"_B_"^0^^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
SET LRG=LRG+1
SET C=A
+9 IF LRG
SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_($PIECE(X,"^",4)+LRG)
+10 QUIT
CMB IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRW(0,86250),0))
SET ^(0)=LRW(0,86250)_"^^0^^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRW(0,86250)_"^"_($PIECE(X,"^",4)+1)
+1 SET X=1
if LRW(2.4)
SET X=X+1
if LRW(2.6)
SET X=X+1
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRW(0,86250),0),"^",2)=X
QUIT
+2 ;
C READ !," Enter WKLD CODE COUNT if more than one: ",X:DTIME
if X=""!(X[U)
QUIT
IF +X'=X!(X<2)!(X>20)
WRITE $CHAR(7),!,"Enter a number from 2 to 20"
GOTO C
+1 QUIT
PH FOR A=1.1,1.2,1.3,1.4
FOR B=0:0
SET B=$ORDER(^LR(LRDFN,"BB",LRI,A,B))
if 'B
QUIT
FOR C=0:0
SET C=$ORDER(^LAB(61.3,B,9,C))
if 'C
QUIT
DO STF
+1 QUIT
STF IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0))
SET X=^(0)
SET $PIECE(X,"^",2)=$SELECT($PIECE(X,"^",3):1,1:$PIECE(X,"^",2)+1)
SET $PIECE(X,"^",3)=0
SET ^(0)=X
QUIT
+1 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))
SET ^(0)="^68.14P^^"
SET X=^(0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_($PIECE(X,"^",4)+1)
SET ^(C,0)=C
QUIT
