LRAPSWK ;AVAMC/REG - STUFF AP WORKLOAD ;2/22/96 10:27
;;5.2;LAB SERVICE;**91**;Sep 27, 1994
S LRK=LRRC S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^" D STF
I "SPEM"[LRSS S A(1)=0 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S A(1)=A(1)+1,A(2)=$E($P(^(A,0),"^"),1,9) D @(LRSS_1)
I "SPCYEM"[LRSS,$G(LRW("S")) S C=LRW("S") D CAP
D:LRSS="AU" AU1 S A(1)=1 F C=0:0 S C=$O(^LAB(60,LRT,9,C)) Q:'C D CAP
S A(1)=1 F C=0:0 S C=$O(^LAB(60,LRT,9.1,C)) Q:'C D CAP
S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
Q
;
SP1 S ^LR(LRDFN,"SP",LRI,.1,A,1,0)="^63.8121A^1^1",^(1,0)=A(2),^(1,0)="^63.8122PA^"_LRW("H&E")_"^1",^(LRW("H&E"),0)=LRW("H&E")_"^1" S:A(2)]"" ^LR(LRDFN,"SP",LRI,.1,A,1,"B",A(2),1)="" Q
EM1 S ^LR(LRDFN,"EM",LRI,.1,A,1,0)="^63.2021A^1^1",^(1,0)="EPON 1",^(1,0)="^63.20211PA^"_+LRW("G")_"^2",^(+LRW("SS"),0)=LRW("SS")
S ^LR(LRDFN,"EM",LRI,.1,A,1,1,1,+LRW("G"),0)=LRW("G"),^LR(LRDFN,"EM",LRI,.1,A,1,"B","EPON 1",1)="" Q
AU1 K E I $O(^LRO(69.2,LRAA,6,0)) S E=0 F A=0:0 S A=$O(^LRO(69.2,LRAA,6,A)) Q:'A S B=$P(^(A,0),"^") I B]"" S E=E+1,^LR(LRDFN,33,E,0)=B,^LR(LRDFN,33,"B",B,E)="" D AU2
S:$D(E) ^LR(LRDFN,33,0)="^63.033A^"_E_"^"_E Q
AU2 S ^LR(LRDFN,33,E,1,0)="^63.331A^1^1",^(1,0)=$E(B,1,9),^(1,0)="^63.3311PA^"_LRW("H&E")_"^1",^(LRW("H&E"),0)=LRW("H&E")_"^1" 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
;
CAP I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)) S ^(0)=C_"^"_A(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):A(1),1:$P(X,"^",2)+A(1)),$P(X,"^",3)=0,^(0)=X Q
;
SP S X="SURGICAL PATHOLOGY LOG-IN" D A^LRUWK Q:'$D(X) S (LRW("S"),X)=$O(^LAM("E","88000.0000",0)) Q:X S X="SP SPECIMEN",Y="88000.0000" D W^LRUWK Q
CY S LRT="",(LRW("S"),X)=$O(^LAM("E","88056.0000",0)) Q:X S X="CY Specimen",Y="88056.0000" D W^LRUWK Q
EM S LRW("S")=$O(^LAM("E","88057.0000",0)),X="EM LOG-IN" D A^LRUWK Q:$D(X) S X="EM Specimen",Y="88057.0000" D W^LRUWK Q
AU S X="AUTOPSY LOG-IN" D A^LRUWK Q
;
CK I '$O(^LR(LRDFN,LRSS,LRI,.1,0)) S Y=1 W !!,"No SPECIMEN entered." G OUT
S A=0 F B=1:1 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S X=^(A,0) I '$P(X,"^",2) W:B=1 ! W !,"WORKLOAD PROFILE NOT ENTERED FOR ",$P(X,U) S Y=1
;
C ;count number of specimens, called by LRAPED,LRAPDA,LRAPM
K LRL,LRN S LRM=0
D S LRL=0 F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S LRL=LRL+1 I LRSS="CY",'LRM S X=^(A,0),B=$P(X,"^",2) I B S:'$D(LRN(B)) LRN(B)=0 S LRN(B)=LRN(B)+1
Q
C1 ; Workload code count update SURG PATH, CYTO or EM specimens
I "EM"[LRSS,$G(LRSOP)="Z" Q
Q:'LRW("S") S LRL(1)=LRL,LRM=1 D D Q:LRL'>LRL(1) S A(1)=LRL-LRL(1) I LRSS'="CY" D STF1,SET Q
K LRL F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A S X=^(A,0),B=$P(X,"^",2) I B S:'$D(LRL(B)) LRL(B)=0 S LRL(B)=LRL(B)+1
S LRT=0 F S LRT=$O(LRL(LRT)) Q:'LRT S LRL=LRL(LRT) S A(1)=LRL(LRT)-$G(LRN(LRT)) D:A(1)>0 STF1,SET
Q
SET S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
Q
;
STF1 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRRC
S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^"
S 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^^" S C=LRW("S")
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)) S X=^(0) N LRTALLY D
. S LRTALLY=$P(X,U,4)
. S A(1)=LRL-LRTALLY
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)) S ^(0)=C_"^"_A(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),Y=$P(X,"^",2) S Y=Y+A(1),$P(X,"^",2)=Y,^(0)=X Q
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^"_A(1)_"^"_"0"_"^"_LRTALLY_"^^"_LRRC_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA Q
;
OUT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSWK 4121 printed Dec 13, 2024@02:08:26 Page 2
LRAPSWK ;AVAMC/REG - STUFF AP WORKLOAD ;2/22/96 10:27
+1 ;;5.2;LAB SERVICE;**91**;Sep 27, 1994
+2 SET LRK=LRRC
if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
SET ^(0)="^68.04PA^^"
DO STF
+3 IF "SPEM"[LRSS
SET A(1)=0
FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
if 'A
QUIT
SET A(1)=A(1)+1
SET A(2)=$EXTRACT($PIECE(^(A,0),"^"),1,9)
DO @(LRSS_1)
+4 IF "SPCYEM"[LRSS
IF $GET(LRW("S"))
SET C=LRW("S")
DO CAP
+5 if LRSS="AU"
DO AU1
SET A(1)=1
FOR C=0:0
SET C=$ORDER(^LAB(60,LRT,9,C))
if 'C
QUIT
DO CAP
+6 SET A(1)=1
FOR C=0:0
SET C=$ORDER(^LAB(60,LRT,9.1,C))
if 'C
QUIT
DO CAP
+7 SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+8 QUIT
+9 ;
SP1 SET ^LR(LRDFN,"SP",LRI,.1,A,1,0)="^63.8121A^1^1"
SET ^(1,0)=A(2)
SET ^(1,0)="^63.8122PA^"_LRW("H&E")_"^1"
SET ^(LRW("H&E"),0)=LRW("H&E")_"^1"
if A(2)]""
SET ^LR(LRDFN,"SP",LRI,.1,A,1,"B",A(2),1)=""
QUIT
EM1 SET ^LR(LRDFN,"EM",LRI,.1,A,1,0)="^63.2021A^1^1"
SET ^(1,0)="EPON 1"
SET ^(1,0)="^63.20211PA^"_+LRW("G")_"^2"
SET ^(+LRW("SS"),0)=LRW("SS")
+1 SET ^LR(LRDFN,"EM",LRI,.1,A,1,1,1,+LRW("G"),0)=LRW("G")
SET ^LR(LRDFN,"EM",LRI,.1,A,1,"B","EPON 1",1)=""
QUIT
AU1 KILL E
IF $ORDER(^LRO(69.2,LRAA,6,0))
SET E=0
FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,6,A))
if 'A
QUIT
SET B=$PIECE(^(A,0),"^")
IF B]""
SET E=E+1
SET ^LR(LRDFN,33,E,0)=B
SET ^LR(LRDFN,33,"B",B,E)=""
DO AU2
+1 if $DATA(E)
SET ^LR(LRDFN,33,0)="^63.033A^"_E_"^"_E
QUIT
AU2 SET ^LR(LRDFN,33,E,1,0)="^63.331A^1^1"
SET ^(1,0)=$EXTRACT(B,1,9)
SET ^(1,0)="^63.3311PA^"_LRW("H&E")_"^1"
SET ^(LRW("H&E"),0)=LRW("H&E")_"^1"
QUIT
+1 ;
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
+2 ;
CAP IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0))
SET ^(0)=C_"^"_A(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):A(1),1:$PIECE(X,"^",2)+A(1))
SET $PIECE(X,"^",3)=0
SET ^(0)=X
QUIT
+2 ;
SP SET X="SURGICAL PATHOLOGY LOG-IN"
DO A^LRUWK
if '$DATA(X)
QUIT
SET (LRW("S"),X)=$ORDER(^LAM("E","88000.0000",0))
if X
QUIT
SET X="SP SPECIMEN"
SET Y="88000.0000"
DO W^LRUWK
QUIT
CY SET LRT=""
SET (LRW("S"),X)=$ORDER(^LAM("E","88056.0000",0))
if X
QUIT
SET X="CY Specimen"
SET Y="88056.0000"
DO W^LRUWK
QUIT
EM SET LRW("S")=$ORDER(^LAM("E","88057.0000",0))
SET X="EM LOG-IN"
DO A^LRUWK
if $DATA(X)
QUIT
SET X="EM Specimen"
SET Y="88057.0000"
DO W^LRUWK
QUIT
AU SET X="AUTOPSY LOG-IN"
DO A^LRUWK
QUIT
+1 ;
CK IF '$ORDER(^LR(LRDFN,LRSS,LRI,.1,0))
SET Y=1
WRITE !!,"No SPECIMEN entered."
GOTO OUT
+1 SET A=0
FOR B=1:1
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
if 'A
QUIT
SET X=^(A,0)
IF '$PIECE(X,"^",2)
if B=1
WRITE !
WRITE !,"WORKLOAD PROFILE NOT ENTERED FOR ",$PIECE(X,U)
SET Y=1
+2 ;
C ;count number of specimens, called by LRAPED,LRAPDA,LRAPM
+1 KILL LRL,LRN
SET LRM=0
D SET LRL=0
FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
if 'A
QUIT
SET LRL=LRL+1
IF LRSS="CY"
IF 'LRM
SET X=^(A,0)
SET B=$PIECE(X,"^",2)
IF B
if '$DATA(LRN(B))
SET LRN(B)=0
SET LRN(B)=LRN(B)+1
+1 QUIT
C1 ; Workload code count update SURG PATH, CYTO or EM specimens
+1 IF "EM"[LRSS
IF $GET(LRSOP)="Z"
QUIT
+2 if 'LRW("S")
QUIT
SET LRL(1)=LRL
SET LRM=1
DO D
if LRL'>LRL(1)
QUIT
SET A(1)=LRL-LRL(1)
IF LRSS'="CY"
DO STF1
DO SET
QUIT
+3 KILL LRL
FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))
if 'A
QUIT
SET X=^(A,0)
SET B=$PIECE(X,"^",2)
IF B
if '$DATA(LRL(B))
SET LRL(B)=0
SET LRL(B)=LRL(B)+1
+4 SET LRT=0
FOR
SET LRT=$ORDER(LRL(LRT))
if 'LRT
QUIT
SET LRL=LRL(LRT)
SET A(1)=LRL(LRT)-$GET(LRN(LRT))
if A(1)>0
DO STF1
DO SET
+5 QUIT
SET SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+1 QUIT
+2 ;
STF1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
SET ^(0)=LRT_"^50^^"_DUZ_"^"_LRRC
+1 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
SET ^(0)="^68.04PA^^"
+2 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
+3 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))
SET ^(0)="^68.14P^^"
SET C=LRW("S")
+4 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0))
SET X=^(0)
NEW LRTALLY
Begin DoDot:1
+5 SET LRTALLY=$PIECE(X,U,4)
+6 SET A(1)=LRL-LRTALLY
End DoDot:1
+7 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0))
SET ^(0)=C_"^"_A(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
+8 ;S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0),Y=$P(X,"^",2) S Y=Y+A(1),$P(X,"^",2)=Y,^(0)=X Q
+9 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^"_A(1)_"^"_"0"_"^"_LRTALLY_"^^"_LRRC_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
QUIT
+10 ;
OUT QUIT
