- LROE ;DALOI/CJS/FHS-LAB ORDER ENTRY AND ACCESSION ;Nov 12, 2020@15:02
- ;;5.2;LAB SERVICE;**100,121,201,221,263,286,360,423,432,438,450,479,541,573**;Sep 27, 1994;Build 7
- ;
- K LRORIFN,LRNATURE,LREND,LRORDRR
- ;;*
- N LRSVODT,LRORDR,LRNAAAC
- S (LRORDR,LRLWC)="WC"
- ;;;*
- D ^LRPARAM
- I $G(LREND) S LREND=0 Q
- L5 ;
- NEXT ;from LROE1
- K DIR,LRSVODT
- I $D(LROESTAT) D:$P(LRPARAM,U,14) ^LRCAPV I $G(LREND) K LRLONG,LRPANEL Q
- S (LRODT,X,DT)=$$DT^XLFDT(),LRODT0=$$FMTE^XLFDT(DT,5)
- I '$D(^LRO(69,DT,1,0)) S ^LRO(69,DT,0)=DT,^LRO(69,DT,1,0)="^69.01PA^^",^LRO(69,"B",DT,DT)=""
- I $D(^LAB(69.9,1,"RO")),+$H'=+$P(^("RO"),U) D
- . W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!
- . S DIR("A")=" Are you sure you want to continue",DIR(0)="Y",DIR("B")="No"
- I $T D ^DIR G END:$D(DIRUT) I Y'=1 W !,"OK, try later." Q
- S X="T-7",%DT="" D ^%DT S LRTM7=+Y
- ;W @IOF
- K DIC,LRSND,LRSN
- W !!,"Select Order number: " R LRORD:DTIME Q:LRORD["^"!(LRORD[".")!($D(LRLONG)&(LRORD=""))
- W @IOF S M9=0 G QUICK^LROE1:LRORD=""
- I $L(LRORD)>8 W !,"The order number entered is too long." H 1 G NEXT
- S:LRORD?.N LRORD=+LRORD IF LRORD'?.N D QMSG G NEXT
- I '$D(^LRO(69,"C",LRORD)) W !!?10,"No order exist with that number ",$C(7),! G NEXT
- S (LRCHK,LRNONE)=1,(M9,LRODT)=0
- F S LRODT=+$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
- . S DA=0 F S DA=$O(^LRO(69,"C",LRORD,LRODT,DA)) Q:DA<1 S LRCHK=LRCHK-1 S:LRNONE'=2 LRNONE=0 D LROE2
- ;;*
- I $G(LRSN),$G(LRSVODT),$O(^LRO(69,LRSVODT,1,LRSN,13,0)) D G NEXT
- . W !,$$CJ^XLFSTR("This is an Anatomic Path order",IOM),!
- . W !,$$CJ^XLFSTR("Must use 'Log-in, anat path' Option to accession this Order",IOM),!
- . H 5
- ;;;*
- I DOD'="" S Y=DOD D DD^LRX W !,!,?5,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF W !
- I '$$GOT(LRORD,LRODT) W !,"All tests for this order have been canceled." H 1 G NEXT
- I DOD'="" D I Y=0!($D(DIRUT)) K DIRUT,DTOUT,DUOUT,Y D KVAR^LRX G NEXT
- . K Y
- . S DIR(0)="Y"
- . S DIR("A")="Do you wish to continue with this accession [Yes/No]"
- . S DIR("T")=120
- . D ^DIR K DIR
- I LRNONE=2,LRCHK<1 W !,"The order has already been partially accessioned." H 1
- I LRNONE=2,LRCHK>0 W !,"The order has already been accessioned." H 1 G NEXT
- I LRNONE=1 W !,"No order exists with that number." H 1 G NEXT
- ;I '$$GOT(LRORD,LRODT) G NEXT ;W !!,"All tests for this order have been canceled.",!,"Are you sure you want to accession it" S %=1 D YN^DICN I %'=1 G NEXT
- K DIR S DIR("A")="Is this the correct order",DIR(0)="Y"
- S DIR("B")="Yes"
- D ^DIR K DIR
- I $D(DIRUT)!(Y'=1) K LRSN G NEXT
- L +^LRO(69,"C",LRORD):$G(DILOCKTM,3)
- I '$T W !?5,"Someone else is editing this Order",!!,$C(7) G NEXT
- K %DT
- S LRSTATUS="C",%DT("B")=""
- D TIME K %DT
- D:$G(LRCDT)<1 UNL69 G NEXT:LRCDT<1
- S LRTIM=+LRCDT
- ;S:'$P(^LRO(69,LRODT,1,LRSN,0),U,8) $P(^(0),U,8)=LRTIM
- S LRUN=$P(LRCDT,U,2) K LRCDT,LRSN
- I '$$Q18^LROE2(DUZ(2)) D UNL69 G NEXT ;LR573 check for accession area conflict with user
- MORE I M9>1 K DIR S DIR("A")="Do you have the entire order",DIR(0)="Y" D ^DIR K DIR S:Y=1 M9=0
- I $D(DIRUT) D UNL69 G NEXT
- S (LRODT,LRSND)=0
- F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
- . S LRSND=0
- . F S LRSND=$O(^LRO(69,"C",LRORD,LRODT,LRSND)) Q:LRSND<1 D
- . . I $D(^LRO(69,LRODT,1,LRSND,1)),$P(^(1),U,4)="C" Q
- . . S LRSN(LRSND)=LRSND,LRSN=LRSND
- . . K LRAA D Q15^LROE2 K LRSN
- D TASK,UNL69
- G NEXT
- ;
- ;
- LROE2 ;
- I '$D(^LRO(69,LRODT,1,DA,0)) Q
- I $D(^LRO(69,LRODT,1,DA,1)) D
- . I $P(^LRO(69,LRODT,1,DA,1),U,4)="C" S LRNONE=2,LRCHK=LRCHK+1 Q
- . I $P(^LRO(69,LRODT,1,DA,0),U,4)="LC",$P(^LRO(69,LRODT,1,DA,1),U,4)="" S LRNONE=2,LRCHK=LRCHK+1
- ;
- K LRSN
- S (LRSN,LRSN(DA))=+DA
- I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
- S M9=$G(M9)+1,LRZX=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LRZX,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN S LRWRDS=LRWRD
- W ?45,"Requesting location: ",$P(LRZX,U,7) S Y=$P(LRZX,U,5) D DD^LRX W !,"Date/Time Ordered: ",Y,?45,"By: ",$S($D(^VA(200,+$P(LRZX,U,2),0)):$P(^(0),U),1:"")
- ;;*
- ;
- S LRSVODT=LRODT
- D ORDER^LROS
- ;;;*
- Q
- ;
- ;
- QMSG W !,"Enter the order entry number assigned when the test was ordered."
- W:'$D(LRLONG) !,"If the test has not been ordered, type the RETURN key to order the test."
- W !,"To exit, type the ""^"" key and RETURN key."
- Q
- ;
- ;
- YN R X:DTIME S:'$T DTOUT=1 Q:X=""!(X["N")!(X["Y")
- W !,"Answer 'Y' or 'N': " G YN
- ;
- ;
- EN ;
- LROEN S LRNCWL=1
- D LROE,END K LRNCWL
- Q
- ;
- ;
- EN01 ; ENTER ORDER # THEN ENTER DATA
- STAT ;
- D ^LRPARAM
- I '$D(LRLABKY) W !!?10,"You do not have the proper security Keys",! Q
- ;
- ; Select peforming laboratory
- S X=$$SELPL^LRVERA(DUZ(2))
- I X<1 D END Q
- I X'=DUZ(2) N LRPL S LRPL=X
- ;
- S LRLONG="",LRPANEL=0,LROESTAT=""
- S %H=$H-60 D YMD^LRX S LRTM60=9999999-X
- D LROE K LRTM60,LRLONG,LREND,LROESTAT
- D END
- Q
- ;
- ;
- TIME ;from LROE1, LRORD1
- N LRFUTURE S LRFUTURE=0
- S %DT="SET" W !,"Collection Date@Time: ",$S($D(%DT("B")):%DT("B"),1:"NOW"),"//" R X:DTIME I '$T!(X="^") S LRCDT=-1 Q
- S:X="" X=$S($D(%DT("B")):%DT("B"),1:"N")
- I X["?" W !!,"You may enter ""T@U"" or just ""U"", for Today at Unknown time",!! G TIME
- I X["@U",$P(X,"@U",2)="" D Q
- . S X=$P(X,"@U",1)
- . D ^%DT
- . I Y<1 D TIME Q
- . I $E(Y,6,7)="00" D Q
- . . W !,"Please enter a specific month, day, and year."
- . . D TIME
- . I Y>DT D TIME1,TIME Q
- . I $G(DOB),Y<DOB D
- . . W !,"Invalid - Collection date precedes patient's date of birth."
- . . D TIME
- . S LRCDT=Y_"^1"
- I X="U" S LRCDT=DT_"^1" Q
- D ^%DT,TIME1
- I LRFUTURE G TIME
- I Y>0,$G(DOB),Y<DOB D Q
- . W !,"Invalid - Collection date precedes patient's date of birth."
- . D TIME
- S LRCDT=+Y_"^" G TIME:Y'["."
- Q
- ;
- TIME1 S X1=X,Y1=Y D TIME2 S X=X1,Y=Y1 K X1,Y1
- Q
- ;
- TIME2 S X="N",%DT="ST" D ^%DT
- Q:Y1'>Y
- W !,"Future date/time may not be entered."
- S LRFUTURE=1
- Q
- ;
- ;
- TASK ;
- I $D(LRLABLIO),$D(LRLBL) S ZTRTN="ENT^LRLABLD",ZTDTH=$H,ZTDESC="LAB LABELS",ZTIO=LRLABLIO,ZTSAVE("LRLBL(")="" D ^%ZTLOAD
- K LRLBL
- I $D(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) K ^XTMP("LRCAP",LRCSQ,DUZ),LRCSQ
- I $D(LRCSQ),$P($G(^LRO(68,+LRAA,0)),U,16) D STD^LRCAPV
- D STOP^LRCAPV K LRCOM,LRSPCDSC,LRCCOM,LRTCOM
- Q
- ;
- ;
- END K DIR,DIRUT,GOT,LRNAAAC
- D ^LRORDK,LROEND^LRORDK,STOP^LRCAPV
- Q
- ;
- ;
- GOT(ORD,ODT) ;See if all tests have been canceled
- N I,SN,ODT
- S (GOT,ODT,SN)=0
- F S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1 D
- . S SN=0 F S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1!(GOT) D
- . . Q:'$D(^LRO(69,ODT,1,SN,0))
- . . S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,I)) Q:I<1 I $D(^(I,0)),'$P(^(0),"^",11),$P(^(0),U,9)'="CA" S GOT=1 Q
- Q GOT
- ;
- ;
- UNL69 ;
- L -^LRO(69,"C",+$G(LRORD))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROE 6712 printed Jan 18, 2025@03:19:12 Page 2
- LROE ;DALOI/CJS/FHS-LAB ORDER ENTRY AND ACCESSION ;Nov 12, 2020@15:02
- +1 ;;5.2;LAB SERVICE;**100,121,201,221,263,286,360,423,432,438,450,479,541,573**;Sep 27, 1994;Build 7
- +2 ;
- +3 KILL LRORIFN,LRNATURE,LREND,LRORDRR
- +4 ;;*
- +5 NEW LRSVODT,LRORDR,LRNAAAC
- +6 SET (LRORDR,LRLWC)="WC"
- +7 ;;;*
- +8 DO ^LRPARAM
- +9 IF $GET(LREND)
- SET LREND=0
- QUIT
- L5 ;
- NEXT ;from LROE1
- +1 KILL DIR,LRSVODT
- +2 IF $DATA(LROESTAT)
- if $PIECE(LRPARAM,U,14)
- DO ^LRCAPV
- IF $GET(LREND)
- KILL LRLONG,LRPANEL
- QUIT
- +3 SET (LRODT,X,DT)=$$DT^XLFDT()
- SET LRODT0=$$FMTE^XLFDT(DT,5)
- +4 IF '$DATA(^LRO(69,DT,1,0))
- SET ^LRO(69,DT,0)=DT
- SET ^LRO(69,DT,1,0)="^69.01PA^^"
- SET ^LRO(69,"B",DT,DT)=""
- +5 IF $DATA(^LAB(69.9,1,"RO"))
- IF +$HOROLOG'=+$PIECE(^("RO"),U)
- Begin DoDot:1
- +6 WRITE $CHAR(7),!,"ROLLOVER ",$SELECT($PIECE(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$CHAR(7),!
- +7 SET DIR("A")=" Are you sure you want to continue"
- SET DIR(0)="Y"
- SET DIR("B")="No"
- End DoDot:1
- +8 IF $TEST
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- IF Y'=1
- WRITE !,"OK, try later."
- QUIT
- +9 SET X="T-7"
- SET %DT=""
- DO ^%DT
- SET LRTM7=+Y
- +10 ;W @IOF
- +11 KILL DIC,LRSND,LRSN
- +12 WRITE !!,"Select Order number: "
- READ LRORD:DTIME
- if LRORD["^"!(LRORD[".")!($DATA(LRLONG)&(LRORD=""))
- QUIT
- +13 WRITE @IOF
- SET M9=0
- if LRORD=""
- GOTO QUICK^LROE1
- +14 IF $LENGTH(LRORD)>8
- WRITE !,"The order number entered is too long."
- HANG 1
- GOTO NEXT
- +15 if LRORD?.N
- SET LRORD=+LRORD
- IF LRORD'?.N
- DO QMSG
- GOTO NEXT
- +16 IF '$DATA(^LRO(69,"C",LRORD))
- WRITE !!?10,"No order exist with that number ",$CHAR(7),!
- GOTO NEXT
- +17 SET (LRCHK,LRNONE)=1
- SET (M9,LRODT)=0
- +18 FOR
- SET LRODT=+$ORDER(^LRO(69,"C",LRORD,LRODT))
- if LRODT<1
- QUIT
- Begin DoDot:1
- +19 SET DA=0
- FOR
- SET DA=$ORDER(^LRO(69,"C",LRORD,LRODT,DA))
- if DA<1
- QUIT
- SET LRCHK=LRCHK-1
- if LRNONE'=2
- SET LRNONE=0
- DO LROE2
- End DoDot:1
- +20 ;;*
- +21 IF $GET(LRSN)
- IF $GET(LRSVODT)
- IF $ORDER(^LRO(69,LRSVODT,1,LRSN,13,0))
- Begin DoDot:1
- +22 WRITE !,$$CJ^XLFSTR("This is an Anatomic Path order",IOM),!
- +23 WRITE !,$$CJ^XLFSTR("Must use 'Log-in, anat path' Option to accession this Order",IOM),!
- +24 HANG 5
- End DoDot:1
- GOTO NEXT
- +25 ;;;*
- +26 IF DOD'=""
- SET Y=DOD
- DO DD^LRX
- WRITE !,!,?5,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF
- WRITE !
- +27 IF '$$GOT(LRORD,LRODT)
- WRITE !,"All tests for this order have been canceled."
- HANG 1
- GOTO NEXT
- +28 IF DOD'=""
- Begin DoDot:1
- +29 KILL Y
- +30 SET DIR(0)="Y"
- +31 SET DIR("A")="Do you wish to continue with this accession [Yes/No]"
- +32 SET DIR("T")=120
- +33 DO ^DIR
- KILL DIR
- End DoDot:1
- IF Y=0!($DATA(DIRUT))
- KILL DIRUT,DTOUT,DUOUT,Y
- DO KVAR^LRX
- GOTO NEXT
- +34 IF LRNONE=2
- IF LRCHK<1
- WRITE !,"The order has already been partially accessioned."
- HANG 1
- +35 IF LRNONE=2
- IF LRCHK>0
- WRITE !,"The order has already been accessioned."
- HANG 1
- GOTO NEXT
- +36 IF LRNONE=1
- WRITE !,"No order exists with that number."
- HANG 1
- GOTO NEXT
- +37 ;I '$$GOT(LRORD,LRODT) G NEXT ;W !!,"All tests for this order have been canceled.",!,"Are you sure you want to accession it" S %=1 D YN^DICN I %'=1 G NEXT
- +38 KILL DIR
- SET DIR("A")="Is this the correct order"
- SET DIR(0)="Y"
- +39 SET DIR("B")="Yes"
- +40 DO ^DIR
- KILL DIR
- +41 IF $DATA(DIRUT)!(Y'=1)
- KILL LRSN
- GOTO NEXT
- +42 LOCK +^LRO(69,"C",LRORD):$GET(DILOCKTM,3)
- +43 IF '$TEST
- WRITE !?5,"Someone else is editing this Order",!!,$CHAR(7)
- GOTO NEXT
- +44 KILL %DT
- +45 SET LRSTATUS="C"
- SET %DT("B")=""
- +46 DO TIME
- KILL %DT
- +47 if $GET(LRCDT)<1
- DO UNL69
- if LRCDT<1
- GOTO NEXT
- +48 SET LRTIM=+LRCDT
- +49 ;S:'$P(^LRO(69,LRODT,1,LRSN,0),U,8) $P(^(0),U,8)=LRTIM
- +50 SET LRUN=$PIECE(LRCDT,U,2)
- KILL LRCDT,LRSN
- +51 ;LR573 check for accession area conflict with user
- IF '$$Q18^LROE2(DUZ(2))
- DO UNL69
- GOTO NEXT
- MORE IF M9>1
- KILL DIR
- SET DIR("A")="Do you have the entire order"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- if Y=1
- SET M9=0
- +1 IF $DATA(DIRUT)
- DO UNL69
- GOTO NEXT
- +2 SET (LRODT,LRSND)=0
- +3 FOR
- SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
- if LRODT<1
- QUIT
- Begin DoDot:1
- +4 SET LRSND=0
- +5 FOR
- SET LRSND=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSND))
- if LRSND<1
- QUIT
- Begin DoDot:2
- +6 IF $DATA(^LRO(69,LRODT,1,LRSND,1))
- IF $PIECE(^(1),U,4)="C"
- QUIT
- +7 SET LRSN(LRSND)=LRSND
- SET LRSN=LRSND
- +8 KILL LRAA
- DO Q15^LROE2
- KILL LRSN
- End DoDot:2
- End DoDot:1
- +9 DO TASK
- DO UNL69
- +10 GOTO NEXT
- +11 ;
- +12 ;
- LROE2 ;
- +1 IF '$DATA(^LRO(69,LRODT,1,DA,0))
- QUIT
- +2 IF $DATA(^LRO(69,LRODT,1,DA,1))
- Begin DoDot:1
- +3 IF $PIECE(^LRO(69,LRODT,1,DA,1),U,4)="C"
- SET LRNONE=2
- SET LRCHK=LRCHK+1
- QUIT
- +4 IF $PIECE(^LRO(69,LRODT,1,DA,0),U,4)="LC"
- IF $PIECE(^LRO(69,LRODT,1,DA,1),U,4)=""
- SET LRNONE=2
- SET LRCHK=LRCHK+1
- End DoDot:1
- +5 ;
- +6 KILL LRSN
- +7 SET (LRSN,LRSN(DA))=+DA
- +8 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
- QUIT
- +9 SET M9=$GET(M9)+1
- SET LRZX=^LRO(69,LRODT,1,LRSN,0)
- SET LRDFN=+LRZX
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- WRITE !,PNM,?30,SSN
- SET LRWRDS=LRWRD
- +10 WRITE ?45,"Requesting location: ",$PIECE(LRZX,U,7)
- SET Y=$PIECE(LRZX,U,5)
- DO DD^LRX
- WRITE !,"Date/Time Ordered: ",Y,?45,"By: ",$SELECT($DATA(^VA(200,+$PIECE(LRZX,U,2),0)):$PIECE(^(0),U),1:"")
- +11 ;;*
- +12 ;
- +13 SET LRSVODT=LRODT
- +14 DO ORDER^LROS
- +15 ;;;*
- +16 QUIT
- +17 ;
- +18 ;
- QMSG WRITE !,"Enter the order entry number assigned when the test was ordered."
- +1 if '$DATA(LRLONG)
- WRITE !,"If the test has not been ordered, type the RETURN key to order the test."
- +2 WRITE !,"To exit, type the ""^"" key and RETURN key."
- +3 QUIT
- +4 ;
- +5 ;
- YN READ X:DTIME
- if '$TEST
- SET DTOUT=1
- if X=""!(X["N")!(X["Y")
- QUIT
- +1 WRITE !,"Answer 'Y' or 'N': "
- GOTO YN
- +2 ;
- +3 ;
- EN ;
- LROEN SET LRNCWL=1
- +1 DO LROE
- DO END
- KILL LRNCWL
- +2 QUIT
- +3 ;
- +4 ;
- EN01 ; ENTER ORDER # THEN ENTER DATA
- STAT ;
- +1 DO ^LRPARAM
- +2 IF '$DATA(LRLABKY)
- WRITE !!?10,"You do not have the proper security Keys",!
- QUIT
- +3 ;
- +4 ; Select peforming laboratory
- +5 SET X=$$SELPL^LRVERA(DUZ(2))
- +6 IF X<1
- DO END
- QUIT
- +7 IF X'=DUZ(2)
- NEW LRPL
- SET LRPL=X
- +8 ;
- +9 SET LRLONG=""
- SET LRPANEL=0
- SET LROESTAT=""
- +10 SET %H=$HOROLOG-60
- DO YMD^LRX
- SET LRTM60=9999999-X
- +11 DO LROE
- KILL LRTM60,LRLONG,LREND,LROESTAT
- +12 DO END
- +13 QUIT
- +14 ;
- +15 ;
- TIME ;from LROE1, LRORD1
- +1 NEW LRFUTURE
- SET LRFUTURE=0
- +2 SET %DT="SET"
- WRITE !,"Collection Date@Time: ",$SELECT($DATA(%DT("B")):%DT("B"),1:"NOW"),"//"
- READ X:DTIME
- IF '$TEST!(X="^")
- SET LRCDT=-1
- QUIT
- +3 if X=""
- SET X=$SELECT($DATA(%DT("B")):%DT("B"),1:"N")
- +4 IF X["?"
- WRITE !!,"You may enter ""T@U"" or just ""U"", for Today at Unknown time",!!
- GOTO TIME
- +5 IF X["@U"
- IF $PIECE(X,"@U",2)=""
- Begin DoDot:1
- +6 SET X=$PIECE(X,"@U",1)
- +7 DO ^%DT
- +8 IF Y<1
- DO TIME
- QUIT
- +9 IF $EXTRACT(Y,6,7)="00"
- Begin DoDot:2
- +10 WRITE !,"Please enter a specific month, day, and year."
- +11 DO TIME
- End DoDot:2
- QUIT
- +12 IF Y>DT
- DO TIME1
- DO TIME
- QUIT
- +13 IF $GET(DOB)
- IF Y<DOB
- Begin DoDot:2
- +14 WRITE !,"Invalid - Collection date precedes patient's date of birth."
- +15 DO TIME
- End DoDot:2
- +16 SET LRCDT=Y_"^1"
- End DoDot:1
- QUIT
- +17 IF X="U"
- SET LRCDT=DT_"^1"
- QUIT
- +18 DO ^%DT
- DO TIME1
- +19 IF LRFUTURE
- GOTO TIME
- +20 IF Y>0
- IF $GET(DOB)
- IF Y<DOB
- Begin DoDot:1
- +21 WRITE !,"Invalid - Collection date precedes patient's date of birth."
- +22 DO TIME
- End DoDot:1
- QUIT
- +23 SET LRCDT=+Y_"^"
- if Y'["."
- GOTO TIME
- +24 QUIT
- +25 ;
- TIME1 SET X1=X
- SET Y1=Y
- DO TIME2
- SET X=X1
- SET Y=Y1
- KILL X1,Y1
- +1 QUIT
- +2 ;
- TIME2 SET X="N"
- SET %DT="ST"
- DO ^%DT
- +1 if Y1'>Y
- QUIT
- +2 WRITE !,"Future date/time may not be entered."
- +3 SET LRFUTURE=1
- +4 QUIT
- +5 ;
- +6 ;
- TASK ;
- +1 IF $DATA(LRLABLIO)
- IF $DATA(LRLBL)
- SET ZTRTN="ENT^LRLABLD"
- SET ZTDTH=$HOROLOG
- SET ZTDESC="LAB LABELS"
- SET ZTIO=LRLABLIO
- SET ZTSAVE("LRLBL(")=""
- DO ^%ZTLOAD
- +2 KILL LRLBL
- +3 IF $DATA(LRCSQ)
- IF '$ORDER(^XTMP("LRCAP",LRCSQ,DUZ,0))
- KILL ^XTMP("LRCAP",LRCSQ,DUZ),LRCSQ
- +4 IF $DATA(LRCSQ)
- IF $PIECE($GET(^LRO(68,+LRAA,0)),U,16)
- DO STD^LRCAPV
- +5 DO STOP^LRCAPV
- KILL LRCOM,LRSPCDSC,LRCCOM,LRTCOM
- +6 QUIT
- +7 ;
- +8 ;
- END KILL DIR,DIRUT,GOT,LRNAAAC
- +1 DO ^LRORDK
- DO LROEND^LRORDK
- DO STOP^LRCAPV
- +2 QUIT
- +3 ;
- +4 ;
- GOT(ORD,ODT) ;See if all tests have been canceled
- +1 NEW I,SN,ODT
- +2 SET (GOT,ODT,SN)=0
- +3 FOR
- SET ODT=$ORDER(^LRO(69,"C",ORD,ODT))
- if ODT<1
- QUIT
- Begin DoDot:1
- +4 SET SN=0
- FOR
- SET SN=$ORDER(^LRO(69,"C",ORD,ODT,SN))
- if SN<1!(GOT)
- QUIT
- Begin DoDot:2
- +5 if '$DATA(^LRO(69,ODT,1,SN,0))
- QUIT
- +6 SET I=0
- FOR
- SET I=$ORDER(^LRO(69,ODT,1,SN,2,I))
- if I<1
- QUIT
- IF $DATA(^(I,0))
- IF '$PIECE(^(0),"^",11)
- IF $PIECE(^(0),U,9)'="CA"
- SET GOT=1
- QUIT
- End DoDot:2
- End DoDot:1
- +7 QUIT GOT
- +8 ;
- +9 ;
- UNL69 ;
- +1 LOCK -^LRO(69,"C",+$GET(LRORD))
- +2 QUIT