Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LROE

LROE.m

Go to the documentation of this file. 
  1. LROE ;DALOI/CJS/FHS-LAB ORDER ENTRY AND ACCESSION ;8/11/97
  1.  ;;5.2;LAB SERVICE;**1003,100,121,1006,201,1013,221,1018,1021,263,1027,286,360,1031,423,1034,1035,1036,1038,432,1039**;NOV 01, 1997;Build 32
  1.  ;;5.2;LAB SERVICE;**100,121,201,221,263,286,360,423,432**;Sep 27, 1994;Build 2
  1.  ;
  1.  K LRORIFN,LRNATURE,LREND,LRORDRR
  1.  S LRLWC="WC"
  1.  D ^LRPARAM
  1.  I $G(LREND) S LREND=0 Q
  1. L5 ;
  1. NEXT ;from LROE1
  1.  K DIR
  1.  I $D(LROESTAT) D:$P(LRPARAM,U,14) ^LRCAPV I $G(LREND) K LRLONG,LRPANEL Q
  1.  S (LRODT,X,DT)=$$DT^XLFDT(),LRODT0=$$FMTE^XLFDT(DT,5)
  1.  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)=""
  1.  I $D(^LAB(69.9,1,"RO")),+$H'=+$P(^("RO"),U) D
  1.  . W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!
  1.  . S DIR("A")="  Are you sure you want to continue",DIR(0)="Y",DIR("B")="No"
  1.  I $T D ^DIR G END:$D(DIRUT) I Y'=1 W !,"OK, try later." Q
  1.  S X="T-7",%DT="" D ^%DT S LRTM7=+Y
  1.  ;W @IOF
  1.  D BLRRL           ; IHS/cmi/maw 9/9/2004 added check for ship manifest
  1.  K DIC,LRSND,LRSN
  1.  W !!,"Select Order number: " R LRORD:DTIME Q:LRORD["^"!(LRORD[".")!($D(LRLONG)&(LRORD=""))
  1.  W @IOF S M9=0 G QUICK^LROE1:LRORD=""
  1.  I $L(LRORD)>8 W !,"The order number entered is too long." H 1 G NEXT
  1.  S:LRORD?.N LRORD=+LRORD IF LRORD'?.N D QMSG G NEXT
  1.  I '$D(^LRO(69,"C",LRORD)) W !!?10,"No order exist with that number ",$C(7),! G NEXT
  1.  S (LRCHK,LRNONE)=1,(M9,LRODT)=0
  1.  F  S LRODT=+$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1  D
  1.  . 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
  1.  I DOD'="" S Y=DOD D DD^LRX W !,!,?5,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF W !
  1.  I DOD'="" D  I Y=0!($D(DIRUT)) K DIRUT,DTOUT,DUOUT,Y D KVAR^LRX G NEXT
  1.  . K Y
  1.  . S DIR(0)="Y"
  1.  . S DIR("A")="Do you wish to continue with this accession [Yes/No]"
  1.  . S DIR("T")=120
  1.  . D ^DIR K DIR
  1.  I LRNONE=2,LRCHK<1 W !,"The order has already been partially accessioned." H 1
  1.  I LRNONE=2,LRCHK>0 W !,"The order has already been accessioned." H 1 G NEXT
  1.  I LRNONE=1 W !,"No order exists with that number." H 1 G NEXT
  1.  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
  1.  K DIR S DIR("A")="Is this the correct order",DIR(0)="Y"
  1.  S DIR("B")="Yes"
  1.  D ^DIR K DIR
  1.  I $D(DIRUT)!(Y'=1) K LRSN G NEXT
  1.  L +^LRO(69,"C",LRORD):$G(DILOCKTM,3)
  1.  I '$T W !?5,"Someone else is editing this Order",!!,$C(7) G NEXT
  1.  K %DT
  1.  S LRSTATUS="C",%DT("B")=""
  1.  D TIME K %DT
  1.  D:$G(LRCDT)<1 UNL69 G NEXT:LRCDT<1
  1.  S LRTIM=+LRCDT
  1.  ;S:'$P(^LRO(69,LRODT,1,LRSN,0),U,8) $P(^(0),U,8)=LRTIM
  1.  S LRUN=$P(LRCDT,U,2) K LRCDT,LRSN
  1. 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
  1.  I $D(DIRUT) D UNL69 G NEXT
  1.  S YYYLRORD=LRORD                                ; IHS/OIT/MKK - LR*5.2*1030
  1.  S (LRODT,LRSND)=0
  1.  F  S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1  D
  1.  . S LRSND=0
  1.  . F  S LRSND=$O(^LRO(69,"C",LRORD,LRODT,LRSND)) Q:LRSND<1  D
  1.  . . I $D(^LRO(69,LRODT,1,LRSND,1)),$P(^(1),U,4)="C" Q
  1.  . . S LRSN(LRSND)=LRSND,LRSN=LRSND
  1.  . . K LRAA D Q15^LROE2 K LRSN
  1.  D TASK,UNL69
  1.  D ORDNSTOR^BLRAAORU(YYYLRORD)  K YYYLRORD       ; IHS/OIT/MKK - LR*5.2*1030 - Store Ask-At-Order Questions
  1.  G NEXT
  1.  ;
  1.  ;
  1. LROE2 ;
  1.  I '$D(^LRO(69,LRODT,1,DA,0)) Q
  1.  I $D(^LRO(69,LRODT,1,DA,1)) D
  1.  . I $P(^LRO(69,LRODT,1,DA,1),U,4)="C" S LRNONE=2,LRCHK=LRCHK+1 Q
  1.  . 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
  1.  ;
  1.  K LRSN
  1.  S (LRSN,LRSN(DA))=+DA
  1.  I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
  1.  ; 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
  1.  ; 
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1027
  1.  S M9=$G(M9)+1
  1.  S LRZX=$G(^LRO(69,LRODT,1,LRSN,0))
  1.  S LRDFN=+LRZX
  1.  S LRDPF=$P($G(^LR(LRDFN,0)),U,2),DFN=$P($G(^(0)),U,3)
  1.  D PT^LRX
  1.  W !,PNM,?30,HRCN
  1.  S LRWRDS=LRWRD
  1.  ;----- END IHS MODIFICATIONS LR*5.2*1027
  1.  ;
  1.  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:"")
  1.  S LRSVSN=LRSN D ORDER^LROS S LRSN=LRSVSN
  1.  Q
  1.  ;
  1.  ;
  1. QMSG W !,"Enter the order entry number assigned when the test was ordered."
  1.  W:'$D(LRLONG) !,"If the test has not been ordered, type the RETURN key to order the test."
  1.  W !,"To exit, type the ""^"" key and RETURN key."
  1.  Q
  1.  ;
  1.  ;
  1. YN R X:DTIME S:'$T DTOUT=1 Q:X=""!(X["N")!(X["Y")
  1.  W !,"Answer 'Y' or 'N': " G YN
  1.  ;
  1.  ;
  1. EN ;
  1. LROEN S LRNCWL=1
  1.  D LROE,END K LRNCWL
  1.  Q
  1.  ;
  1.  ;
  1. EN01 ; ENTER ORDER # THEN ENTER DATA
  1. STAT ;
  1.  D ^LRPARAM
  1.  I '$D(LRLABKY) W !!?10,"You do not have the proper security Keys",! Q
  1.  ;
  1.  ; Select peforming laboratory
  1.  S X=$$SELPL^LRVERA(DUZ(2))
  1.  I X<1 D END Q
  1.  I X'=DUZ(2) N LRPL S LRPL=X
  1.  ;
  1.  S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="ACCORD",BLROPT(0)=$P(XQY0,U)  ;IHS/OIRM TUC/AAB 2/1/97
  1.  ;
  1.  S LRLONG="",LRPANEL=0,LROESTAT=""
  1.  S %H=$H-60 D YMD^LRX S LRTM60=9999999-X
  1.  D LROE K LRTM60,LRLONG,LREND,LROESTAT
  1.  D END
  1.  Q
  1.  ;
  1.  ;
  1. TIME ;from LROE1, LRORD1
  1.  ; 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
  1.  ; S:X="" X=$S($D(%DT("B")):%DT("B"),1:"N")
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
  1.  I $P(XQY0,U)="LRQUICK" D
  1.  . S %DT="SET" W !,"Collection Date@Time: " R X:DTIME I '$T!(X="^")!(X="") S LRCDT=-1
  1.  I $P(XQY0,U)'="LRQUICK" D
  1.  . 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
  1.  . S:X="" X=$S($D(%DT("B")):%DT("B"),1:"N")
  1.  I $G(LRCDT)<0 Q
  1.  S X=$$UP^XLFSTR(X)
  1.  I $E($G(X))'["N",$G(X)'["U",$G(X)'["@" W !!,?4,"Need Time also."  G TIME
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1038
  1.  ;
  1.  W:X["?" !!,"You may enter ""T@U"" or just ""U"", for Today at Unknown time",!!
  1.  I X["@U",$P(X,"@U",2)="" S X=$P(X,"@U",1) D ^%DT G TIME:Y<1 S LRCDT=+Y_"^1" Q
  1.  S:X="U" LRCDT=DT_"^1"
  1.  I X'="U" D ^%DT D:X'["?" TIME1 G TIME:X["?" S LRCDT=+Y_"^" G TIME:Y'["."
  1.  Q
  1.  ;
  1. TIME1 S X1=X,Y1=Y D TIME2 S X=X1,Y=Y1 K X1,Y1
  1.  Q
  1.  ;
  1. TIME2 S X="N",%DT="ST" D ^%DT Q:Y1'>Y  F  W !,"You have specified a collection time in the future.  Are you sure" S %=2 D YN^DICN Q:%  W !,"Answer 'Y'es or 'N'o."
  1.  S:%'=1 X="?" S X1=X
  1.  Q
  1.  ;
  1.  ;
  1. TASK ;
  1.  I $D(LRLABLIO),$D(LRLBL) S ZTRTN="ENT^LRLABLD",ZTDTH=$H,ZTDESC="LAB LABELS",ZTIO=LRLABLIO,ZTSAVE("LRLBL(")="" D ^%ZTLOAD
  1.  K LRLBL
  1.  I $D(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) K ^XTMP("LRCAP",LRCSQ,DUZ),LRCSQ
  1.  I $D(LRCSQ),$P($G(^LRO(68,+LRAA,0)),U,16) D STD^LRCAPV
  1.  D STOP^LRCAPV K LRCOM,LRSPCDSC,LRCCOM,LRTCOM
  1.  Q
  1.  ;
  1.  ;
  1. END K DIR,DIRUT,GOT
  1.  D ^LRORDK,LROEND^LRORDK,STOP^LRCAPV
  1.  Q
  1.  ;
  1.  ;
  1. GOT(ORD,ODT) ;See if all tests have been canceled
  1.  N I,SN,ODT
  1.  S (GOT,ODT,SN)=0
  1.  F  S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1  D
  1.  . S SN=0 F  S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1!(GOT)  D
  1.  . . Q:'$D(^LRO(69,ODT,1,SN,0))
  1.  . . S I=0 F  S I=$O(^LRO(69,ODT,1,SN,2,I)) Q:I<1  I $D(^(I,0)),'$P(^(0),"^",11) S GOT=1 Q
  1.  Q GOT
  1.  ;
  1.  ;
  1. UNL69 ;
  1.  L -^LRO(69,"C",+$G(LRORD))
  1.  Q
  1.  ;
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
  1. BLRRL ;EP - cmi/anch/maw 8/4/2004 added to check for shipping manifest and print
  1.  ;cmi/anch/maw REF LAB
  1.  ;cmi/anch/maw 9/28/2004 changed to write only when a shipping manifest
  1.  K BLRINS,BLRDXS  ;cmi/7/1/2010 reference lab ledi variables
  1.  K BLRASFLG  ;P1034
  1.  Q:$G(BLRGUI)
  1.  Q:'$G(^BLRSITE(DUZ(2),"RL"))  ;reference lab not set up
  1.  Q:$P($G(^BLRSITE(DUZ(2),"RL")),U,22)
  1.  ;I $D(^TMP("BLRRL",$J)) D
  1.  I $G(LRORD),$O(^BLRRLO("B",LRORD,0)) D  ;p1034
  1.  . N OI
  1.  . S OI=$O(^BLRRLO("B",LRORD,0))
  1.  . Q:'$D(^BLRRLO(OI,3,0))  ;not accessioned yet
  1.  . ;W !,"Printing Shipping Manifests for Reference Lab..."  ;1036 moved to BLRRLEVN
  1.  . ;D PRT^BLRSHPM
  1.  . D SHIPMAN^BLRRLEVN(LRORD,0,0)  ;ihs/cmi/maw 12/17/2014 p1034 store and forward changes
  1.  K BLRINS,BLRASFLG,BLRDXS  ;p1035
  1.  Q
  1.  ;----- END IHS MODIFICATIONS cmi/anch/maw end REF LAB LR*5.2*1021