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
