- LRUTT ;AVAMC/REG/CYM - LAB TEST TURNAROUND TIME; 17-Oct-2014 09:22 ; MKK
- ;;5.2;LAB SERVICE;**153,1018,354,1031,1032,1034**;NOV 1, 1997;Build 88
- ;
- D END W !!?24,"Laboratory Test Turnaround Times"
- AT S DIC=60,DIC(0)="AEQM" D ^DIC K DIC I Y>0 S LRT(+Y)=$P(Y,U,2) G AT
- I '$D(LRT) W $C(7),!,"NO TESTS SELECTED" G END
- HL W ! S LRL="",INSTFLAG=0 K DIR S DIR("?",1)="Select an entry from the HOSPITAL LOCATION file (#44) or an entry from",DIR("?",2)="the INSTITUTION file (#4).",DIR("?",3)=""
- S DIR("?",4)="To specify a selection from the HOSPITAL LOCATION file (#44), enter your",DIR("?",5)="selection with the 'L.' prefix. Enter 'L.?' to see the list of entries in",DIR("?",6)="the HOSPITAL LOCATION file (#44)."
- S DIR("?",7)="",DIR("?",8)="To specify a selection from the INSTITUTION file (#4), enter your selection",DIR("?",9)="with the 'I.' prefix. Enter 'I.?' to see the list of entries in the",DIR("?",10)="INSTITUTION file (#4)."
- S DIR("?",11)="",DIR("?",12)="If the selection entered does not have the 'L.' or 'I.' prefix, the HOSPITAL",DIR("?",13)="LOCATION file (#44) will be searched for a match first. If no match is"
- S DIR("?")="found, the INSTITUTION file (#4) will then be searched for a match."
- S DIR("A")="Select HOSPITAL LOCATION NAME: ",DIR(0)="FOA" D ^DIR I $D(DIRUT) G END
- S LRY=Y D LOC I LRL="" G HL
- W ! D B^LRU G:Y<0 END S LRSDT=LRSDT-.1,LRLDT=LRLDT+.9
- W !!,"Print patients " S %=2 D YN^LRU S:%=1 LRI=1
- S ZTRTN="QUE^LRUTT" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) D L^LRU,S^LRU,H S LR("F")=1 F A=0:0 S A=$O(LRT(A)) Q:'A S (LRG(A),LRH(A))=0
- F LRA=LRSDT:0 S LRA=$O(^LRO(69,LRA)) Q:'LRA!(LRA>LRLDT) D
- . I 'INSTFLAG D
- . . F LRB=0:0 S LRB=$O(^LRO(69,LRA,1,"AC",LRL,LRB)) Q:'LRB F T=0:0 S T=$O(^LRO(69,LRA,1,LRB,2,"B",T)) Q:'T D:$D(LRT(T)) C
- . I INSTFLAG D
- . . S XLRL="" F S XLRL=$O(^LRO(69,LRA,1,"AC",XLRL)) Q:XLRL="" I $$INSTHIT(XLRL) F LRB=0:0 S LRB=$O(^LRO(69,LRA,1,"AC",XLRL,LRB)) Q:'LRB F T=0:0 S T=$O(^LRO(69,LRA,1,LRB,2,"B",T)) Q:'T D:$D(LRT(T)) C
- F A=0:0 S A=$O(LRT(A)) Q:'A!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !,LRT(A),?30,"Count: ",$J(LRH(A),5),?45,"Average time:" I LRG(A) S X=LRG(A)\LRH(A),Y=X\60,X=X#60 W:Y $J(Y,3)," hr" W:X ?65,$J(X,2)," min"
- ; F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=^LR(A,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)") S ^TMP($J,"B",$P(X,"^"),A)=$P(X,"^",9)
- ; W ! S LRP=0 F Q=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F A=0:0 S A=$O(^TMP($J,"B",LRP,A)) Q:'A!(LR("Q")) S SSN=^(A),LRDPF=$P(^LR(A,0),U,2) D SSN^LRU D:$Y>(IOSL-6) H Q:LR("Q") W !,LRP,?31,SSN D L
- ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 modifications
- ; F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=^LR(A,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),HRCN=$S($P($G(^AUPNPAT(+$G(Y),41,+$G(DUZ(2)),0)),"^",2):$P(^(0),"^",2),1:"??") S ^TMP($J,"B",$P(X,"^"),A)=HRCN ;IHS/ANMC/CLS 08/18/96
- ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
- F A=0:0 S A=$O(^TMP($J,A)) Q:'A D
- . S X=$G(^LR(A,0))
- . Q:$L(X)<1
- . S Y=$P(X,"^",3)
- . S X=$P(X,"^",2)
- . S X=^DIC(X,0,"GL")
- . S X=@(X_Y_",0)")
- . S HRCN=$S($P($G(^AUPNPAT(+$G(Y),41,+$G(DUZ(2)),0)),"^",2):$P($G(^(0)),"^",2),1:"??")
- . S ^TMP($J,"B",$P(X,"^"),A)=HRCN ; Naked Reference Fix
- ; ----- END IHS/MSC/MKK - LR*5.2*1034
- W ! S LRP=0 F Q=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F A=0:0 S A=$O(^TMP($J,"B",LRP,A)) Q:'A!(LR("Q")) S HRCN=^(A),LRDPF=$P(^LR(A,0),U,2) D SSN^LRU D:$Y>(IOSL-6) H Q:LR("Q") W !,LRP,?31,HRCN D L ;IHS/ANMC/CLS
- ; ----- END IHS/MSC/MKK - LR*5.2*1031
- D END^LRUTL,END Q
- T S V=$P(X,".",2)_"000",V=$E(V,1,2)*60+$E(V,3,4) D H^%DTC S X=%H_"."_$E("0000",1,4-$L(V))_V Q
- L F T=0:0 S T=$O(^TMP($J,A,T)) Q:'T!(LR("Q")) F B=0:0 S B=$O(^TMP($J,A,T,B)) Q:'B!(LR("Q")) F C=0:0 S C=$O(^TMP($J,A,T,B,C)) Q:'C!(LR("Q")) F E=0:0 S E=$O(^TMP($J,A,T,B,C,E)) Q:'E!(LR("Q")) D W
- K T,B,C,E
- Q
- W D:$Y>(IOSL-6) H1 Q:LR("Q")
- ; W !?3,LRT(T),?32,$$Y2K^LRX(B,"5D"),?44 S X(1)=^TMP($J,A,T,B,C,E),X=+X(1),Y=X\60,X=X#60 W:Y $J(Y,3)," hr" W:X ?50,$J(X,2)," min" W ?60,"Arr time:" S X=$P(X(1),"^",2) W $E(X,1,2)_":"_$E(X,3,4) Q
- ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 modifications
- W !?3,LRT(T),?33,$$Y2K^LRX(B,"5D"),?44 S X(1)=^TMP($J,A,T,B,C,E),X=+X(1),Y=X\60,X=X#60 W:Y $J(Y,3)," hr" W:X ?50,$J(X,2)," min" W ?60,"Arr time:" S X=$P(X(1),"^",2) W $E(X,1,2)_":"_$E(X,3,4) Q ;IHS/ANMC/CLS 08/18/96
- ; ----- END IHS/MSC/MKK - LR*5.2*1031
- ;
- C S E=$O(^LRO(69,LRA,1,LRB,2,"B",T,0)),LRS=$S($D(^LRO(69,LRA,1,LRB,3)):+^(3),1:0),E=$S($D(^(2,E,0)):^(0),1:""),W=$P(E,"^",4),LRC=$P(E,"^",3),LRX=$P(E,"^",5)
- I $P(E,"^",11)'="" Q
- I $$CANCEL Q
- ; I LRS,W,LRC,LRX,$D(^LRO(68,W,1,LRC,1,LRX,4,T,0)) S X=$P(^(0),"^",5) Q:X'["." Q:$P(^(0),"^",8)="" D T S LRF=X D S
- I LRS,W,LRC,LRX,$D(^LRO(68,W,1,LRC,1,LRX,4,T,0)) S X=$P(^(0),"^",5) Q:X'["." D T S LRF=X D S ; IHS/MSC/MKK - LR*5.2*1032 -- Do *NOT* check for the WKLD SUFFIX in file 68
- Q
- S S (LRS(1),X)=LRS D T S LRS=X,LRDFN=+^LRO(68,W,1,LRC,1,LRX,0) S X=$P(LRF,".")-$P(LRS,".") S:X X=X*1440 S LRT=X+$P(LRF,".",2)-$P(LRS,".",2)
- S LRG(T)=LRG(T)+LRT,LRH(T)=LRH(T)+1 S:$D(LRI) ^TMP($J,LRDFN,T,LRA,W,LRX)=LRT_"^"_$P(LRS(1),".",2)_"000" Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"Location: ",LRL,!,"Laboratory test turnaround times from: ",LRSTR," to ",LRLST,!,LR("%") Q
- ;
- H1 ; D H Q:LR("Q") W !,LRP,?31,SSN Q
- ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 modifications
- D H Q:LR("Q") W !,LRP,?31,HRCN Q
- ; ----- END IHS/MSC/MKK - LR*5.2*1031
- ;
- END D V^LRU K INSTFLAG,XLRL Q
- LOC ; check file 44 for location entered
- I $E(LRY,1,2)="L."!($E(LRY,1,2)="l.") S LRY=$E(LRY,3,99) D HLOC Q
- I $E(LRY,1,2)="I."!($E(LRY,1,2)="i.") S LRY=$E(LRY,3,99) D INST Q
- D HLOC I Y<1 D INST
- Q
- HLOC S X=LRY,DIC=44,DIC(0)="EMZ" D ^DIC K DIC I Y'<1 S LRL=$P(Y(0),U,2) I LRL="" W $C(7),!!,"There must be an abbreviation entered for the hospital location!"
- Q
- INST ; check file 4 for location entered
- S X=LRY,DIC=4,DIC(0)="EQMZ",DIC("S")="I $G(^DIC(4,Y,99))" D ^DIC K DIC I Y'<1 S LRL=$P(Y(0),"^"),INSTFLAG=1
- Q
- INSTHIT(XLOC) ;
- N HIT,LOCNUM,INSTNUM,X99
- S HIT=0
- S LOCNUM=$O(^SC("C",XLOC,0))
- I LOCNUM'="" D
- . S INSTNUM=$P($G(^SC(LOCNUM,0)),U,4)
- . Q:INSTNUM=""
- . I $D(^DIC(4,"B",LRL,INSTNUM)) D
- . . S X99=$G(^DIC(4,INSTNUM,99))
- . . Q:X99=""
- . . I $P(X99,U,4) Q
- . . S HIT=1
- Q HIT
- CANCEL() ;
- ; This function checks to see if a test was cancelled.
- ; If the test was cancelled the function evaluates as "true".
- N CANFLAG,COLTIME,LRTIME,LRID,TESTNUM,LR63,PC1
- S CANFLAG=0
- S COLTIME=$P($G(^LRO(69,LRA,1,LRB,1)),"^",1)
- I COLTIME D
- . S LRTIME=9999999-COLTIME
- . S LRID=$P($G(^LRO(69,LRA,1,LRB,0)),"^",1)
- . I LRID="" Q
- . S TESTNUM=$G(^LAB(60,T,.2))
- . I TESTNUM="" Q
- . S LR63=$G(^LR(LRID,"CH",LRTIME,TESTNUM))
- . I LR63="" Q
- . S PC1=$P(LR63,"^",1)
- . I PC1="" Q
- . I $E(PC1,1,$L(PC1))=$E("CANCELLED",1,$L(PC1))!($E(PC1,1,$L(PC1))=$E("cancelled",1,$L(PC1))) S CANFLAG=1
- Q CANFLAG
- LRUTT ;AVAMC/REG/CYM - LAB TEST TURNAROUND TIME; 17-Oct-2014 09:22 ; MKK
- +1 ;;5.2;LAB SERVICE;**153,1018,354,1031,1032,1034**;NOV 1, 1997;Build 88
- +2 ;
- +3 DO END
- WRITE !!?24,"Laboratory Test Turnaround Times"
- AT SET DIC=60
- SET DIC(0)="AEQM"
- DO ^DIC
- KILL DIC
- IF Y>0
- SET LRT(+Y)=$PIECE(Y,U,2)
- GOTO AT
- +1 IF '$DATA(LRT)
- WRITE $CHAR(7),!,"NO TESTS SELECTED"
- GOTO END
- HL WRITE !
- SET LRL=""
- SET INSTFLAG=0
- KILL DIR
- SET DIR("?",1)="Select an entry from the HOSPITAL LOCATION file (#44) or an entry from"
- SET DIR("?",2)="the INSTITUTION file (#4)."
- SET DIR("?",3)=""
- +1 SET DIR("?",4)="To specify a selection from the HOSPITAL LOCATION file (#44), enter your"
- SET DIR("?",5)="selection with the 'L.' prefix. Enter 'L.?' to see the list of entries in"
- SET DIR("?",6)="the HOSPITAL LOCATION file (#44)."
- +2 SET DIR("?",7)=""
- SET DIR("?",8)="To specify a selection from the INSTITUTION file (#4), enter your selection"
- SET DIR("?",9)="with the 'I.' prefix. Enter 'I.?' to see the list of entries in the"
- SET DIR("?",10)="INSTITUTION file (#4)."
- +3 SET DIR("?",11)=""
- SET DIR("?",12)="If the selection entered does not have the 'L.' or 'I.' prefix, the HOSPITAL"
- SET DIR("?",13)="LOCATION file (#44) will be searched for a match first. If no match is"
- +4 SET DIR("?")="found, the INSTITUTION file (#4) will then be searched for a match."
- +5 SET DIR("A")="Select HOSPITAL LOCATION NAME: "
- SET DIR(0)="FOA"
- DO ^DIR
- IF $DATA(DIRUT)
- GOTO END
- +6 SET LRY=Y
- DO LOC
- IF LRL=""
- GOTO HL
- +7 WRITE !
- DO B^LRU
- IF Y<0
- GOTO END
- SET LRSDT=LRSDT-.1
- SET LRLDT=LRLDT+.9
- +8 WRITE !!,"Print patients "
- SET %=2
- DO YN^LRU
- IF %=1
- SET LRI=1
- +9 SET ZTRTN="QUE^LRUTT"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- DO L^LRU
- DO S^LRU
- DO H
- SET LR("F")=1
- FOR A=0:0
- SET A=$ORDER(LRT(A))
- IF 'A
- QUIT
- SET (LRG(A),LRH(A))=0
- +1 FOR LRA=LRSDT:0
- SET LRA=$ORDER(^LRO(69,LRA))
- IF 'LRA!(LRA>LRLDT)
- QUIT
- Begin DoDot:1
- +2 IF 'INSTFLAG
- Begin DoDot:2
- +3 FOR LRB=0:0
- SET LRB=$ORDER(^LRO(69,LRA,1,"AC",LRL,LRB))
- IF 'LRB
- QUIT
- FOR T=0:0
- SET T=$ORDER(^LRO(69,LRA,1,LRB,2,"B",T))
- IF 'T
- QUIT
- IF $DATA(LRT(T))
- DO C
- End DoDot:2
- +4 IF INSTFLAG
- Begin DoDot:2
- +5 SET XLRL=""
- FOR
- SET XLRL=$ORDER(^LRO(69,LRA,1,"AC",XLRL))
- IF XLRL=""
- QUIT
- IF $$INSTHIT(XLRL)
- FOR LRB=0:0
- SET LRB=$ORDER(^LRO(69,LRA,1,"AC",XLRL,LRB))
- IF 'LRB
- QUIT
- FOR T=0:0
- SET T=$ORDER(^LRO(69,LRA,1,LRB,2,"B",T))
- IF 'T
- QUIT
- IF $DATA(LRT(T))
- DO C
- End DoDot:2
- End DoDot:1
- +6 FOR A=0:0
- SET A=$ORDER(LRT(A))
- IF 'A!(LR("Q"))
- QUIT
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- WRITE !,LRT(A),?30,"Count: ",$JUSTIFY(LRH(A),5),?45,"Average time:"
- IF LRG(A)
- SET X=LRG(A)\LRH(A)
- SET Y=X\60
- SET X=X#60
- IF Y
- WRITE $JUSTIFY(Y,3)," hr"
- IF X
- WRITE ?65,$JUSTIFY(X,2)," min"
- +7 ; F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=^LR(A,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)") S ^TMP($J,"B",$P(X,"^"),A)=$P(X,"^",9)
- +8 ; W ! S LRP=0 F Q=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F A=0:0 S A=$O(^TMP($J,"B",LRP,A)) Q:'A!(LR("Q")) S SSN=^(A),LRDPF=$P(^LR(A,0),U,2) D SSN^LRU D:$Y>(IOSL-6) H Q:LR("Q") W !,LRP,?31,SSN D L
- +9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 modifications
- +10 ; F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=^LR(A,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),HRCN=$S($P($G(^AUPNPAT(+$G(Y),41,+$G(DUZ(2)),0)),"^",2):$P(^(0),"^",2),1:"??") S ^TMP($J,"B",$P(X,"^"),A)=HRCN ;IHS/ANMC/CLS 08/18/96
- +11 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
- +12 FOR A=0:0
- SET A=$ORDER(^TMP($JOB,A))
- IF 'A
- QUIT
- Begin DoDot:1
- +13 SET X=$GET(^LR(A,0))
- +14 IF $LENGTH(X)<1
- QUIT
- +15 SET Y=$PIECE(X,"^",3)
- +16 SET X=$PIECE(X,"^",2)
- +17 SET X=^DIC(X,0,"GL")
- +18 SET X=@(X_Y_",0)")
- +19 SET HRCN=$SELECT($PIECE($GET(^AUPNPAT(+$GET(Y),41,+$GET(DUZ(2)),0)),"^",2):$PIECE($GET(^(0)),"^",2),1:"??")
- +20 ; Naked Reference Fix
- SET ^TMP($JOB,"B",$PIECE(X,"^"),A)=HRCN
- End DoDot:1
- +21 ; ----- END IHS/MSC/MKK - LR*5.2*1034
- +22 ;IHS/ANMC/CLS
- WRITE !
- SET LRP=0
- FOR Q=0:0
- SET LRP=$ORDER(^TMP($JOB,"B",LRP))
- IF LRP=""!(LR("Q"))
- QUIT
- FOR A=0:0
- SET A=$ORDER(^TMP($JOB,"B",LRP,A))
- IF 'A!(LR("Q"))
- QUIT
- SET HRCN=^(A)
- SET LRDPF=$PIECE(^LR(A,0),U,2)
- DO SSN^LRU
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- WRITE !,LRP,?31,HRCN
- DO L
- +23 ; ----- END IHS/MSC/MKK - LR*5.2*1031
- +24 DO END^LRUTL
- DO END
- QUIT
- T SET V=$PIECE(X,".",2)_"000"
- SET V=$EXTRACT(V,1,2)*60+$EXTRACT(V,3,4)
- DO H^%DTC
- SET X=%H_"."_$EXTRACT("0000",1,4-$LENGTH(V))_V
- QUIT
- L FOR T=0:0
- SET T=$ORDER(^TMP($JOB,A,T))
- IF 'T!(LR("Q"))
- QUIT
- FOR B=0:0
- SET B=$ORDER(^TMP($JOB,A,T,B))
- IF 'B!(LR("Q"))
- QUIT
- FOR C=0:0
- SET C=$ORDER(^TMP($JOB,A,T,B,C))
- IF 'C!(LR("Q"))
- QUIT
- FOR E=0:0
- SET E=$ORDER(^TMP($JOB,A,T,B,C,E))
- IF 'E!(LR("Q"))
- QUIT
- DO W
- +1 KILL T,B,C,E
- +2 QUIT
- W IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- +1 ; W !?3,LRT(T),?32,$$Y2K^LRX(B,"5D"),?44 S X(1)=^TMP($J,A,T,B,C,E),X=+X(1),Y=X\60,X=X#60 W:Y $J(Y,3)," hr" W:X ?50,$J(X,2)," min" W ?60,"Arr time:" S X=$P(X(1),"^",2) W $E(X,1,2)_":"_$E(X,3,4) Q
- +2 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 modifications
- +3 ;IHS/ANMC/CLS 08/18/96
- WRITE !?3,LRT(T),?33,$$Y2K^LRX(B,"5D"),?44
- SET X(1)=^TMP($JOB,A,T,B,C,E)
- SET X=+X(1)
- SET Y=X\60
- SET X=X#60
- IF Y
- WRITE $JUSTIFY(Y,3)," hr"
- IF X
- WRITE ?50,$JUSTIFY(X,2)," min"
- WRITE ?60,"Arr time:"
- SET X=$PIECE(X(1),"^",2)
- WRITE $EXTRACT(X,1,2)_":"_$EXTRACT(X,3,4)
- QUIT
- +4 ; ----- END IHS/MSC/MKK - LR*5.2*1031
- +5 ;
- C SET E=$ORDER(^LRO(69,LRA,1,LRB,2,"B",T,0))
- SET LRS=$SELECT($DATA(^LRO(69,LRA,1,LRB,3)):+^(3),1:0)
- SET E=$SELECT($DATA(^(2,E,0)):^(0),1:"")
- SET W=$PIECE(E,"^",4)
- SET LRC=$PIECE(E,"^",3)
- SET LRX=$PIECE(E,"^",5)
- +1 IF $PIECE(E,"^",11)'=""
- QUIT
- +2 IF $$CANCEL
- QUIT
- +3 ; I LRS,W,LRC,LRX,$D(^LRO(68,W,1,LRC,1,LRX,4,T,0)) S X=$P(^(0),"^",5) Q:X'["." Q:$P(^(0),"^",8)="" D T S LRF=X D S
- +4 ; IHS/MSC/MKK - LR*5.2*1032 -- Do *NOT* check for the WKLD SUFFIX in file 68
- IF LRS
- IF W
- IF LRC
- IF LRX
- IF $DATA(^LRO(68,W,1,LRC,1,LRX,4,T,0))
- SET X=$PIECE(^(0),"^",5)
- IF X'["."
- QUIT
- DO T
- SET LRF=X
- DO S
- +5 QUIT
- S SET (LRS(1),X)=LRS
- DO T
- SET LRS=X
- SET LRDFN=+^LRO(68,W,1,LRC,1,LRX,0)
- SET X=$PIECE(LRF,".")-$PIECE(LRS,".")
- IF X
- SET X=X*1440
- SET LRT=X+$PIECE(LRF,".",2)-$PIECE(LRS,".",2)
- +1 SET LRG(T)=LRG(T)+LRT
- SET LRH(T)=LRH(T)+1
- IF $DATA(LRI)
- SET ^TMP($JOB,LRDFN,T,LRA,W,LRX)=LRT_"^"_$PIECE(LRS(1),".",2)_"000"
- QUIT
- +2 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"Location: ",LRL,!,"Laboratory test turnaround times from: ",LRSTR," to ",LRLST,!,LR("%")
- QUIT
- +2 ;
- H1 ; D H Q:LR("Q") W !,LRP,?31,SSN Q
- +1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 modifications
- +2 DO H
- IF LR("Q")
- QUIT
- WRITE !,LRP,?31,HRCN
- QUIT
- +3 ; ----- END IHS/MSC/MKK - LR*5.2*1031
- +4 ;
- END DO V^LRU
- KILL INSTFLAG,XLRL
- QUIT
- LOC ; check file 44 for location entered
- +1 IF $EXTRACT(LRY,1,2)="L."!($EXTRACT(LRY,1,2)="l.")
- SET LRY=$EXTRACT(LRY,3,99)
- DO HLOC
- QUIT
- +2 IF $EXTRACT(LRY,1,2)="I."!($EXTRACT(LRY,1,2)="i.")
- SET LRY=$EXTRACT(LRY,3,99)
- DO INST
- QUIT
- +3 DO HLOC
- IF Y<1
- DO INST
- +4 QUIT
- HLOC SET X=LRY
- SET DIC=44
- SET DIC(0)="EMZ"
- DO ^DIC
- KILL DIC
- IF Y'<1
- SET LRL=$PIECE(Y(0),U,2)
- IF LRL=""
- WRITE $CHAR(7),!!,"There must be an abbreviation entered for the hospital location!"
- +1 QUIT
- INST ; check file 4 for location entered
- +1 SET X=LRY
- SET DIC=4
- SET DIC(0)="EQMZ"
- SET DIC("S")="I $G(^DIC(4,Y,99))"
- DO ^DIC
- KILL DIC
- IF Y'<1
- SET LRL=$PIECE(Y(0),"^")
- SET INSTFLAG=1
- +2 QUIT
- INSTHIT(XLOC) ;
- +1 NEW HIT,LOCNUM,INSTNUM,X99
- +2 SET HIT=0
- +3 SET LOCNUM=$ORDER(^SC("C",XLOC,0))
- +4 IF LOCNUM'=""
- Begin DoDot:1
- +5 SET INSTNUM=$PIECE($GET(^SC(LOCNUM,0)),U,4)
- +6 IF INSTNUM=""
- QUIT
- +7 IF $DATA(^DIC(4,"B",LRL,INSTNUM))
- Begin DoDot:2
- +8 SET X99=$GET(^DIC(4,INSTNUM,99))
- +9 IF X99=""
- QUIT
- +10 IF $PIECE(X99,U,4)
- QUIT
- +11 SET HIT=1
- End DoDot:2
- End DoDot:1
- +12 QUIT HIT
- CANCEL() ;
- +1 ; This function checks to see if a test was cancelled.
- +2 ; If the test was cancelled the function evaluates as "true".
- +3 NEW CANFLAG,COLTIME,LRTIME,LRID,TESTNUM,LR63,PC1
- +4 SET CANFLAG=0
- +5 SET COLTIME=$PIECE($GET(^LRO(69,LRA,1,LRB,1)),"^",1)
- +6 IF COLTIME
- Begin DoDot:1
- +7 SET LRTIME=9999999-COLTIME
- +8 SET LRID=$PIECE($GET(^LRO(69,LRA,1,LRB,0)),"^",1)
- +9 IF LRID=""
- QUIT
- +10 SET TESTNUM=$GET(^LAB(60,T,.2))
- +11 IF TESTNUM=""
- QUIT
- +12 SET LR63=$GET(^LR(LRID,"CH",LRTIME,TESTNUM))
- +13 IF LR63=""
- QUIT
- +14 SET PC1=$PIECE(LR63,"^",1)
- +15 IF PC1=""
- QUIT
- +16 IF $EXTRACT(PC1,1,$LENGTH(PC1))=$EXTRACT("CANCELLED",1,$LENGTH(PC1))!($EXTRACT(PC1,1,$LENGTH(PC1))=$EXTRACT("cancelled",1,$LENGTH(PC1)))
- SET CANFLAG=1
- End DoDot:1
- +17 QUIT CANFLAG
