- LRORD1 ;DALOI/STAFF - LAZY ACCESSION LOGGING ;03/07/12 16:38
- ;;5.2;LAB SERVICE;**1,8,121,153,201,286,291,350**;Sep 27, 1994;Build 230
- ;
- L2 Q:$G(LREND)
- N LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP ; CIDC
- K LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
- S LRWPC=LRWP G:$D(LROR) LRFIRST
- I '$D(LRADDTST) K DFN,DIC S PNM="",DIC(0)="EMQ"_$S($P(LRPARAM,U,6)&$D(LRLABKY):"L",1:"") W ! D ^LRDPA I (LRDFN=-1)!$D(DUOUT)!$D(DTOUT) Q
- I $D(LRADDTST),LRADDTST="" Q
- S:'$D(LREND) LREND=0 I LRORDR="" D COLTY^LRWU G DROP:LREND
- S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
- ;
- Q12 D LOC^LRWU G DROP:LREND
- ;
- Q11 D PRAC^LRWU1 G DROP:LREND
- K T,TT,LRDMAX,LRDTST,LRTMAX
- S DA=0
- F S DA=$O(^LRO(69,LRODT,1,"AA",LRDFN,DA)) Q:DA<1 I $S($D(^LRO(69,LRODT,1,DA,1)):$P(^(1),U,4)'="U",1:1) S S=$S($D(^LRO(69,LRODT,1,DA,4,1,0)):+^(0),1:0) D
- . S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:I<1 I $D(^(I,0)) S T(+^(0),DA)=S,X=+^(0) S:'$D(TT(X,S)) TT(X,S)=0 S TT(X,S)=TT(X,S)+1
- K DIC
- I $D(LRADDTST) S LRORD=+LRADDTST,LRADDTST="" G LRFIRST
- D ORDER^LROW2
- I $D(LRFLOG),$P(LRFLOG,U,3)="MI",$G(LRORDRR)'="R" K DUOUT D MICRO G L2:$D(DUOUT)!$D(DTOUT)
- ;
- LRFIRST S LRSX=1 G Q13:'LRFIRST!(LRWP<2)
- W !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
- F I=1:1:LRWPD D
- . N X
- . S X=^TMP("LRSTIK",$J,"B",I)
- . W !,X,?4,$P(^TMP("LRSTIK",$J,X),U,2)
- . S X=$G(^TMP("LRSTIK",$J,"B",I+LRWPD))
- . I X W ?39," ",X,?44,$P(^TMP("LRSTIK",$J,X),U,2)
- Q13 S LREDO=0
- ;
- LEDI ;
- ;
- ; If LEDI accessioning then check for pending orders in file #69.6
- I $G(LRRSTAT)="I",$G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" D I $O(LROT(0)) G BAR
- . D EN^LRORDB(LRSD("RUID"),LRRSITE("SMID"))
- G:LRWP'>1 Q13A
- W ! W:'LRFIRST "'?' for list, " S LRFIRST=0
- R "TEST number(s): ",LRSX:DTIME S:LRSX["?" LRFIRST=1 G LRFIRST:LRFIRST
- I LRSX=""!(LRSX["^") G BAR
- F I=1:1:$L(LRSX,",") D Q:LREDO
- . S LRSSX=$P(LRSX,",",I)
- . I LRSSX'?1.3N.1"*" S LREDO=1 Q
- . S LRSSX=$P(LRSSX,"*")
- . I '$D(^TMP("LRSTIK",$J,LRSSX)) S LREDO=1
- Q13A I LREDO W !,"Something was mistyped, try again." G Q13
- F LRK=1:1 S LRSSX=$P(LRSX,",",LRK) Q:LRSSX="" D
- . N X
- . S LRST=$S(LRSSX["*":1,1:0),LRSSX=+LRSSX
- . S X=^TMP("LRSTIK",$J,LRSSX)
- . S LRSAMP=$P(X,U,3),LRSPEC=$P(X,U,5),LRTSTS=+X
- . D Q20^LRORDD
- BAR S LRM=LRWPC+1,K=0 G:$G(LRORDRR)="R" Q14 W !,"Other tests? N//" D % G Q14:'(%["Y")
- LRM D MORE^LRORD2
- Q14 D:$P(LRPARAM,U,17) ^LRORDD D ^LRORD2A D ENSTIK^LROW3 G LRM:'$D(%)&($D(LROT)'=11),DROP:$O(LROT(-1))="",LRM:'$D(%),DROP:%[U K DIC G DROP:'$D(LROT)!(%["N")
- S LRBEY=1 I $G(LRORDRR)'="R",+LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) D G DROP:'LRBEY
- .D BALROR^LRBEBA3(.LRORD) ; CIDC
- I ($D(LRBEY)<1)!$D(DUOUT)!$D(DTOUT) Q
- W !!,"LAB Order number: ",LRORD,!!
- I LRECT D G DROP:LRCDT<1
- . I $G(LRORDRR)="R",$G(LRSD("CDT")) D Q
- . . S LRCDT=LRSD("CDT")_"^"
- . . S LRORDTIM=$P(LRSD("CDT"),".",2)
- . . I 'LRORDTIM S $P(LRCDT,"^",2)=1
- . D TIME^LROE
- . I $G(LRCDT)<1 Q
- . S LRORDTIM=$P($P(LRCDT,U),".",2)
- D NOW^%DTC S LRNT=% S:'LRECT LRCDT=LRNT_"^1"
- S LRIDT=9999999-LRCDT
- D ^LRORDST Q:$D(LROR)
- I $D(LRFASTS) D LRWU4^LRFASTS
- Q:$G(LRKIL) G L2
- ;
- ;
- % R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
- ;
- ;
- Q20A ;from LRORD2
- MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
- N I7,I9,LRSN
- I $D(TT(LRTSTS,LRSPEC)),$D(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN))) D EN2^LRORDD I %'["Y" Q
- S (I7,I9)=0
- F S I9=$O(T(LRTSTS,I9)) Q:I9="" I $D(^LAB(60,LRTSTS,3,+$O(^LAB(60,LRTSTS,3,"B",LRSAMP,0)),0)),+$P(^(0),U,5),LRSPEC=T(LRTSTS,I9) S I7=1
- I I7 D
- . W $C(7),!!,"You have a duplicate: "
- . S LRSN=0
- . F S LRSN=$O(T(LRTSTS,LRSN)) Q:LRSN<1 D
- . . W " for ",$P(^LAB(60,LRTSTS,0),U)
- . . N LRTSTS D ORDER^LROS
- . W !,"You already have that test, do you really want another? N//" D %
- Q
- ;
- ;
- URGG W !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2)
- D URG^LRORD2
- Q
- ;
- ;
- DROP W !!,"ORDER CANCELED",$C(7),!! Q:$D(LROR) G L2 ; !($G(LREND)) G L2
- ;
- ;
- MICRO W !,"Is there one sample for this patient's order"
- S %=1 D YN^DICN
- I %=2!(%=-1) S:%=-1 DUOUT=1 Q
- I %=0 W !,"The collection sample and site/specimen will be used for all tests ordered",!,"at this time for this patient." G MICRO
- D GSNO^LRORD3 Q:$D(DUOUT)!$D(DTOUT)
- I +LRSAMP=-1&(LRSPEC=-1) W !,"Incompletely defined." G MICRO
- S LRSAME=LRSAMP_U_LRSPEC
- S LRECOM=0 D GCOM^LRORD2
- Q
- ;
- ;
- PRAC ;from LRFAST
- S X=$S(+DIC("B"):$P(^VA(200,+DIC("B"),0),U),1:"")
- W !,"PRACTITIONER: ",X,$S($L(X):"//",1:"")
- R X:DTIME
- I DIC("B"),X="" S Y=DIC("B") Q
- D ^DIC K DIC
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRORD1 4604 printed Mar 13, 2025@21:23:20 Page 2
- LRORD1 ;DALOI/STAFF - LAZY ACCESSION LOGGING ;03/07/12 16:38
- +1 ;;5.2;LAB SERVICE;**1,8,121,153,201,286,291,350**;Sep 27, 1994;Build 230
- +2 ;
- L2 if $GET(LREND)
- QUIT
- +1 ; CIDC
- NEW LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP
- +2 KILL LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
- +3 SET LRWPC=LRWP
- if $DATA(LROR)
- GOTO LRFIRST
- +4 IF '$DATA(LRADDTST)
- KILL DFN,DIC
- SET PNM=""
- SET DIC(0)="EMQ"_$SELECT($PIECE(LRPARAM,U,6)&$DATA(LRLABKY):"L",1:"")
- WRITE !
- DO ^LRDPA
- IF (LRDFN=-1)!$DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +5 IF $DATA(LRADDTST)
- IF LRADDTST=""
- QUIT
- +6 if '$DATA(LREND)
- SET LREND=0
- IF LRORDR=""
- DO COLTY^LRWU
- if LREND
- GOTO DROP
- +7 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- +8 ;
- Q12 DO LOC^LRWU
- if LREND
- GOTO DROP
- +1 ;
- Q11 DO PRAC^LRWU1
- if LREND
- GOTO DROP
- +1 KILL T,TT,LRDMAX,LRDTST,LRTMAX
- +2 SET DA=0
- +3 FOR
- SET DA=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,DA))
- if DA<1
- QUIT
- IF $SELECT($DATA(^LRO(69,LRODT,1,DA,1)):$PIECE(^(1),U,4)'="U",1:1)
- SET S=$SELECT($DATA(^LRO(69,LRODT,1,DA,4,1,0)):+^(0),1:0)
- Begin DoDot:1
- +4 SET I=0
- FOR
- SET I=$ORDER(^LRO(69,LRODT,1,DA,2,I))
- if I<1
- QUIT
- IF $DATA(^(I,0))
- SET T(+^(0),DA)=S
- SET X=+^(0)
- if '$DATA(TT(X,S))
- SET TT(X,S)=0
- SET TT(X,S)=TT(X,S)+1
- End DoDot:1
- +5 KILL DIC
- +6 IF $DATA(LRADDTST)
- SET LRORD=+LRADDTST
- SET LRADDTST=""
- GOTO LRFIRST
- +7 DO ORDER^LROW2
- +8 IF $DATA(LRFLOG)
- IF $PIECE(LRFLOG,U,3)="MI"
- IF $GET(LRORDRR)'="R"
- KILL DUOUT
- DO MICRO
- if $DATA(DUOUT)!$DATA(DTOUT)
- GOTO L2
- +9 ;
- LRFIRST SET LRSX=1
- if 'LRFIRST!(LRWP<2)
- GOTO Q13
- +1 WRITE !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
- +2 FOR I=1:1:LRWPD
- Begin DoDot:1
- +3 NEW X
- +4 SET X=^TMP("LRSTIK",$JOB,"B",I)
- +5 WRITE !,X,?4,$PIECE(^TMP("LRSTIK",$JOB,X),U,2)
- +6 SET X=$GET(^TMP("LRSTIK",$JOB,"B",I+LRWPD))
- +7 IF X
- WRITE ?39," ",X,?44,$PIECE(^TMP("LRSTIK",$JOB,X),U,2)
- End DoDot:1
- Q13 SET LREDO=0
- +1 ;
- LEDI ;
- +1 ;
- +2 ; If LEDI accessioning then check for pending orders in file #69.6
- +3 IF $GET(LRRSTAT)="I"
- IF $GET(LRRSITE("SMID"))'=""
- IF $GET(LRSD("RUID"))'=""
- Begin DoDot:1
- +4 DO EN^LRORDB(LRSD("RUID"),LRRSITE("SMID"))
- End DoDot:1
- IF $ORDER(LROT(0))
- GOTO BAR
- +5 if LRWP'>1
- GOTO Q13A
- +6 WRITE !
- if 'LRFIRST
- WRITE "'?' for list, "
- SET LRFIRST=0
- +7 READ "TEST number(s): ",LRSX:DTIME
- if LRSX["?"
- SET LRFIRST=1
- if LRFIRST
- GOTO LRFIRST
- +8 IF LRSX=""!(LRSX["^")
- GOTO BAR
- +9 FOR I=1:1:$LENGTH(LRSX,",")
- Begin DoDot:1
- +10 SET LRSSX=$PIECE(LRSX,",",I)
- +11 IF LRSSX'?1.3N.1"*"
- SET LREDO=1
- QUIT
- +12 SET LRSSX=$PIECE(LRSSX,"*")
- +13 IF '$DATA(^TMP("LRSTIK",$JOB,LRSSX))
- SET LREDO=1
- End DoDot:1
- if LREDO
- QUIT
- Q13A IF LREDO
- WRITE !,"Something was mistyped, try again."
- GOTO Q13
- +1 FOR LRK=1:1
- SET LRSSX=$PIECE(LRSX,",",LRK)
- if LRSSX=""
- QUIT
- Begin DoDot:1
- +2 NEW X
- +3 SET LRST=$SELECT(LRSSX["*":1,1:0)
- SET LRSSX=+LRSSX
- +4 SET X=^TMP("LRSTIK",$JOB,LRSSX)
- +5 SET LRSAMP=$PIECE(X,U,3)
- SET LRSPEC=$PIECE(X,U,5)
- SET LRTSTS=+X
- +6 DO Q20^LRORDD
- End DoDot:1
- BAR SET LRM=LRWPC+1
- SET K=0
- if $GET(LRORDRR)="R"
- GOTO Q14
- WRITE !,"Other tests? N//"
- DO %
- if '(%["Y")
- GOTO Q14
- LRM DO MORE^LRORD2
- Q14 if $PIECE(LRPARAM,U,17)
- DO ^LRORDD
- DO ^LRORD2A
- DO ENSTIK^LROW3
- if '$DATA(%)&($DATA(LROT)'=11)
- GOTO LRM
- if $ORDER(LROT(-1))=""
- GOTO DROP
- if '$DATA(%)
- GOTO LRM
- if %[U
- GOTO DROP
- KILL DIC
- if '$DATA(LROT)!(%["N")
- GOTO DROP
- +1 SET LRBEY=1
- IF $GET(LRORDRR)'="R"
- IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
- Begin DoDot:1
- +2 ; CIDC
- DO BALROR^LRBEBA3(.LRORD)
- End DoDot:1
- if 'LRBEY
- GOTO DROP
- +3 IF ($DATA(LRBEY)<1)!$DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +4 WRITE !!,"LAB Order number: ",LRORD,!!
- +5 IF LRECT
- Begin DoDot:1
- +6 IF $GET(LRORDRR)="R"
- IF $GET(LRSD("CDT"))
- Begin DoDot:2
- +7 SET LRCDT=LRSD("CDT")_"^"
- +8 SET LRORDTIM=$PIECE(LRSD("CDT"),".",2)
- +9 IF 'LRORDTIM
- SET $PIECE(LRCDT,"^",2)=1
- End DoDot:2
- QUIT
- +10 DO TIME^LROE
- +11 IF $GET(LRCDT)<1
- QUIT
- +12 SET LRORDTIM=$PIECE($PIECE(LRCDT,U),".",2)
- End DoDot:1
- if LRCDT<1
- GOTO DROP
- +13 DO NOW^%DTC
- SET LRNT=%
- if 'LRECT
- SET LRCDT=LRNT_"^1"
- +14 SET LRIDT=9999999-LRCDT
- +15 DO ^LRORDST
- if $DATA(LROR)
- QUIT
- +16 IF $DATA(LRFASTS)
- DO LRWU4^LRFASTS
- +17 if $GET(LRKIL)
- QUIT
- GOTO L2
- +18 ;
- +19 ;
- % READ %:DTIME
- if %=""!(%["N")!(%["Y")
- QUIT
- WRITE !,"Answer 'Y' or 'N': "
- GOTO %
- +1 ;
- +2 ;
- Q20A ;from LRORD2
- MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
- +1 NEW I7,I9,LRSN
- +2 IF $DATA(TT(LRTSTS,LRSPEC))
- IF $DATA(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN)))
- DO EN2^LRORDD
- IF %'["Y"
- QUIT
- +3 SET (I7,I9)=0
- +4 FOR
- SET I9=$ORDER(T(LRTSTS,I9))
- if I9=""
- QUIT
- IF $DATA(^LAB(60,LRTSTS,3,+$ORDER(^LAB(60,LRTSTS,3,"B",LRSAMP,0)),0))
- IF +$PIECE(^(0),U,5)
- IF LRSPEC=T(LRTSTS,I9)
- SET I7=1
- +5 IF I7
- Begin DoDot:1
- +6 WRITE $CHAR(7),!!,"You have a duplicate: "
- +7 SET LRSN=0
- +8 FOR
- SET LRSN=$ORDER(T(LRTSTS,LRSN))
- if LRSN<1
- QUIT
- Begin DoDot:2
- +9 WRITE " for ",$PIECE(^LAB(60,LRTSTS,0),U)
- +10 NEW LRTSTS
- DO ORDER^LROS
- End DoDot:2
- +11 WRITE !,"You already have that test, do you really want another? N//"
- DO %
- End DoDot:1
- +12 QUIT
- +13 ;
- +14 ;
- URGG WRITE !,"For ",$PIECE(^TMP("LRSTIK",$JOB,LRSSX),U,2)
- +1 DO URG^LRORD2
- +2 QUIT
- +3 ;
- +4 ;
- DROP ; !($G(LREND)) G L2
- WRITE !!,"ORDER CANCELED",$CHAR(7),!!
- if $DATA(LROR)
- QUIT
- GOTO L2
- +1 ;
- +2 ;
- MICRO WRITE !,"Is there one sample for this patient's order"
- +1 SET %=1
- DO YN^DICN
- +2 IF %=2!(%=-1)
- if %=-1
- SET DUOUT=1
- QUIT
- +3 IF %=0
- WRITE !,"The collection sample and site/specimen will be used for all tests ordered",!,"at this time for this patient."
- GOTO MICRO
- +4 DO GSNO^LRORD3
- if $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +5 IF +LRSAMP=-1&(LRSPEC=-1)
- WRITE !,"Incompletely defined."
- GOTO MICRO
- +6 SET LRSAME=LRSAMP_U_LRSPEC
- +7 SET LRECOM=0
- DO GCOM^LRORD2
- +8 QUIT
- +9 ;
- +10 ;
- PRAC ;from LRFAST
- +1 SET X=$SELECT(+DIC("B"):$PIECE(^VA(200,+DIC("B"),0),U),1:"")
- +2 WRITE !,"PRACTITIONER: ",X,$SELECT($LENGTH(X):"//",1:"")
- +3 READ X:DTIME
- +4 IF DIC("B")
- IF X=""
- SET Y=DIC("B")
- QUIT
- +5 DO ^DIC
- KILL DIC
- +6 QUIT
