- LRBLW ;AVAMC/REG - STUFF WORKLOAD IN 65 ;11/5/93 10:38
- ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q:'LRCAPA!('LRT) I '$D(LRCAPA(2))!('$D(LRCAPA(3))) D S
- S:'$D(^LRD(65,LRX,99,0)) ^(0)="^65.3PA^^" I '$D(^(LRT,0)) S ^(0)=LRT,X=^LRD(65,LRX,99,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
- S:'$D(^LRD(65,LRX,99,LRT,1,0)) ^(0)="^65.31DA^^" I '$D(^LRD(65,LRX,99,LRT,1,LRK,0)) S ^(0)=LRK_U_DUZ_U_DUZ(2)_U_LRCAPA(2)_U_LRCAPA(3),X=^LRD(65,LRX,99,LRT,1,0),^(0)=$P(X,U,1,2)_U_LRK_U_($P(X,U,4)+1)
- F C=0:0 S C=$O(LRT(C)) Q:'C D STF
- S ^LRD(65,"AA",LRX,LRT,LRK)=$P(^LRD(65,LRX,0),"^") I '$D(^LRD(65,LRX,99,LRT,1,LRK,1,0)) K ^LRD(65,LRX,99,LRT,1,LRK) S X=^LRD(65,LRX,99,LRT,1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
- Q
- STF I $D(^LRD(65,LRX,99,LRT,1,LRK,1,C,0)) S X=$P(^(0),"^",2) S:'X X=1 S X=X+1,$P(^(0),"^",2,3)=X_"^"_0 Q
- S:'$D(^LRD(65,LRX,99,LRT,1,LRK,1,0)) ^(0)="^65.311PA^^" S X=^(0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1),^(C,0)=C_"^"_1 Q
- ;
- RS S LRT=LRW("S") F A=0:0 S A=$O(LRW("S",A)) Q:'A S LRT(A)=""
- D DT^LRBLU,LRBLW K LRT Q
- ;
- S S X=$G(^LAB(69.9,1,8.1,DUZ(2),0)),LRCAPA(2)=$P(X,"^",2),LRCAPA(3)=$P(X,"^",3) Q
- ;
- EN ;from LRBLDX,LRBLDT
- W !,"Same date/time work completed for all entries " S %=2 D YN^LRU S:%=1 LRK("LRK")=1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLW 1372 printed Jan 18, 2025@03:13:09 Page 2
- LRBLW ;AVAMC/REG - STUFF WORKLOAD IN 65 ;11/5/93 10:38
- +1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 if 'LRCAPA!('LRT)
- QUIT
- IF '$DATA(LRCAPA(2))!('$DATA(LRCAPA(3)))
- DO S
- +4 if '$DATA(^LRD(65,LRX,99,0))
- SET ^(0)="^65.3PA^^"
- IF '$DATA(^(LRT,0))
- SET ^(0)=LRT
- SET X=^LRD(65,LRX,99,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
- +5 if '$DATA(^LRD(65,LRX,99,LRT,1,0))
- SET ^(0)="^65.31DA^^"
- IF '$DATA(^LRD(65,LRX,99,LRT,1,LRK,0))
- SET ^(0)=LRK_U_DUZ_U_DUZ(2)_U_LRCAPA(2)_U_LRCAPA(3)
- SET X=^LRD(65,LRX,99,LRT,1,0)
- SET ^(0)=$PIECE(X,U,1,2)_U_LRK_U_($PIECE(X,U,4)+1)
- +6 FOR C=0:0
- SET C=$ORDER(LRT(C))
- if 'C
- QUIT
- DO STF
- +7 SET ^LRD(65,"AA",LRX,LRT,LRK)=$PIECE(^LRD(65,LRX,0),"^")
- IF '$DATA(^LRD(65,LRX,99,LRT,1,LRK,1,0))
- KILL ^LRD(65,LRX,99,LRT,1,LRK)
- SET X=^LRD(65,LRX,99,LRT,1,0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
- +8 QUIT
- STF IF $DATA(^LRD(65,LRX,99,LRT,1,LRK,1,C,0))
- SET X=$PIECE(^(0),"^",2)
- if 'X
- SET X=1
- SET X=X+1
- SET $PIECE(^(0),"^",2,3)=X_"^"_0
- QUIT
- +1 if '$DATA(^LRD(65,LRX,99,LRT,1,LRK,1,0))
- SET ^(0)="^65.311PA^^"
- SET X=^(0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_($PIECE(X,"^",4)+1)
- SET ^(C,0)=C_"^"_1
- QUIT
- +2 ;
- RS SET LRT=LRW("S")
- FOR A=0:0
- SET A=$ORDER(LRW("S",A))
- if 'A
- QUIT
- SET LRT(A)=""
- +1 DO DT^LRBLU
- DO LRBLW
- KILL LRT
- QUIT
- +2 ;
- S SET X=$GET(^LAB(69.9,1,8.1,DUZ(2),0))
- SET LRCAPA(2)=$PIECE(X,"^",2)
- SET LRCAPA(3)=$PIECE(X,"^",3)
- QUIT
- +1 ;
- EN ;from LRBLDX,LRBLDT
- +1 WRITE !,"Same date/time work completed for all entries "
- SET %=2
- DO YN^LRU
- if %=1
- SET LRK("LRK")=1
- QUIT