- BLRORD1 ;SLC/RWF/TPF - LAZY ACCESSION LOGGING ;8/11/97 [ 08/01/2002 8:20 AM ]
- ;;5.2;LR;**1,1013**;JUL 31, 1997
- ;;5.2;LAB SERVICE;**1,8,121**;Sep 27, 1994
- L2 K LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LRNATURE
- S LRWPC=LRWP G:$D(LROR) LRFIRST
- ; MJL 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
- ; MJL I $D(LRADDTST),LRADDTST="" Q
- ; MJL S:'$D(LREND) LREND=0 I LRORDR="" D COLTY^LRWU G DROP:LREND
- S LRDPF="2^DPT(",PNM=^DPT(DFN,0),SSN=$P(PNM,U,9),PNM=$P(PNM,U)
- S HRCN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0),"^?"),U,2)
- S X="^"_$P(LRDPF,"^",2)_DFN_",""LR"")",LRDFN=+$S($D(@X):@X,1:-1) G E3:LRDFN>0
- L ^LR(0) S LRDFN=$P(^LR(0),"^",3)+1
- E2 I $D(^LR(LRDFN)) S LRDFN=LRDFN+1 G E2
- S ^LR(LRDFN,0)=LRDFN_"^"_+LRDPF_"^"_DFN,@X=LRDFN,^(0)=$P(^LR(0),"^",1,2)_"^"_LRDFN_"^"_(1+$P(^(0),"^",4)),^LR("B",LRDFN,LRDFN)="" L
- E3 I LRDFN>0,$P(^LR(LRDFN,0),"^",2)'=+LRDPF!($P(^(0),"^",3)'=DFN) S RESULT(1)=-1,RESULT(2)="Database degradation on "_PNM_". Contact site manager." Q
- BPC I LRDFN<1 S RESULT(1)=-1,RESULT(2)="No Lab LRDFN Defined" Q
- S LRDPF=$P(^LR(LRDFN,0),U,2)
- Q12 ; MJL D LOC^LRWU G DROP:LREND
- S LRLLOC=$P(BPCPARAM,";",5),LROLLOC="",LROLLOC=$O(^SC("C",LRLLOC,LROLLOC))
- Q11 ; MJL D PRAC^LRWU1 G DROP:LREND
- S (LRPRAC,^LR(LRDFN,.2))=DUZ
- K T,TT,LRDMAX,LRDTST,LRTMAX
- ;FHL 7/31/97
- S DA=0 F S DA=$O(^LRO(69,LRODT,1,"AA",LRDFN,DA)) Q:DA<1 D
- .I $S($D(^LRO(69,LRODT,1,DA,1)):$P(^LRO(69,LRODT,1,DA,1),U,4)'="U",1:1) D
- ..S S=+$G(^LRO(69,LRODT,1,DA,4,1,0))
- ..S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:+I<1 D
- ...S X=+^LRO(69,LRODT,1,DA,2,I,0),T(X,DA)=S
- ...S:'$D(TT(X,S)) TT(X,S)=0 S TT(X,S)=TT(X,S)+1
- ; MJL 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) S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:I<1 S T(+^(I,0),DA)=S D EN^LRORDD
- K DIC I $D(LRADDTST) S LRORD=+LRADDTST,LRADDTST="" G LRFIRST
- D ORDER^BLROW2 I $D(LRFLOG),$P(LRFLOG,U,3)="MI" K DUOUT D MICRO G L2:$D(DUOUT)!$D(DTOUT)
- LRFIRST S LRSX=1 G Q13:'LRFIRST!(LRWP<2) ; MJL W !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
- ; MJL F I=1:1:LRWPD W !,I,?4,$P(LRSTIK(I),U,2) W:$D(LRSTIK(I+LRWPD)) ?39," ",I+LRWPD,?44,$P(LRSTIK(I+LRWPD),U,2)
- Q13 S LREDO=0 G:LRWP'>1 Q13A
- ; MJL W ! W:'LRFIRST "'?' for list, " S LRFIRST=0 R "TEST number(s): ",LRSX:DTIME S:LRSX["?" LRFIRST=1 G LRFIRST:LRFIRST
- S LRSX=BPCTL
- F I=1:1 S LRSSX=$P(LRSX,",",I),LRSSX=$P(LRSSX,"*") Q:$P(LRSX,",",I,99)="" S LREDO=$S($L(LRSSX)>31:1,1:(+(LRSSX\1)'=LRSSX)!(LRSSX<1)!(LRSSX>LRWP)) Q:LREDO
- Q13A ; MJL I LREDO W !,"Something was mistyped, try again." G Q13
- F LRK=1:1 S LRSSX=$P(LRSX,",",LRK) Q:LRSSX="" S LRST=$S(LRSSX["*":1,1:0),LRSSX=+LRSSX,LRSAMP=$P(LRSTIK(LRSSX),U,3),LRSPEC=$P(LRSTIK(LRSSX),U,5),LRTSTS=+LRSTIK(LRSSX) D Q20^BLRORDD
- S LRM=LRWPC+1,K=0 ; MJL W !,"Other tests? N//" D % G Q14:'(%["Y")
- LRM ; MJL D MORE^LRORD2
- Q14 ;FHL D:$P(LRPARAM,U,17) ^BLRORDD G LRM:'$D(%)&($D(LROT)'=11),DROP:$O(LROT(-1))="",LRM:'$D(%),DROP:%[U K DIC G DROP:'$D(LROT)!(%["N")
- D:$P(LRPARAM,U,17) ^BLRORDD
- ; MJL 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")
- ; MJL W !!,"LAB Order number: ",LRORD,!!
- ; MJL I LRECT D TIME^LROE G DROP:LRCDT<1 S LRORDTIM=$P(Y,".",2)
- S:LRECT LRORDTIM="08"
- D NOW^%DTC S LRNT=% S:'LRECT LRCDT=LRNT_"^1"
- S LRIDT=9999999-LRCDT
- D ^BLRORDST Q:$D(LROR)
- S RESULT(1)=1,RESULT(2)="Order: "_LRORD_" "_$G(BPCACC) Q
- ; MJL I $D(LRFASTS) D LRWU4^LRFASTS
- ; MJL D:BLRLOG ^BLRSLTL("C","O",$G(BLROPT)) ;IHS/OIRM TUC/AAB 11/14/96
- Q:$G(LRKIK) G L2
- % R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
- Q20A ;from LRORD2
- MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
- I $D(TT(LRTSTS,LRSPEC)),$D(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN))) D EN2^LRORDD I %'["Y" Q
- S I7=0 F I9=0:0 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 W $C(7),!!,"You have a duplicate: " S LRSN=0 F S LRSN=$O(T(LRTSTS,LRSN)) Q:LRSN<1 W " for ",$P(^LAB(60,LRTSTS,0),U) S LRZT=LRTSTS D ORDER^LROS S LRTSTS=LRZT
- I I7 W !,"You already have that test, do you really want another? N//" D %
- Q
- URGG W !,"For ",$P(LRSTIK(LRSSX),U,2) D URG^LRORD2 Q
- DROP G L2 ;FHL 1/8/98 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
- BLRORD1 ;SLC/RWF/TPF - LAZY ACCESSION LOGGING ;8/11/97 [ 08/01/2002 8:20 AM ]
- +1 ;;5.2;LR;**1,1013**;JUL 31, 1997
- +2 ;;5.2;LAB SERVICE;**1,8,121**;Sep 27, 1994
- L2 KILL LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LRNATURE
- +1 SET LRWPC=LRWP
- IF $DATA(LROR)
- GOTO LRFIRST
- +2 ; MJL 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
- +3 ; MJL I $D(LRADDTST),LRADDTST="" Q
- +4 ; MJL S:'$D(LREND) LREND=0 I LRORDR="" D COLTY^LRWU G DROP:LREND
- +5 SET LRDPF="2^DPT("
- SET PNM=^DPT(DFN,0)
- SET SSN=$PIECE(PNM,U,9)
- SET PNM=$PIECE(PNM,U)
- +6 SET HRCN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0),"^?"),U,2)
- +7 SET X="^"_$PIECE(LRDPF,"^",2)_DFN_",""LR"")"
- SET LRDFN=+$SELECT($DATA(@X):@X,1:-1)
- IF LRDFN>0
- GOTO E3
- +8 LOCK ^LR(0)
- SET LRDFN=$PIECE(^LR(0),"^",3)+1
- E2 IF $DATA(^LR(LRDFN))
- SET LRDFN=LRDFN+1
- GOTO E2
- +1 SET ^LR(LRDFN,0)=LRDFN_"^"_+LRDPF_"^"_DFN
- SET @X=LRDFN
- SET ^(0)=$PIECE(^LR(0),"^",1,2)_"^"_LRDFN_"^"_(1+$PIECE(^(0),"^",4))
- SET ^LR("B",LRDFN,LRDFN)=""
- LOCK
- E3 IF LRDFN>0
- IF $PIECE(^LR(LRDFN,0),"^",2)'=+LRDPF!($PIECE(^(0),"^",3)'=DFN)
- SET RESULT(1)=-1
- SET RESULT(2)="Database degradation on "_PNM_". Contact site manager."
- QUIT
- BPC IF LRDFN<1
- SET RESULT(1)=-1
- SET RESULT(2)="No Lab LRDFN Defined"
- QUIT
- +1 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- Q12 ; MJL D LOC^LRWU G DROP:LREND
- +1 SET LRLLOC=$PIECE(BPCPARAM,";",5)
- SET LROLLOC=""
- SET LROLLOC=$ORDER(^SC("C",LRLLOC,LROLLOC))
- Q11 ; MJL D PRAC^LRWU1 G DROP:LREND
- +1 SET (LRPRAC,^LR(LRDFN,.2))=DUZ
- +2 KILL T,TT,LRDMAX,LRDTST,LRTMAX
- +3 ;FHL 7/31/97
- +4 SET DA=0
- FOR
- SET DA=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,DA))
- IF DA<1
- QUIT
- Begin DoDot:1
- +5 IF $SELECT($DATA(^LRO(69,LRODT,1,DA,1)):$PIECE(^LRO(69,LRODT,1,DA,1),U,4)'="U",1:1)
- Begin DoDot:2
- +6 SET S=+$GET(^LRO(69,LRODT,1,DA,4,1,0))
- +7 SET I=0
- FOR
- SET I=$ORDER(^LRO(69,LRODT,1,DA,2,I))
- IF +I<1
- QUIT
- Begin DoDot:3
- +8 SET X=+^LRO(69,LRODT,1,DA,2,I,0)
- SET T(X,DA)=S
- +9 IF '$DATA(TT(X,S))
- SET TT(X,S)=0
- SET TT(X,S)=TT(X,S)+1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 ; MJL 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) S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:I<1 S T(+^(I,0),DA)=S D EN^LRORDD
- +11 KILL DIC
- IF $DATA(LRADDTST)
- SET LRORD=+LRADDTST
- SET LRADDTST=""
- GOTO LRFIRST
- +12 DO ORDER^BLROW2
- IF $DATA(LRFLOG)
- IF $PIECE(LRFLOG,U,3)="MI"
- KILL DUOUT
- DO MICRO
- IF $DATA(DUOUT)!$DATA(DTOUT)
- GOTO L2
- LRFIRST ; MJL W !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
- SET LRSX=1
- IF 'LRFIRST!(LRWP<2)
- GOTO Q13
- +1 ; MJL F I=1:1:LRWPD W !,I,?4,$P(LRSTIK(I),U,2) W:$D(LRSTIK(I+LRWPD)) ?39," ",I+LRWPD,?44,$P(LRSTIK(I+LRWPD),U,2)
- Q13 SET LREDO=0
- IF LRWP'>1
- GOTO Q13A
- +1 ; MJL W ! W:'LRFIRST "'?' for list, " S LRFIRST=0 R "TEST number(s): ",LRSX:DTIME S:LRSX["?" LRFIRST=1 G LRFIRST:LRFIRST
- +2 SET LRSX=BPCTL
- +3 FOR I=1:1
- SET LRSSX=$PIECE(LRSX,",",I)
- SET LRSSX=$PIECE(LRSSX,"*")
- IF $PIECE(LRSX,",",I,99)=""
- QUIT
- SET LREDO=$SELECT($LENGTH(LRSSX)>31:1,1:(+(LRSSX\1)'=LRSSX)!(LRSSX<1)!(LRSSX>LRWP))
- IF LREDO
- QUIT
- Q13A ; MJL I LREDO W !,"Something was mistyped, try again." G Q13
- +1 FOR LRK=1:1
- SET LRSSX=$PIECE(LRSX,",",LRK)
- IF LRSSX=""
- QUIT
- SET LRST=$SELECT(LRSSX["*":1,1:0)
- SET LRSSX=+LRSSX
- SET LRSAMP=$PIECE(LRSTIK(LRSSX),U,3)
- SET LRSPEC=$PIECE(LRSTIK(LRSSX),U,5)
- SET LRTSTS=+LRSTIK(LRSSX)
- DO Q20^BLRORDD
- +2 ; MJL W !,"Other tests? N//" D % G Q14:'(%["Y")
- SET LRM=LRWPC+1
- SET K=0
- LRM ; MJL D MORE^LRORD2
- Q14 ;FHL D:$P(LRPARAM,U,17) ^BLRORDD G LRM:'$D(%)&($D(LROT)'=11),DROP:$O(LROT(-1))="",LRM:'$D(%),DROP:%[U K DIC G DROP:'$D(LROT)!(%["N")
- +1 IF $PIECE(LRPARAM,U,17)
- DO ^BLRORDD
- +2 ; MJL 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")
- +3 ; MJL W !!,"LAB Order number: ",LRORD,!!
- +4 ; MJL I LRECT D TIME^LROE G DROP:LRCDT<1 S LRORDTIM=$P(Y,".",2)
- +5 IF LRECT
- SET LRORDTIM="08"
- +6 DO NOW^%DTC
- SET LRNT=%
- IF 'LRECT
- SET LRCDT=LRNT_"^1"
- +7 SET LRIDT=9999999-LRCDT
- +8 DO ^BLRORDST
- IF $DATA(LROR)
- QUIT
- +9 SET RESULT(1)=1
- SET RESULT(2)="Order: "_LRORD_" "_$GET(BPCACC)
- QUIT
- +10 ; MJL I $D(LRFASTS) D LRWU4^LRFASTS
- +11 ; MJL D:BLRLOG ^BLRSLTL("C","O",$G(BLROPT)) ;IHS/OIRM TUC/AAB 11/14/96
- +12 IF $GET(LRKIK)
- QUIT
- GOTO L2
- % READ %:DTIME
- IF %=""!(%["N")!(%["Y")
- QUIT
- WRITE !,"Answer 'Y' or 'N': "
- GOTO %
- Q20A ;from LRORD2
- MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
- +1 IF $DATA(TT(LRTSTS,LRSPEC))
- IF $DATA(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN)))
- DO EN2^LRORDD
- IF %'["Y"
- QUIT
- +2 SET I7=0
- FOR I9=0:0
- 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
- +3 IF I7
- WRITE $CHAR(7),!!,"You have a duplicate: "
- SET LRSN=0
- FOR
- SET LRSN=$ORDER(T(LRTSTS,LRSN))
- IF LRSN<1
- QUIT
- WRITE " for ",$PIECE(^LAB(60,LRTSTS,0),U)
- SET LRZT=LRTSTS
- DO ORDER^LROS
- SET LRTSTS=LRZT
- +4 IF I7
- WRITE !,"You already have that test, do you really want another? N//"
- DO %
- +5 QUIT
- URGG WRITE !,"For ",$PIECE(LRSTIK(LRSSX),U,2)
- DO URG^LRORD2
- QUIT
- DROP ;FHL 1/8/98 W !!,"ORDER CANCELED",$C(7),!! Q:$D(LROR) G L2 ; !($G(LREND)) G L2
- GOTO L2
- MICRO WRITE !,"Is there one sample for this patient's order"
- SET %=1
- DO YN^DICN
- IF %=2!(%=-1)
- IF %=-1
- SET DUOUT=1
- QUIT
- +1 IF %=0
- WRITE !,"The collection sample and site/specimen will be used for all tests ordered",!,"at this time for this patient."
- GOTO MICRO
- +2 DO GSNO^LRORD3
- IF $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +3 IF +LRSAMP=-1&(LRSPEC=-1)
- WRITE !,"Incompletely defined."
- GOTO MICRO
- +4 SET LRSAME=LRSAMP_U_LRSPEC
- +5 SET LRECOM=0
- DO GCOM^LRORD2
- +6 QUIT
- PRAC ;from LRFAST
- +1 SET X=$SELECT(+DIC("B"):$PIECE(^VA(200,+DIC("B"),0),U),1:"")
- WRITE !,"PRACTITIONER: ",X,$SELECT($LENGTH(X):"//",1:"")
- READ X:DTIME
- IF DIC("B")
- IF X=""
- SET Y=DIC("B")
- QUIT
- +2 DO ^DIC
- KILL DIC
- +3 QUIT
