LRCAPVM ;DALOI/FHS - ADD WKLD CODES FOR MICRO VERIFICATION ;Jul 20, 2020@13:53
;;5.2;LAB SERVICE;**49,163,263,537**;Sep 27, 1994;Build 11
;
EN ;
N LRORG
Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,LRAA,0)),U,16)) S LREND=0
I $D(LAMIAUTO),$D(LRINST) S LRTS=$S(+$P(^LAB(62.4,LRINST,0),U,16):$P(^(0),U,16),1:LRTS),LRORG=0 I LRTS D
. F S LRORG=$O(^LAH(LRLL,1,LRIFN,3,LRORG)) K LRADD Q:LRORG<1 I $D(^(LRORG,0))#2 S LRGB1=+^(0),GLB="^LAB(61.2,LRGB1,9,A)",LRADD="" D ETIOL^LRCAPV1
;LR*5.2*537 - LRVR Micro instrumentation logic
;FLD=etiology nodes
;Look in all "MI" subscripts for organisms
;3=organism,6=parasite,9=fungus,12=microbacteria,17-virus
I $G(LRINTYPE)=1,$G(LRTS) D
. N LRFLD,LRT,LRTIME,LRMETH,LRINST,LRADD,LRISO,LRGB1,GLB
. S:'$G(LRURGW) LRURGW=$G(LRALERT,9)
. S LRTIME=$$NOW^XLFDT
. S LRMETH=$P($G(^LAH(LRLL,1,ISQN,0)),U,7)
. I LRMETH]"" S LRINST=$O(^LAB(62.4,"D",LRMETH,0))
. I $G(LRINST) S (LRT,LRTS)=$S(+$P(^LAB(62.4,LRINST,0),U,16):$P(^(0),U,16),1:LRTS)
. S LRORG=0
. I '$G(LRT) S LRT=LRTS
. S:'$G(LRT("P")) LRT("P")=LRT
. F LRFLD=3,6,9,12,17 S LRORG=0 D
. . F S LRORG=$O(^LAH(LRLL,1,ISQN,"MI",LRFLD,LRORG)) K LRADD Q:LRORG<1 I $G(^(LRORG,0)) S LRGB1=+^(0) D
. . . ;LRISO = Isolate ID
. . . S LRISO=$G(^LAH(LRLL,1,ISQN,"MI",LRFLD,LRORG,.1))
. . . Q:LRISO=""
. . . ;Do not re-accumulate workload if this is a re-transmission of
. . . ;the same isolate id. LRM63ORG array is set by routine LRVR0.
. . . ;Not checking isolate number IEN in ^LAH vs ^LR because the IEN's
. . . ;could differ between ^LAH and ^LR. The isolate ID is consistent
. . . ;with subsequent transmissions of the same organism. Also, not
. . . ;checking organism IEN from the ETIOLOGY (#61.2) file because an
. . . ;organism might be filed multiple times on an accession. In the
. . . ;instance that an isolate id is changed for an organism, workload
. . . ;counts must be adjusted manually. It is standard laboratory
. . . ;practice to not change the isolate id for an organism.
. . . Q:$D(LRM63ORG(LRFLD,LRISO))
. . . S GLB="^LAB(61.2,LRGB1,9,A)",LRADD="" D ETIOL^LRCAPV1
;LR*5.2*537 end
Q:$G(LRMIMASS)
K GLB F W !!?10,"(D)isplay (A)dd Work Load " R X:DTIME S X=$E(X) S:'$T!(X=U)!(X="") LREND=1 Q:X="A"!(LREND) D:X="D" DIS^LRCAPU
G END:LREND
S X1="" S LRTIME=$$NOW^LRAFUNC1,LRADD=""
SEL ;
K DIC,DA S DIC("A")="Which Test ",DIC(0)="AEQNMZ",DIC="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN_",4,"
S DA(1)=LRAN,DA(2)=LRAD,DA(3)=LRAA,X1="" F D ^DIC Q:Y<1 S:$L(X1) X1=X1_","_+Y I '$L(X1) S X1=+Y
G:'$L(X1) END S X=X1 D RANGE^LRWU2 I '$L(X9) W !,"NOTHING SELECTED " G END
K DIC S LREND=0,LRSTAR=1,X9=X9_"Q:LREND D LOAD" X X9 S LREND=0
G EN
LOAD ;
Q:'$D(^LAB(60,T1,0))
I '$P(^LAB(60,T1,0),U,14) W !!?7," ** NO EDIT TEMPLATE FOR ",$P(^(0),U),! Q
CODE S LREC=$P(^LAB(60,T1,0),U,14) I '$D(^LAB(62.07,LREC,0)) W !,"ERROR IN ",$P(^LAB(60,T1,0),U) Q
I '$O(^LAB(62.07,LREC,9,0)) W !!?5,"NO CODE DEFINED FOR THE TEST ",!,$C(7) Q
W !!?10,"Additional Work load for "_$P(^LAB(60,T1,0),U),!
S LRT=T1,DIC="^LAB(62.07,"_LREC_",9,",DIC(0)="AEZMNQ"
F G:LREND MORE D ^DIC Q:Y<1 S:X=U LREND=1 Q:LREND S LRP=+Y,LRCODE=$P(Y,U,2),LRCNT=$S($P(Y(0),U,3):$P(Y(0),U,3),1:1) D CNT
K LRSTAR1,LRCNTD
MORE S LREND=0
Q
CNT ;
D Q:$D(DIRUT)!($D(DTOUT))!($D(DUOUT))
. N DIR
. S DIR(0)="NO^0:25:0",DIR("A")=" MULTIPLY BY "
. I $G(LRCNT),$G(LRCNT)<26 S DIR("B")=+$G(LRCNT)
. S DIR("?")=$$CJ^XLFSTR("to be used for this procedure.",IOM)
. S DIR("?",1)=$$CJ^XLFSTR("Enter the WKLD CODE weight multiplier,",IOM)
. S DIR("?",2)=$$CJ^XLFSTR("enter a number between 1 - 25",IOM)
. D ^DIR
S LRCNT=+Y
I LRCNT<1 W !?5,"No workload added ",! Q
CK Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) S:'$D(^(LRT,1,0)) ^(0)="^68.14P^" S NODE0=^(0),LRADD="" D STUFE^LRCAPV1 K LRADD
Q
QUE ;S X="?" D ^DIC G RD
END ;
K DIC,T1,LRSTAR,LRADD S LREND=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPVM 3913 printed Oct 16, 2024@18:14:17 Page 2
LRCAPVM ;DALOI/FHS - ADD WKLD CODES FOR MICRO VERIFICATION ;Jul 20, 2020@13:53
+1 ;;5.2;LAB SERVICE;**49,163,263,537**;Sep 27, 1994;Build 11
+2 ;
EN ;
+1 NEW LRORG
+2 if '$PIECE(LRPARAM,U,14)!('$PIECE($GET(^LRO(68,LRAA,0)),U,16))
QUIT
SET LREND=0
+3 IF $DATA(LAMIAUTO)
IF $DATA(LRINST)
SET LRTS=$SELECT(+$PIECE(^LAB(62.4,LRINST,0),U,16):$PIECE(^(0),U,16),1:LRTS)
SET LRORG=0
IF LRTS
Begin DoDot:1
+4 FOR
SET LRORG=$ORDER(^LAH(LRLL,1,LRIFN,3,LRORG))
KILL LRADD
if LRORG<1
QUIT
IF $DATA(^(LRORG,0))#2
SET LRGB1=+^(0)
SET GLB="^LAB(61.2,LRGB1,9,A)"
SET LRADD=""
DO ETIOL^LRCAPV1
End DoDot:1
+5 ;LR*5.2*537 - LRVR Micro instrumentation logic
+6 ;FLD=etiology nodes
+7 ;Look in all "MI" subscripts for organisms
+8 ;3=organism,6=parasite,9=fungus,12=microbacteria,17-virus
+9 IF $GET(LRINTYPE)=1
IF $GET(LRTS)
Begin DoDot:1
+10 NEW LRFLD,LRT,LRTIME,LRMETH,LRINST,LRADD,LRISO,LRGB1,GLB
+11 if '$GET(LRURGW)
SET LRURGW=$GET(LRALERT,9)
+12 SET LRTIME=$$NOW^XLFDT
+13 SET LRMETH=$PIECE($GET(^LAH(LRLL,1,ISQN,0)),U,7)
+14 IF LRMETH]""
SET LRINST=$ORDER(^LAB(62.4,"D",LRMETH,0))
+15 IF $GET(LRINST)
SET (LRT,LRTS)=$SELECT(+$PIECE(^LAB(62.4,LRINST,0),U,16):$PIECE(^(0),U,16),1:LRTS)
+16 SET LRORG=0
+17 IF '$GET(LRT)
SET LRT=LRTS
+18 if '$GET(LRT("P"))
SET LRT("P")=LRT
+19 FOR LRFLD=3,6,9,12,17
SET LRORG=0
Begin DoDot:2
+20 FOR
SET LRORG=$ORDER(^LAH(LRLL,1,ISQN,"MI",LRFLD,LRORG))
KILL LRADD
if LRORG<1
QUIT
IF $GET(^(LRORG,0))
SET LRGB1=+^(0)
Begin DoDot:3
+21 ;LRISO = Isolate ID
+22 SET LRISO=$GET(^LAH(LRLL,1,ISQN,"MI",LRFLD,LRORG,.1))
+23 if LRISO=""
QUIT
+24 ;Do not re-accumulate workload if this is a re-transmission of
+25 ;the same isolate id. LRM63ORG array is set by routine LRVR0.
+26 ;Not checking isolate number IEN in ^LAH vs ^LR because the IEN's
+27 ;could differ between ^LAH and ^LR. The isolate ID is consistent
+28 ;with subsequent transmissions of the same organism. Also, not
+29 ;checking organism IEN from the ETIOLOGY (#61.2) file because an
+30 ;organism might be filed multiple times on an accession. In the
+31 ;instance that an isolate id is changed for an organism, workload
+32 ;counts must be adjusted manually. It is standard laboratory
+33 ;practice to not change the isolate id for an organism.
+34 if $DATA(LRM63ORG(LRFLD,LRISO))
QUIT
+35 SET GLB="^LAB(61.2,LRGB1,9,A)"
SET LRADD=""
DO ETIOL^LRCAPV1
End DoDot:3
End DoDot:2
End DoDot:1
+36 ;LR*5.2*537 end
+37 if $GET(LRMIMASS)
QUIT
+38 KILL GLB
FOR
WRITE !!?10,"(D)isplay (A)dd Work Load "
READ X:DTIME
SET X=$EXTRACT(X)
if '$TEST!(X=U)!(X="")
SET LREND=1
if X="A"!(LREND)
QUIT
if X="D"
DO DIS^LRCAPU
+39 if LREND
GOTO END
+40 SET X1=""
SET LRTIME=$$NOW^LRAFUNC1
SET LRADD=""
SEL ;
+1 KILL DIC,DA
SET DIC("A")="Which Test "
SET DIC(0)="AEQNMZ"
SET DIC="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN_",4,"
+2 SET DA(1)=LRAN
SET DA(2)=LRAD
SET DA(3)=LRAA
SET X1=""
FOR
DO ^DIC
if Y<1
QUIT
if $LENGTH(X1)
SET X1=X1_","_+Y
IF '$LENGTH(X1)
SET X1=+Y
+3 if '$LENGTH(X1)
GOTO END
SET X=X1
DO RANGE^LRWU2
IF '$LENGTH(X9)
WRITE !,"NOTHING SELECTED "
GOTO END
+4 KILL DIC
SET LREND=0
SET LRSTAR=1
SET X9=X9_"Q:LREND D LOAD"
XECUTE X9
SET LREND=0
+5 GOTO EN
LOAD ;
+1 if '$DATA(^LAB(60,T1,0))
QUIT
+2 IF '$PIECE(^LAB(60,T1,0),U,14)
WRITE !!?7," ** NO EDIT TEMPLATE FOR ",$PIECE(^(0),U),!
QUIT
CODE SET LREC=$PIECE(^LAB(60,T1,0),U,14)
IF '$DATA(^LAB(62.07,LREC,0))
WRITE !,"ERROR IN ",$PIECE(^LAB(60,T1,0),U)
QUIT
+1 IF '$ORDER(^LAB(62.07,LREC,9,0))
WRITE !!?5,"NO CODE DEFINED FOR THE TEST ",!,$CHAR(7)
QUIT
+2 WRITE !!?10,"Additional Work load for "_$PIECE(^LAB(60,T1,0),U),!
+3 SET LRT=T1
SET DIC="^LAB(62.07,"_LREC_",9,"
SET DIC(0)="AEZMNQ"
+4 FOR
if LREND
GOTO MORE
DO ^DIC
if Y<1
QUIT
if X=U
SET LREND=1
if LREND
QUIT
SET LRP=+Y
SET LRCODE=$PIECE(Y,U,2)
SET LRCNT=$SELECT($PIECE(Y(0),U,3):$PIECE(Y(0),U,3),1:1)
DO CNT
+5 KILL LRSTAR1,LRCNTD
MORE SET LREND=0
+1 QUIT
CNT ;
+1 Begin DoDot:1
+2 NEW DIR
+3 SET DIR(0)="NO^0:25:0"
SET DIR("A")=" MULTIPLY BY "
+4 IF $GET(LRCNT)
IF $GET(LRCNT)<26
SET DIR("B")=+$GET(LRCNT)
+5 SET DIR("?")=$$CJ^XLFSTR("to be used for this procedure.",IOM)
+6 SET DIR("?",1)=$$CJ^XLFSTR("Enter the WKLD CODE weight multiplier,",IOM)
+7 SET DIR("?",2)=$$CJ^XLFSTR("enter a number between 1 - 25",IOM)
+8 DO ^DIR
End DoDot:1
if $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+9 SET LRCNT=+Y
+10 IF LRCNT<1
WRITE !?5,"No workload added ",!
QUIT
CK if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT))
QUIT
if '$DATA(^(LRT,1,0))
SET ^(0)="^68.14P^"
SET NODE0=^(0)
SET LRADD=""
DO STUFE^LRCAPV1
KILL LRADD
+1 QUIT
QUE ;S X="?" D ^DIC G RD
END ;
+1 KILL DIC,T1,LRSTAR,LRADD
SET LREND=0
+2 QUIT
