- LRCAPV ;DALOI/FHS - DETERMINE WKLD CODE AND STUFF INTO 68 ;2/19/91 11:45
- ;;5.2;LAB SERVICE;**232**;Sep 27, 1994
- EN ;from LRVER4,LRVR4,LRMIEDZ,LRMIV,LROE,LRVER
- K LRCSQ,LRCSQQ S LREND=0 Q:'$P(LRPARAM,U,14)!('$D(LRAA)) Q:'$P($G(^LRO(68,+LRAA,0)),U,16) S LRCSQQ=+$P(^(0),U,20)
- I $D(LRCDEF),$D(LRCDEF0) W !!?7,"Currently you are using ( ",$P(LRCDEF0,U)_" ) Suffix ["_$P(LRCDEF0,U,2)_"]"
- W !! K DIC S:$G(LRLL) DIC("B")=$S($G(^LRO(68.2,+LRLL,"SUF")):$P(^(0),U),1:"")
- S LREND=0,DIC="^LRO(68.2,",DIC(0)="AQEM",DIC("A")="Work Load Area: ",DIC("S")="I $D(^(""SUF"")),+^(""SUF"")" D ^DIC S:Y<1 LREND=1 K DIC
- EN1 Q:$G(LREND)
- N LRSUFIEN,I
- S LRSUF0=^LRO(68.2,+Y,"SUF") D
- . S LRSUFIEN=$O(^LAB(64.2,"C",$P(LRSUF0,U,3)_" ",0))
- . Q:'LRSUFIEN S $P(LRUSUFO,U)=LRSUFIEN
- S LRCDEF0=$S($D(^LAB(64.2,+LRSUF0,0)):$P(^(0),U,1,18),1:0) S:LRCDEF0=0 LREND=1 G:$G(LREND) STOP S LRCDEF0(1)=$P(^(0),U,19),LRCDEF=$P($P(LRCDEF0,U,2),".",2)
- S I=0 F S I=$O(^LRO(68.2,+Y,4,I)) Q:I<.5 S LRCDEF(I)=""
- I '$P(LRSUF0,U,7) S $P(LRSUF0,U,7)=+LRAA,LRLD=$S($L($P($G(^LRO(68,LRAA,0)),U,19)):$P($G(^LRO(68,LRAA,0)),U,19),1:"CP"),LRCSQQ=+$P(^(0),U,20) K DIC
- S:'$P(LRSUF0,U,8) $P(LRSUFO,U,8)=+LRAA
- S LRCAPMS=$P(LRSUF0,U,7)_U_$S($P(LRSUF0,U,8):$P(LRSUF0,U,8),1:$P(LRSUF0,U,7)),LRCAPWA=$S($P(LRSUF0,U,9):$P(LRSUF0,U,9),1:$P(LRSUF0,U,8)),LRCAPMS=LRCAPMS_U_LRCAPWA
- I $G(LRCSQQ) S LRCSQ=$H,^XTMP("LRCAP",LRCSQ,DUZ)=""
- Q
- AUTO ;from LRVR
- Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+LRAA,0)),U,16)) S LRX=$G(^LRO(68,LRAA,0)),LRLD=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP") K LRX
- I $D(^LRO(68.2,LRLL,"SUF")),+^("SUF") S LRCDEF0=^("SUF"),LRP=+LRCDEF0,LRCDEF0=$S($D(^LAB(64.2,LRP,0)):^(0),1:0) I LRCDEF0 S LRCDEF=$P(LRCDEF0,U,2),LRCDEF0(1)=$P(^(0),U,19)
- G EN
- Q
- STD ;from LRVER,LRVER4,LRVR,LRVR4,LRVRW,LAMIAUTO,LRMIEDZ
- I $G(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) K ^XTMP("LRCAP",LRCSQ) G STDQ
- G:'$G(LRCSQ) STDQ
- S LRCSQQ=+$P($G(^LRO(68,+$G(LRAA),0)),U,20) I 'LRCSQQ,$G(LRCSQ) K ^XTMP("LRCAP",LRCSQ) G STDQ
- I '$P($G(LRPARAM),U,14) K:$G(LRCSQ) ^XTMP("LRCAP",LRCSQ) G STDQ
- W !!?10,"Wish to enter STD/QC/REPS " S %=2 D YN^DICN G:%=0 STD I %'=1 G STDQ
- S (LRREP,LRQC,LRSTD)=0
- ST R !!?10,"Number of standards this run ",LRSTD:DTIME G:'$T!(LRSTD="^") SQR G:$G(LRSTD)="^QC" @("QC") G:$G(LRSTD)="^REP" @("REP") I $G(LRSTD)'=0,$G(LRSTD)'="",'+$G(LRSTD) D MSG G ST
- QC R !!?10,"Number of QC this Run ",LRQC:DTIME G:'$T!($G(LRQC)="^") SQR G:$G(LRQC)="^STD" @("ST") G:$G(LRQC)="^REP" @("REP") I $G(LRQC)'=0,$G(LRQC)'="",'+$G(LRQC) D MSG G QC
- REP R !!,?10,"Number of Repeats ",LRREP:DTIME G:'$T!($G(LRREP)="^") SQR G:$G(LRREP)="^QC" @("QC") G:$G(LRREP)="^STD" @("ST") I LRREP'=0,LRREP'="",'+LRREP D MSG G REP
- SQR K LRTAGE,LRSUF0 I 'LRSTD&('LRQC)&('LRREP) G STDQ
- S LRDUZ=DUZ,ZTSAVE("LRDUZ")="",ZTSAVE("LRSTD")="",ZTSAVE("LRQC")="",ZTSAVE("DT")="",ZTSAVE("LRREP")="",ZTSAVE("LRCSQ")="",ZTSAVE("U")="",^XTMP("LRCAP",LRCSQ,DUZ)=LRSTD_"STD^"_LRQC_"QC^"_LRREP_"REPS^"
- S ZTRTN="QC^LRCAPPH",ZTIO="",ZTDTH=$H,ZTDESC="TALLY LAB QC/STD/REPS " D ^%ZTLOAD
- SQR1 S ZTRTN="LRCAPV2",ZTDTH=$H,ZTDESC="LAB WORKLOAD PROGRAM",ZTIO="" D ^%ZTLOAD
- K LRCSQ,LRCSQQ,LRSTD,LRQC,LRREP,LRDUZ
- Q
- STDQ K:$D(LRCSQ) ^XTMP("LRCAP",LRCSQ,DUZ) K LRCSQ,LRCSQQ
- ANN I $P($G(LRPARAM),U,14) S ZTIO="",ZTRTN="LRCAPV2",ZTDTH=$H,ZTDESC="LAB WORKLOAD PROGRAM" D ^%ZTLOAD
- K LRCSQ,LRCSQQ,LRSTD,LRQC,LRREP Q
- CON ;
- N J
- S J=0 F S J=$O(^LAB(60,+X,2,J)) Q:J<1 I $D(^(J,0)) S NODE=+^(0) I '$D(LRTEST(NODE)) S LRTEST(NODE)="",LRNT(LRNT)=NODE S:'$O(^LAB(60,NODE,2,0)) LRNT=LRNT+1
- Q
- ENCON ;
- N I
- I '$O(^LAB(60,+X,2,0)) S LRNT=1 Q
- K LRTEST,LRNT S LRNT=0 D CON S I=0 F S I=$O(LRNT(I)) Q:I="" S X=LRNT(I) D CON
- Q
- MSG W !!?10,"Enter a Number - Press Return or '^' to Stop " Q
- STOP ;
- S LREND=1 K LRCDEF,LRCDEF0,DIC,LRSUF0,LRCDEF,LRCDEF0X,LRLD,LRCAPMS,LRCAPWA,LRCSQ
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPV 3822 printed Jan 18, 2025@03:14:08 Page 2
- LRCAPV ;DALOI/FHS - DETERMINE WKLD CODE AND STUFF INTO 68 ;2/19/91 11:45
- +1 ;;5.2;LAB SERVICE;**232**;Sep 27, 1994
- EN ;from LRVER4,LRVR4,LRMIEDZ,LRMIV,LROE,LRVER
- +1 KILL LRCSQ,LRCSQQ
- SET LREND=0
- if '$PIECE(LRPARAM,U,14)!('$DATA(LRAA))
- QUIT
- if '$PIECE($GET(^LRO(68,+LRAA,0)),U,16)
- QUIT
- SET LRCSQQ=+$PIECE(^(0),U,20)
- +2 IF $DATA(LRCDEF)
- IF $DATA(LRCDEF0)
- WRITE !!?7,"Currently you are using ( ",$PIECE(LRCDEF0,U)_" ) Suffix ["_$PIECE(LRCDEF0,U,2)_"]"
- +3 WRITE !!
- KILL DIC
- if $GET(LRLL)
- SET DIC("B")=$SELECT($GET(^LRO(68.2,+LRLL,"SUF")):$PIECE(^(0),U),1:"")
- +4 SET LREND=0
- SET DIC="^LRO(68.2,"
- SET DIC(0)="AQEM"
- SET DIC("A")="Work Load Area: "
- SET DIC("S")="I $D(^(""SUF"")),+^(""SUF"")"
- DO ^DIC
- if Y<1
- SET LREND=1
- KILL DIC
- EN1 if $GET(LREND)
- QUIT
- +1 NEW LRSUFIEN,I
- +2 SET LRSUF0=^LRO(68.2,+Y,"SUF")
- Begin DoDot:1
- +3 SET LRSUFIEN=$ORDER(^LAB(64.2,"C",$PIECE(LRSUF0,U,3)_" ",0))
- +4 if 'LRSUFIEN
- QUIT
- SET $PIECE(LRUSUFO,U)=LRSUFIEN
- End DoDot:1
- +5 SET LRCDEF0=$SELECT($DATA(^LAB(64.2,+LRSUF0,0)):$PIECE(^(0),U,1,18),1:0)
- if LRCDEF0=0
- SET LREND=1
- if $GET(LREND)
- GOTO STOP
- SET LRCDEF0(1)=$PIECE(^(0),U,19)
- SET LRCDEF=$PIECE($PIECE(LRCDEF0,U,2),".",2)
- +6 SET I=0
- FOR
- SET I=$ORDER(^LRO(68.2,+Y,4,I))
- if I<.5
- QUIT
- SET LRCDEF(I)=""
- +7 IF '$PIECE(LRSUF0,U,7)
- SET $PIECE(LRSUF0,U,7)=+LRAA
- SET LRLD=$SELECT($LENGTH($PIECE($GET(^LRO(68,LRAA,0)),U,19)):$PIECE($GET(^LRO(68,LRAA,0)),U,19),1:"CP")
- SET LRCSQQ=+$PIECE(^(0),U,20)
- KILL DIC
- +8 if '$PIECE(LRSUF0,U,8)
- SET $PIECE(LRSUFO,U,8)=+LRAA
- +9 SET LRCAPMS=$PIECE(LRSUF0,U,7)_U_$SELECT($PIECE(LRSUF0,U,8):$PIECE(LRSUF0,U,8),1:$PIECE(LRSUF0,U,7))
- SET LRCAPWA=$SELECT($PIECE(LRSUF0,U,9):$PIECE(LRSUF0,U,9),1:$PIECE(LRSUF0,U,8))
- SET LRCAPMS=LRCAPMS_U_LRCAPWA
- +10 IF $GET(LRCSQQ)
- SET LRCSQ=$HOROLOG
- SET ^XTMP("LRCAP",LRCSQ,DUZ)=""
- +11 QUIT
- AUTO ;from LRVR
- +1 if '$PIECE(LRPARAM,U,14)!('$PIECE($GET(^LRO(68,+LRAA,0)),U,16))
- QUIT
- SET LRX=$GET(^LRO(68,LRAA,0))
- SET LRLD=$SELECT($LENGTH($PIECE(LRX,U,19)):$PIECE(LRX,U,19),1:"CP")
- KILL LRX
- +2 IF $DATA(^LRO(68.2,LRLL,"SUF"))
- IF +^("SUF")
- SET LRCDEF0=^("SUF")
- SET LRP=+LRCDEF0
- SET LRCDEF0=$SELECT($DATA(^LAB(64.2,LRP,0)):^(0),1:0)
- IF LRCDEF0
- SET LRCDEF=$PIECE(LRCDEF0,U,2)
- SET LRCDEF0(1)=$PIECE(^(0),U,19)
- +3 GOTO EN
- +4 QUIT
- STD ;from LRVER,LRVER4,LRVR,LRVR4,LRVRW,LAMIAUTO,LRMIEDZ
- +1 IF $GET(LRCSQ)
- IF '$ORDER(^XTMP("LRCAP",LRCSQ,DUZ,0))
- KILL ^XTMP("LRCAP",LRCSQ)
- GOTO STDQ
- +2 if '$GET(LRCSQ)
- GOTO STDQ
- +3 SET LRCSQQ=+$PIECE($GET(^LRO(68,+$GET(LRAA),0)),U,20)
- IF 'LRCSQQ
- IF $GET(LRCSQ)
- KILL ^XTMP("LRCAP",LRCSQ)
- GOTO STDQ
- +4 IF '$PIECE($GET(LRPARAM),U,14)
- if $GET(LRCSQ)
- KILL ^XTMP("LRCAP",LRCSQ)
- GOTO STDQ
- +5 WRITE !!?10,"Wish to enter STD/QC/REPS "
- SET %=2
- DO YN^DICN
- if %=0
- GOTO STD
- IF %'=1
- GOTO STDQ
- +6 SET (LRREP,LRQC,LRSTD)=0
- ST READ !!?10,"Number of standards this run ",LRSTD:DTIME
- if '$TEST!(LRSTD="^")
- GOTO SQR
- if $GET(LRSTD)="^QC"
- GOTO @("QC")
- if $GET(LRSTD)="^REP"
- GOTO @("REP")
- IF $GET(LRSTD)'=0
- IF $GET(LRSTD)'=""
- IF '+$GET(LRSTD)
- DO MSG
- GOTO ST
- QC READ !!?10,"Number of QC this Run ",LRQC:DTIME
- if '$TEST!($GET(LRQC)="^")
- GOTO SQR
- if $GET(LRQC)="^STD"
- GOTO @("ST")
- if $GET(LRQC)="^REP"
- GOTO @("REP")
- IF $GET(LRQC)'=0
- IF $GET(LRQC)'=""
- IF '+$GET(LRQC)
- DO MSG
- GOTO QC
- REP READ !!,?10,"Number of Repeats ",LRREP:DTIME
- if '$TEST!($GET(LRREP)="^")
- GOTO SQR
- if $GET(LRREP)="^QC"
- GOTO @("QC")
- if $GET(LRREP)="^STD"
- GOTO @("ST")
- IF LRREP'=0
- IF LRREP'=""
- IF '+LRREP
- DO MSG
- GOTO REP
- SQR KILL LRTAGE,LRSUF0
- IF 'LRSTD&('LRQC)&('LRREP)
- GOTO STDQ
- +1 SET LRDUZ=DUZ
- SET ZTSAVE("LRDUZ")=""
- SET ZTSAVE("LRSTD")=""
- SET ZTSAVE("LRQC")=""
- SET ZTSAVE("DT")=""
- SET ZTSAVE("LRREP")=""
- SET ZTSAVE("LRCSQ")=""
- SET ZTSAVE("U")=""
- SET ^XTMP("LRCAP",LRCSQ,DUZ)=LRSTD_"STD^"_LRQC_"QC^"_LRREP_"REPS^"
- +2 SET ZTRTN="QC^LRCAPPH"
- SET ZTIO=""
- SET ZTDTH=$HOROLOG
- SET ZTDESC="TALLY LAB QC/STD/REPS "
- DO ^%ZTLOAD
- SQR1 SET ZTRTN="LRCAPV2"
- SET ZTDTH=$HOROLOG
- SET ZTDESC="LAB WORKLOAD PROGRAM"
- SET ZTIO=""
- DO ^%ZTLOAD
- +1 KILL LRCSQ,LRCSQQ,LRSTD,LRQC,LRREP,LRDUZ
- +2 QUIT
- STDQ if $DATA(LRCSQ)
- KILL ^XTMP("LRCAP",LRCSQ,DUZ)
- KILL LRCSQ,LRCSQQ
- ANN IF $PIECE($GET(LRPARAM),U,14)
- SET ZTIO=""
- SET ZTRTN="LRCAPV2"
- SET ZTDTH=$HOROLOG
- SET ZTDESC="LAB WORKLOAD PROGRAM"
- DO ^%ZTLOAD
- +1 KILL LRCSQ,LRCSQQ,LRSTD,LRQC,LRREP
- QUIT
- CON ;
- +1 NEW J
- +2 SET J=0
- FOR
- SET J=$ORDER(^LAB(60,+X,2,J))
- if J<1
- QUIT
- IF $DATA(^(J,0))
- SET NODE=+^(0)
- IF '$DATA(LRTEST(NODE))
- SET LRTEST(NODE)=""
- SET LRNT(LRNT)=NODE
- if '$ORDER(^LAB(60,NODE,2,0))
- SET LRNT=LRNT+1
- +3 QUIT
- ENCON ;
- +1 NEW I
- +2 IF '$ORDER(^LAB(60,+X,2,0))
- SET LRNT=1
- QUIT
- +3 KILL LRTEST,LRNT
- SET LRNT=0
- DO CON
- SET I=0
- FOR
- SET I=$ORDER(LRNT(I))
- if I=""
- QUIT
- SET X=LRNT(I)
- DO CON
- +4 QUIT
- MSG WRITE !!?10,"Enter a Number - Press Return or '^' to Stop "
- QUIT
- STOP ;
- +1 SET LREND=1
- KILL LRCDEF,LRCDEF0,DIC,LRSUF0,LRCDEF,LRCDEF0X,LRLD,LRCAPMS,LRCAPWA,LRCSQ
- +2 QUIT