- LRORD1GU ;VA/DALOI/RWF - LAZY ACCESSION LOGGING ;JUL 06, 2010 3:14 PM
- ;;5.2;LAB SERVICE;**1027**;NOV 01, 1997
- ;;
- ; Cloned from LEDI III LRORD1 routine. Next two lines VA code
- LRORD1 ;DALOI/RWF - LAZY ACCESSION LOGGING ; Feb 20, 2004
- ;;5.2;LAB SERVICE;**1,8,121,153,201,286,1027**;Sep 27, 1994
- ;;
- ; This code was removed from the previous IHS version of the LRORD1 routine
- ; and placed in this new routine due to the changes to the LRORD1 routine
- ; brought in with VA LR*5.2*286 --LEDI III.
- ;
- ; It was felt that the PATIENT CHART coding was overwhelming the logic
- ; flow of the LRORD1 routine.
- ;
- ; This code is invoked ONLY when BLRGUI=1. No need to check for that.
- ; All code that was skipped when BLRGUI=1 has been removed.
- ;
- L2 ; EP ;
- K LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
- S LRWPC=LRWP G:$D(LROR) LRFIRST
- ;
- 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):1 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)
- Q:$G(RESULT(1))=-1
- ;
- Q12 ;
- S LRLLOC=$P(BPCPARAM,";",5),LROLLOC=""
- S Y=0,Y=$O(^SC("B",LRLLOC,Y))
- ;
- ; IHS/ITSC/TPF 12/19/02 **1015** PER F.J. EVANS fix for Fort Thompson not
- ; printing Verified results to the ward when using the Patient Chart
- I Y S LROLLOC=Y,LRLLOC=$S($L($P($G(^SC(Y,0)),U,2)):$P(^(0),U,2),1:LRLLOC)
- ;
- Q11 ;
- S (LRPRAC,^LR(LRDFN,.2))=BLRPRAC ;IHS/ITSC/IHS 10/9/02 PATIENT CHART FIX **1014**
- K T,TT,LRDMAX,LRDTST,LRTMAX
- 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
- ;
- 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)
- ;
- Q13 S LREDO=0
- LEDI ;
- ;
- G:LRWP'>1 Q13A
- 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 ;
- 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
- ;
- 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:LRECT LRORDTIM="08"
- D NOW^%DTC S LRNT=% S:'LRECT LRCDT=LRNT_"^1"
- S LRIDT=9999999-LRCDT
- D ^LRORDST Q:$D(LROR)
- S RESULT(1)=1,RESULT(2)="Order: "_LRORD_" "_$G(BPCACC)
- Q
- ;
- % 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(^TMP("LRSTIK",$J,LRSSX),U,2)
- D URG^LRORD2
- Q
- ;
- ;
- DROP Q:$D(LROR) G L2 ; !($G(LREND)) G L2
- ;
- ;
- MICRO ; EP
- Q:$D(LRFLOG) ;IHS/ITSC/TPF 08/02/01 ;ACCESSION TEST GROUP ALREADY CHOSEN
- D GSNO^LRORD3 Q:$D(DUOUT)!$D(DTOUT)
- S LRSAMP=1,LRSPEC=1
- 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
- LRORD1GU ;VA/DALOI/RWF - LAZY ACCESSION LOGGING ;JUL 06, 2010 3:14 PM
- +1 ;;5.2;LAB SERVICE;**1027**;NOV 01, 1997
- +2 ;;
- +3 ; Cloned from LEDI III LRORD1 routine. Next two lines VA code
- LRORD1 ;DALOI/RWF - LAZY ACCESSION LOGGING ; Feb 20, 2004
- +1 ;;5.2;LAB SERVICE;**1,8,121,153,201,286,1027**;Sep 27, 1994
- +2 ;;
- +3 ; This code was removed from the previous IHS version of the LRORD1 routine
- +4 ; and placed in this new routine due to the changes to the LRORD1 routine
- +5 ; brought in with VA LR*5.2*286 --LEDI III.
- +6 ;
- +7 ; It was felt that the PATIENT CHART coding was overwhelming the logic
- +8 ; flow of the LRORD1 routine.
- +9 ;
- +10 ; This code is invoked ONLY when BLRGUI=1. No need to check for that.
- +11 ; All code that was skipped when BLRGUI=1 has been removed.
- +12 ;
- L2 ; EP ;
- +1 KILL LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
- +2 SET LRWPC=LRWP
- IF $DATA(LROR)
- GOTO LRFIRST
- +3 ;
- +4 SET LRDPF="2^DPT("
- SET PNM=^DPT(DFN,0)
- SET SSN=$PIECE(PNM,U,9)
- SET PNM=$PIECE(PNM,U)
- +5 SET HRCN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0),"^?"),U,2)
- +6 SET X="^"_$PIECE(LRDPF,"^",2)_DFN_",""LR"")"
- SET LRDFN=+$SELECT($DATA(@X):@X,1:-1)
- IF LRDFN>0
- GOTO E3
- +7 LOCK ^LR(0):1
- 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)=""
- +2 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)
- +2 IF $GET(RESULT(1))=-1
- QUIT
- +3 ;
- Q12 ;
- +1 SET LRLLOC=$PIECE(BPCPARAM,";",5)
- SET LROLLOC=""
- +2 SET Y=0
- SET Y=$ORDER(^SC("B",LRLLOC,Y))
- +3 ;
- +4 ; IHS/ITSC/TPF 12/19/02 **1015** PER F.J. EVANS fix for Fort Thompson not
- +5 ; printing Verified results to the ward when using the Patient Chart
- +6 IF Y
- SET LROLLOC=Y
- SET LRLLOC=$SELECT($LENGTH($PIECE($GET(^SC(Y,0)),U,2)):$PIECE(^(0),U,2),1:LRLLOC)
- +7 ;
- Q11 ;
- +1 ;IHS/ITSC/IHS 10/9/02 PATIENT CHART FIX **1014**
- SET (LRPRAC,^LR(LRDFN,.2))=BLRPRAC
- +2 KILL T,TT,LRDMAX,LRDTST,LRTMAX
- +3 SET DA=0
- +4 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 ;
- +11 KILL DIC
- +12 IF $DATA(LRADDTST)
- SET LRORD=+LRADDTST
- SET LRADDTST=""
- GOTO LRFIRST
- +13 DO ORDER^LROW2
- +14 IF $DATA(LRFLOG)
- IF $PIECE(LRFLOG,U,3)="MI"
- IF $GET(LRORDRR)'="R"
- KILL DUOUT
- DO MICRO
- IF $DATA(DUOUT)!$DATA(DTOUT)
- GOTO L2
- +15 ;
- LRFIRST SET LRSX=1
- IF 'LRFIRST!(LRWP<2)
- GOTO Q13
- +1 ;
- Q13 SET LREDO=0
- LEDI ;
- +1 ;
- +2 IF LRWP'>1
- GOTO Q13A
- +3 SET LRSX=BPCTL
- +4 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
- +5 ;
- Q13A ;
- +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
- +7 ;
- BAR SET LRM=LRWPC+1
- SET K=0
- +1 ;
- LRM ; D MORE^LRORD2
- +1 ;
- 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 IF LRECT
- SET LRORDTIM="08"
- +2 DO NOW^%DTC
- SET LRNT=%
- IF 'LRECT
- SET LRCDT=LRNT_"^1"
- +3 SET LRIDT=9999999-LRCDT
- +4 DO ^LRORDST
- IF $DATA(LROR)
- QUIT
- +5 SET RESULT(1)=1
- SET RESULT(2)="Order: "_LRORD_" "_$GET(BPCACC)
- +6 QUIT
- +7 ;
- % READ %:DTIME
- IF %=""!(%["N")!(%["Y")
- QUIT
- WRITE !,"Answer 'Y' or 'N': "
- GOTO %
- +1 ;
- 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
- +6 ;
- URGG ; W !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2)
- +1 DO URG^LRORD2
- +2 QUIT
- +3 ;
- +4 ;
- DROP ; !($G(LREND)) G L2
- IF $DATA(LROR)
- QUIT
- GOTO L2
- +1 ;
- +2 ;
- MICRO ; EP
- +1 ;IHS/ITSC/TPF 08/02/01 ;ACCESSION TEST GROUP ALREADY CHOSEN
- IF $DATA(LRFLOG)
- QUIT
- +2 DO GSNO^LRORD3
- IF $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +3 SET LRSAMP=1
- SET LRSPEC=1
- +4 IF +LRSAMP=-1&(LRSPEC=-1)
- WRITE !,"Incompletely defined."
- GOTO MICRO
- +5 SET LRSAME=LRSAMP_U_LRSPEC
- +6 SET LRECOM=0
- DO GCOM^LRORD2
- +7 QUIT
- +8 ;
- +9 ;
- 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
