- LRAPCWK ; IHS/DIR/FJE - STUFF CYTOPATH WORKLOAD 08:05 ; [ 8/3/94 ]
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- ASK W ! S %DT("A")="Date/time Specimen(s) Processed: " D W^LRAPWU I LRK<1 W $C(7),!!,"Processing workload not recorded. Is this what you want " S %=2 D YN^LRU Q:%<2 G ASK
- K A F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S A(A)=$P(^(A,0),"^",2)
- S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^" F A=0:0 S A=$O(A(A)) Q:'A S LRT=A(A) D:LRT STF,R
- Q
- R F C=0:0 S C=$O(^LAB(60,LRT,9.1,C)) Q:'C D CAP
- I $G(LRW("S")) S C=LRW("S") D CAP
- D SET F LRX=0:0 S LRX=$O(^LAB(60,LRT,2,LRX)) Q:'LRX S X(1)=+^(LRX,0),X(2)=$P($G(^LAB(60,X(1),0)),"^",19) I X(2),$D(^LAB(62.07,X(2),0)) S Y=$P(^(0),"^") D B
- Q
- CAP I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)) S ^(0)=C_"^1^0^0^^"_LRRC_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1) Q
- S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0),$P(X,"^",2)=$S($P(X,"^",3):1,1:$P(X,"^",2)+1),$P(X,"^",3)=0,^(0)=X Q
- ;
- B Q:'$D(LRZ(Y)) S LRO=LRT,LRO(1)=LRRC,LRRC=LRK,LRT=X(1) D STF F C=0:0 S C=$O(^LAB(60,LRT,9,C)) Q:'C D CAP
- D SET S LRT=LRO,LRRC=LRO(1),E=+LRZ(Y),Y(2)=$S($P(LRZ(Y),"^",4)]"":$P(LRZ(Y),"^",4),1:$E(Y,1,9)) S:'$D(^LR(LRDFN,LRSS,LRI,.1,A,E,0)) ^(0)="^"_$P(LRZ(Y),"^",2)_"^^" S B=$P(^(0),"^",3)+1
- G I $D(^LR(LRDFN,LRSS,LRI,.1,A,E,B,0)) S B=B+1 G G
- S F=^LR(LRDFN,LRSS,LRI,.1,A,E,0),^(0)=$P(F,"^",1,2)_"^"_B_"^"_($P(F,"^",4)+1),^(B,0)=Y(2)
- S:'$D(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,0)) ^(0)="^"_$P(LRZ(Y),"^",3)_"^^"
- F C=0:0 S C=$O(^LAB(60,X(1),2,C)) Q:'C S C(1)=^(C,0) D S
- Q
- S I '$D(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,+C(1),0)) S ^(0)=$P(C(1),"^",1,2),F=^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,0),^(0)=$P(F,"^",1,2)_"^"_+C(1)_"^"_($P(F,"^",4)+1) Q
- S F=^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,+C(1),0),$P(F,"^",2)=$P(F,"^",2)+$P(C(1),"^",2),^(0)=F Q
- ;
- STF I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRRC,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
- S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^" Q
- SET S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" Q
- ;
- CK I '$O(^LR(LRDFN,LRSS,LRI,.1,0)) S Y=1 W !!,"No SPECIMEN entered." G OUT
- K A S A=0 F B=1:1 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S X=$P(^(A,0),"^",2) S:X'=+X X=0 I '$D(^LAB(60,X,0)) S $P(^LR(LRDFN,LRSS,LRI,.1,A,0),U,2)="" W:B=1 ! W !,"WORKLOAD PROFILE NOT ENTERED FOR ",$P(^(0),U) S Y=1
- OUT Q
- C ;from LRAPDA
- S LRK=1,C=0 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A!(C) F B=0:0 S B=$O(^(A,B)) Q:'B S C=1
- Q:C D EN^LRAPST,ASK Q
- LRAPCWK ; IHS/DIR/FJE - STUFF CYTOPATH WORKLOAD 08:05 ; [ 8/3/94 ]
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- ASK WRITE !
- SET %DT("A")="Date/time Specimen(s) Processed: "
- DO W^LRAPWU
- IF LRK<1
- WRITE $CHAR(7),!!,"Processing workload not recorded. Is this what you want "
- SET %=2
- DO YN^LRU
- IF %<2
- QUIT
- GOTO ASK
- +1 KILL A
- FOR A=0:0
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
- IF 'A
- QUIT
- SET A(A)=$PIECE(^(A,0),"^",2)
- +2 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
- SET ^(0)="^68.04PA^^"
- FOR A=0:0
- SET A=$ORDER(A(A))
- IF 'A
- QUIT
- SET LRT=A(A)
- IF LRT
- DO STF
- DO R
- +3 QUIT
- R FOR C=0:0
- SET C=$ORDER(^LAB(60,LRT,9.1,C))
- IF 'C
- QUIT
- DO CAP
- +1 IF $GET(LRW("S"))
- SET C=LRW("S")
- DO CAP
- +2 DO SET
- FOR LRX=0:0
- SET LRX=$ORDER(^LAB(60,LRT,2,LRX))
- IF 'LRX
- QUIT
- SET X(1)=+^(LRX,0)
- SET X(2)=$PIECE($GET(^LAB(60,X(1),0)),"^",19)
- IF X(2)
- IF $DATA(^LAB(62.07,X(2),0))
- SET Y=$PIECE(^(0),"^")
- DO B
- +3 QUIT
- CAP IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0))
- SET ^(0)=C_"^1^0^0^^"_LRRC_"^"_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)_"^"_C_"^"_($PIECE(X,"^",4)+1)
- QUIT
- +1 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)
- SET $PIECE(X,"^",2)=$SELECT($PIECE(X,"^",3):1,1:$PIECE(X,"^",2)+1)
- SET $PIECE(X,"^",3)=0
- SET ^(0)=X
- QUIT
- +2 ;
- B IF '$DATA(LRZ(Y))
- QUIT
- SET LRO=LRT
- SET LRO(1)=LRRC
- SET LRRC=LRK
- SET LRT=X(1)
- DO STF
- FOR C=0:0
- SET C=$ORDER(^LAB(60,LRT,9,C))
- IF 'C
- QUIT
- DO CAP
- +1 DO SET
- SET LRT=LRO
- SET LRRC=LRO(1)
- SET E=+LRZ(Y)
- SET Y(2)=$SELECT($PIECE(LRZ(Y),"^",4)]"":$PIECE(LRZ(Y),"^",4),1:$EXTRACT(Y,1,9))
- IF '$DATA(^LR(LRDFN,LRSS,LRI,.1,A,E,0))
- SET ^(0)="^"_$PIECE(LRZ(Y),"^",2)_"^^"
- SET B=$PIECE(^(0),"^",3)+1
- G IF $DATA(^LR(LRDFN,LRSS,LRI,.1,A,E,B,0))
- SET B=B+1
- GOTO G
- +1 SET F=^LR(LRDFN,LRSS,LRI,.1,A,E,0)
- SET ^(0)=$PIECE(F,"^",1,2)_"^"_B_"^"_($PIECE(F,"^",4)+1)
- SET ^(B,0)=Y(2)
- +2 IF '$DATA(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,0))
- SET ^(0)="^"_$PIECE(LRZ(Y),"^",3)_"^^"
- +3 FOR C=0:0
- SET C=$ORDER(^LAB(60,X(1),2,C))
- IF 'C
- QUIT
- SET C(1)=^(C,0)
- DO S
- +4 QUIT
- S IF '$DATA(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,+C(1),0))
- SET ^(0)=$PIECE(C(1),"^",1,2)
- SET F=^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,0)
- SET ^(0)=$PIECE(F,"^",1,2)_"^"_+C(1)_"^"_($PIECE(F,"^",4)+1)
- QUIT
- +1 SET F=^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,+C(1),0)
- SET $PIECE(F,"^",2)=$PIECE(F,"^",2)+$PIECE(C(1),"^",2)
- SET ^(0)=F
- QUIT
- +2 ;
- STF IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
- SET ^(0)=LRT_"^50^^"_DUZ_"^"_LRRC
- SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
- +1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))
- SET ^(0)="^68.14P^^"
- QUIT
- SET SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
- QUIT
- +1 ;
- CK IF '$ORDER(^LR(LRDFN,LRSS,LRI,.1,0))
- SET Y=1
- WRITE !!,"No SPECIMEN entered."
- GOTO OUT
- +1 KILL A
- SET A=0
- FOR B=1:1
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
- IF 'A
- QUIT
- SET X=$PIECE(^(A,0),"^",2)
- IF X'=+X
- SET X=0
- IF '$DATA(^LAB(60,X,0))
- SET $PIECE(^LR(LRDFN,LRSS,LRI,.1,A,0),U,2)=""
- IF B=1
- WRITE !
- WRITE !,"WORKLOAD PROFILE NOT ENTERED FOR ",$PIECE(^(0),U)
- SET Y=1
- OUT QUIT
- C ;from LRAPDA
- +1 SET LRK=1
- SET C=0
- FOR A=0:0
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
- IF 'A!(C)
- QUIT
- FOR B=0:0
- SET B=$ORDER(^(A,B))
- IF 'B
- QUIT
- SET C=1
- +2 IF C
- QUIT
- DO EN^LRAPST
- DO ASK
- QUIT
