LRTSTJAM ;DALOI/STAFF - JAM TESTS ONTO (OR OFF) ACCESSIONS ;10/25/11 12:29
;;5.2;LAB SERVICE;**121,153,291,350**;Sep 27, 1994;Build 230
;
EN ;
ADD ; I $G(LRAA),$G(LRAD),$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
N LRACC,LRADL,LRADD1,LRADDTST,LREXTFLG,LRTSAD,LRNATURE,LRORDTYP
K LRPARAM D EN^LRPARAM
I '$D(LRPARAM) D END Q
; Initialize flag for test added for auto download
S LRADL=0
;
; LRADD1: Set flag to loop back to ADD1 tag
; LRADDTST: Set flag to loop back to ADDTST tag
; LREXTFLG: Set flag to exit
;
D ADD1
;
F Q:$D(LREXTFLG)!(('$D(LRADD1))&('$D(LRADDTST))) D
. I $D(LRADD1) K LRADD1,LRADDTST D UNLOCK,ADD1 Q
. I $D(LRADDTST) K LRADD1,LRADDTST D ADDTST Q
;
D END
;
Q
;
;
ADD1 ;
; If test added then check for automatic downloading
I LRADL D EN^LA7ADL($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),0),"^")) S LRADL=0
;
S LRACC=1 D LRACC^LRTSTOUT
K LRACC,LRTSAD,LRNATURE
I LRAN<1 S LREXTFLG=1 Q
;
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,2) W !?5,"This is not a valid Accession number ",!,$C(7) S LRADD1=1 Q
;
L +^LRO(68,LRAA,1,LRAD,1,LRAN):DILOCKTM
I '$T W !?5,"Someone else is editing this entry ",!,$C(7) S LRADD1=1 Q
;
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRDFN=$P(X,U),LRAODT=$P(X,U,3),LRODT=$P(X,U,4),LRSN=$P(X,U,5),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN
;
; Only ask nature of order on file #2 patients.
I LRDPF=2,'$D(LRNATURE) D NEW^LROR6() I $G(LRNATURE)=-1 W !!,"...process aborted",$C(7) K LRNATURE S LRADD1=1 Q
;
W !,"TESTS ALREADY ON THE ACCESSION: "
S I=0
F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<1 W !,?5,$P(^LAB(60,I,0),U,1) S LRTSAD(1,I)=""
;
LRTSP ;
W ! K DIC,DA S DIC("A")="Select Original Ordered Test: ",DA=LRSN,DA(1)=LRODT
I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U,2) S DIC("S")="I $L($P($G(^(.3)),U))"
S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DIC(0)="AQEZNM"
W ! D ^DIC K DIC,DA
I Y<1 S LRADD1=1 Q
S LRTSP=$P(Y,U,2) W !
;
ADDTST ;
S DIC("A")="Add LABORATORY TEST: ",DIC=60,DIC(0)="AEMOQ"
S DIC("S")="I $P(^(0),U,4)'="""""_$S('$D(^XUSEC("LRSUPER",DUZ)):",""N""'[$P(^(0),U,3)",1:"")
D ^DIC
K DIC("A"),DIC("S")
I Y<1 S LRADD1=1 Q
W !," ...OK" S %=1 D YN^DICN
;
I %=2 S LRADDTST=1 Q
I %'=1 S LRADD1=1 Q
;
S (LRTS,I)=+Y I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0)) W !,"The accession already has this test." S LRADDTST=1 Q
S LRTSUB=1 D EXPLD^LRTSTJM1 I $D(LRTSAD(1,LRTS)) W !,"The accession already has this test." S LRADDTST=1 Q
I $D(^LAB(60,I,8,+DUZ(2),0)) D Q:$D(LRADD1)
. S J=$P(^LAB(60,I,8,+DUZ(2),0),U,2)
. I J,J'=LRAA D
. . W !,"That test normally belongs to accession area ",$P(^LRO(68,J,0),U),",",!,"are you sure"
. . S %=2 D YN^DICN
. . I %'=1 S LRADD1=1 Q
I $O(^LAB(60,LRTS,2,0)) D Q:$D(LRADDTST)
. S LRTSURG=$P(^LAB(60,LRTS,0),U,18)
. K LRTSAD(2)
. S LRTSAD(2,LRTS)=""
. S LRTSUB=2
. D EXPLD^LRTSTJM1
. D COMPTST^LRTSTJM1
. I 'LRTSUB S LRADDTST=1 Q
S LRFLG=1 S (LRURG,Y)=$P(^LAB(60,I,0),U,18)
I LRURG'="" D SETTST Q
;
ADDURG ;
S DIC=62.05,DIC("B")="ROUTINE"
D ^DIC K DIC("B")
I Y<1 W !,"URGENCY must be defined. Test not added." S LRADDTST=1 Q
W !," ...OK" S %=1 D YN^DICN
G ADDURG:%=2
I %<1 S LRADD1=1 Q
S LRURG=+Y,LRFLG=""
;
SETTST ;
; LRORDTYP=1(add)/2(reflex)^file #64.061 ien for code^if reflex parent test^if reflex parent NLT^
S LRORDTYP=$$ORDTYP^LRTSTJM1()
I LRORDTYP<1 S LRADD1=1 Q
I $P(LRORDTYP,"^")=2 D
. N LRORDTST
. S LRORDTST=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSP,0)),U,9)
. I LRORDTST="" S LRORDTST=LRTSP
. S $P(LRORDTYP,"^",3)=LRORDTST,$P(LRORDTYP,"^",4)=$$NLT^LRVER1(LRORDTST)
I +LRDPF=2,$G(LRSS)'="BB",'$$CHKINP^LRBEBA4(LRDFN,LRODT) S LRBERF=$S(LRORDTYP>0:LRORDTYP-1,1:-1) ;CIDC
D EN^LRTSTSET
K DIC("B")
Q:$D(LRTSAD(2))
S LRADDTST=1
Q
;
;
IDENT ;D LRACC^LRTSTOUT Q:LREND
FXID ;
S LRACC=1 D LRACC^LRTSTOUT K LRACC Q:LRAN<1
S LRWDT1=DA(1) D:$D(^LRO(68,LRAA,.3))#2 ^LRWLST2 G FXID
;
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
Q
;
;
END ;
I $G(LRAA),$G(LRAD),$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
K %,A,AGE,DD,DFN,DIC,DIE,DO,DOB,DR,I,K,LRAA,LRAD,LRACD,LRAN,LRCCOM,LRDFN,LRDPF,LREND,LRIDT,LRODT,LRSN,LRSS,LRTNM,LRTS,LRWRD,PNM,SEX,SSN,X,Y,Z,LRUSNM
K %DT,%H,%X,%Y,DA,J,LRBED,LRCS,LRCSS,LRDTM,LRDTO,LRGVP,LRIDENT,LRIOZERO,LRLLOC,LRLWC,LRNOP,LRONE,LRORD,LRORDTIM,LROWLE,LRPR,LRTP,LRTSN,LRUR,LRUSNM,LRWDT1,LRXD,POP,T
K LRTSAD,LRTSUB,LRDATE,D,D0,D1,DN,LRAODT,LRFLG,LRRB,LRSAMP,LRTREA,LRTSP
K LRURG,VA,LRX,LRBERF,LRBETN
Q
;
;
CHK ; from LRTSTJAN
D CHK1 I LREND W !,$C(7),"CAN'T DO IT. The data has been approved for that log number."
Q
;
;
CHK1 ;
I $D(^LRO(68,LRWL1,1,LRWDT1,1,LRAN,3)),$P(^(3),U,4) S LREND=1 Q
I $D(^LRO(69,LRODT,1,LRSN,3)),$P(^(3),U,2) S LREND=1 Q
S LRTST=0 F S LRTST=$O(^LRO(68,LRWL1,1,LRWDT1,1,LRAN,4,LRTST)) Q:LRTST<1 I $D(^(LRTST,0)),$P(^(0),U,5) S LREND=1 Q
Q
UNLOCK ;
I $G(LRAA),$G(LRAD),$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRTSTJAM 5028 printed Apr 09, 2024@21:06:37 Page 2
LRTSTJAM ;DALOI/STAFF - JAM TESTS ONTO (OR OFF) ACCESSIONS ;10/25/11 12:29
+1 ;;5.2;LAB SERVICE;**121,153,291,350**;Sep 27, 1994;Build 230
+2 ;
EN ;
ADD ; I $G(LRAA),$G(LRAD),$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
+1 NEW LRACC,LRADL,LRADD1,LRADDTST,LREXTFLG,LRTSAD,LRNATURE,LRORDTYP
+2 KILL LRPARAM
DO EN^LRPARAM
+3 IF '$DATA(LRPARAM)
DO END
QUIT
+4 ; Initialize flag for test added for auto download
+5 SET LRADL=0
+6 ;
+7 ; LRADD1: Set flag to loop back to ADD1 tag
+8 ; LRADDTST: Set flag to loop back to ADDTST tag
+9 ; LREXTFLG: Set flag to exit
+10 ;
+11 DO ADD1
+12 ;
+13 FOR
if $DATA(LREXTFLG)!(('$DATA(LRADD1))&('$DATA(LRADDTST)))
QUIT
Begin DoDot:1
+14 IF $DATA(LRADD1)
KILL LRADD1,LRADDTST
DO UNLOCK
DO ADD1
QUIT
+15 IF $DATA(LRADDTST)
KILL LRADD1,LRADDTST
DO ADDTST
QUIT
End DoDot:1
+16 ;
+17 DO END
+18 ;
+19 QUIT
+20 ;
+21 ;
ADD1 ;
+1 ; If test added then check for automatic downloading
+2 IF LRADL
DO EN^LA7ADL($PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),0),"^"))
SET LRADL=0
+3 ;
+4 SET LRACC=1
DO LRACC^LRTSTOUT
+5 KILL LRACC,LRTSAD,LRNATURE
+6 IF LRAN<1
SET LREXTFLG=1
QUIT
+7 ;
+8 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,2)
WRITE !?5,"This is not a valid Accession number ",!,$CHAR(7)
SET LRADD1=1
QUIT
+9 ;
+10 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):DILOCKTM
+11 IF '$TEST
WRITE !?5,"Someone else is editing this entry ",!,$CHAR(7)
SET LRADD1=1
QUIT
+12 ;
+13 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRDFN=$PIECE(X,U)
SET LRAODT=$PIECE(X,U,3)
SET LRODT=$PIECE(X,U,4)
SET LRSN=$PIECE(X,U,5)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
WRITE !,PNM,?30,SSN
+14 ;
+15 ; Only ask nature of order on file #2 patients.
+16 IF LRDPF=2
IF '$DATA(LRNATURE)
DO NEW^LROR6()
IF $GET(LRNATURE)=-1
WRITE !!,"...process aborted",$CHAR(7)
KILL LRNATURE
SET LRADD1=1
QUIT
+17 ;
+18 WRITE !,"TESTS ALREADY ON THE ACCESSION: "
+19 SET I=0
+20 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<1
QUIT
WRITE !,?5,$PIECE(^LAB(60,I,0),U,1)
SET LRTSAD(1,I)=""
+21 ;
LRTSP ;
+1 WRITE !
KILL DIC,DA
SET DIC("A")="Select Original Ordered Test: "
SET DA=LRSN
SET DA(1)=LRODT
+2 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U,2)
SET DIC("S")="I $L($P($G(^(.3)),U))"
+3 SET DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET DIC(0)="AQEZNM"
+4 WRITE !
DO ^DIC
KILL DIC,DA
+5 IF Y<1
SET LRADD1=1
QUIT
+6 SET LRTSP=$PIECE(Y,U,2)
WRITE !
+7 ;
ADDTST ;
+1 SET DIC("A")="Add LABORATORY TEST: "
SET DIC=60
SET DIC(0)="AEMOQ"
+2 SET DIC("S")="I $P(^(0),U,4)'="""""_$SELECT('$DATA(^XUSEC("LRSUPER",DUZ)):",""N""'[$P(^(0),U,3)",1:"")
+3 DO ^DIC
+4 KILL DIC("A"),DIC("S")
+5 IF Y<1
SET LRADD1=1
QUIT
+6 WRITE !," ...OK"
SET %=1
DO YN^DICN
+7 ;
+8 IF %=2
SET LRADDTST=1
QUIT
+9 IF %'=1
SET LRADD1=1
QUIT
+10 ;
+11 SET (LRTS,I)=+Y
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
WRITE !,"The accession already has this test."
SET LRADDTST=1
QUIT
+12 SET LRTSUB=1
DO EXPLD^LRTSTJM1
IF $DATA(LRTSAD(1,LRTS))
WRITE !,"The accession already has this test."
SET LRADDTST=1
QUIT
+13 IF $DATA(^LAB(60,I,8,+DUZ(2),0))
Begin DoDot:1
+14 SET J=$PIECE(^LAB(60,I,8,+DUZ(2),0),U,2)
+15 IF J
IF J'=LRAA
Begin DoDot:2
+16 WRITE !,"That test normally belongs to accession area ",$PIECE(^LRO(68,J,0),U),",",!,"are you sure"
+17 SET %=2
DO YN^DICN
+18 IF %'=1
SET LRADD1=1
QUIT
End DoDot:2
End DoDot:1
if $DATA(LRADD1)
QUIT
+19 IF $ORDER(^LAB(60,LRTS,2,0))
Begin DoDot:1
+20 SET LRTSURG=$PIECE(^LAB(60,LRTS,0),U,18)
+21 KILL LRTSAD(2)
+22 SET LRTSAD(2,LRTS)=""
+23 SET LRTSUB=2
+24 DO EXPLD^LRTSTJM1
+25 DO COMPTST^LRTSTJM1
+26 IF 'LRTSUB
SET LRADDTST=1
QUIT
End DoDot:1
if $DATA(LRADDTST)
QUIT
+27 SET LRFLG=1
SET (LRURG,Y)=$PIECE(^LAB(60,I,0),U,18)
+28 IF LRURG'=""
DO SETTST
QUIT
+29 ;
ADDURG ;
+1 SET DIC=62.05
SET DIC("B")="ROUTINE"
+2 DO ^DIC
KILL DIC("B")
+3 IF Y<1
WRITE !,"URGENCY must be defined. Test not added."
SET LRADDTST=1
QUIT
+4 WRITE !," ...OK"
SET %=1
DO YN^DICN
+5 if %=2
GOTO ADDURG
+6 IF %<1
SET LRADD1=1
QUIT
+7 SET LRURG=+Y
SET LRFLG=""
+8 ;
SETTST ;
+1 ; LRORDTYP=1(add)/2(reflex)^file #64.061 ien for code^if reflex parent test^if reflex parent NLT^
+2 SET LRORDTYP=$$ORDTYP^LRTSTJM1()
+3 IF LRORDTYP<1
SET LRADD1=1
QUIT
+4 IF $PIECE(LRORDTYP,"^")=2
Begin DoDot:1
+5 NEW LRORDTST
+6 SET LRORDTST=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSP,0)),U,9)
+7 IF LRORDTST=""
SET LRORDTST=LRTSP
+8 SET $PIECE(LRORDTYP,"^",3)=LRORDTST
SET $PIECE(LRORDTYP,"^",4)=$$NLT^LRVER1(LRORDTST)
End DoDot:1
+9 ;CIDC
IF +LRDPF=2
IF $GET(LRSS)'="BB"
IF '$$CHKINP^LRBEBA4(LRDFN,LRODT)
SET LRBERF=$SELECT(LRORDTYP>0:LRORDTYP-1,1:-1)
+10 DO EN^LRTSTSET
+11 KILL DIC("B")
+12 if $DATA(LRTSAD(2))
QUIT
+13 SET LRADDTST=1
+14 QUIT
+15 ;
+16 ;
IDENT ;D LRACC^LRTSTOUT Q:LREND
FXID ;
+1 SET LRACC=1
DO LRACC^LRTSTOUT
KILL LRACC
if LRAN<1
QUIT
+2 SET LRWDT1=DA(1)
if $DATA(^LRO(68,LRAA,.3))#2
DO ^LRWLST2
GOTO FXID
+3 ;
% READ %:DTIME
if %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 QUIT
+2 ;
+3 ;
END ;
+1 IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+2 KILL %,A,AGE,DD,DFN,DIC,DIE,DO,DOB,DR,I,K,LRAA,LRAD,LRACD,LRAN,LRCCOM,LRDFN,LRDPF,LREND,LRIDT,LRODT,LRSN,LRSS,LRTNM,LRTS,LRWRD,PNM,SEX,SSN,X,Y,Z,LRUSNM
+3 KILL %DT,%H,%X,%Y,DA,J,LRBED,LRCS,LRCSS,LRDTM,LRDTO,LRGVP,LRIDENT,LRIOZERO,LRLLOC,LRLWC,LRNOP,LRONE,LRORD,LRORDTIM,LROWLE,LRPR,LRTP,LRTSN,LRUR,LRUSNM,LRWDT1,LRXD,POP,T
+4 KILL LRTSAD,LRTSUB,LRDATE,D,D0,D1,DN,LRAODT,LRFLG,LRRB,LRSAMP,LRTREA,LRTSP
+5 KILL LRURG,VA,LRX,LRBERF,LRBETN
+6 QUIT
+7 ;
+8 ;
CHK ; from LRTSTJAN
+1 DO CHK1
IF LREND
WRITE !,$CHAR(7),"CAN'T DO IT. The data has been approved for that log number."
+2 QUIT
+3 ;
+4 ;
CHK1 ;
+1 IF $DATA(^LRO(68,LRWL1,1,LRWDT1,1,LRAN,3))
IF $PIECE(^(3),U,4)
SET LREND=1
QUIT
+2 IF $DATA(^LRO(69,LRODT,1,LRSN,3))
IF $PIECE(^(3),U,2)
SET LREND=1
QUIT
+3 SET LRTST=0
FOR
SET LRTST=$ORDER(^LRO(68,LRWL1,1,LRWDT1,1,LRAN,4,LRTST))
if LRTST<1
QUIT
IF $DATA(^(LRTST,0))
IF $PIECE(^(0),U,5)
SET LREND=1
QUIT
+4 QUIT
UNLOCK ;
+1 IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+2 QUIT
