- 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 Feb 18, 2025@23:34:20 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
