LRTSTJAM ;SLC/CJS/JAH - JAM TESTS ONTO (OR OFF) ACCESSIONS ;8/10/04
;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
;
;;VA LR Patch(s): 121,153,291
;
EN ;
ADD I $G(LRAA),$G(LRAD),$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
K LRPARAM D ^LRPARAM G:'$D(LRPARAM) END S LRACC=1 D LRACC^LRTSTOUT K LRACC,LRTSAD,LRNATURE G:LRAN<1 END ;ADD A TEST
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,2) W !?5,"This is not a valid Accession number ",!,$C(7) G ADD
L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !?5,"Someone else is editing this entry ",!,$C(7) G ADD
; 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
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
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,HRCN ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
;
D:'$D(LRNATURE) NEW^LROR6() I $G(LRNATURE)=-1 W !!,"...process aborted",$C(7) K LRNATURE G ADD
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 G:Y<1 ADD S LRTSP=$P(Y,U,2) W !
ADDTST S DIC("A")="Add LABORATORY TEST: ",DIC=60,DIC(0)="AEMOQ",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") G ADD:Y<1 W !," ...OK" S %=1 D YN^DICN
G ADDTST:%=2,ADD:%'=1 S (LRTS,I)=+Y I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0)) W !,"The accession already has this test." G ADDTST
S LRTSUB=1 D EXPLD^LRTSTJM1 I $D(LRTSAD(1,LRTS)) W !,"The accession already has this test." G ADDTST
I $D(^LAB(60,I,8,+DUZ(2),0)) S J=$P(^LAB(60,I,8,+DUZ(2),0),U,2) I J,J'=LRAA W !,"That test normally belongs to accession area ",$P(^LRO(68,J,0),U),",",!,"are you sure" S %=2 D YN^DICN G ADD:%'=1
I $O(^LAB(60,LRTS,2,0)) S LRTSURG=$P(^LAB(60,LRTS,0),U,18) K LRTSAD(2) S LRTSAD(2,LRTS)="" S LRTSUB=2 D EXPLD^LRTSTJM1,COMPTST^LRTSTJM1 I 'LRTSUB G ADDTST
S LRFLG=1 S (LRURG,Y)=$P(^LAB(60,I,0),U,18) G SETTST:$L(Y)
ADDURG S DIC=62.05,DIC("B")="ROUTINE" D ^DIC K DIC("B") W:Y<1 !,"URGENCY must be defined. Test not added." G ADDTST:Y<1 W !," ...OK" S %=1 D YN^DICN
G ADDURG:%=2,ADD:%<1 S LRURG=+Y,LRFLG=""
SETTST ;
D:+LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
.S LRBERF=$$RFLX^LRBEBA4() ; CIDC
G EN^LRTSTSET Q
Q
IDENT ;D LRACC^LRTSTOUT Q:LREND
FXID S LRACC=1 D LRACC^LRTSTOUT K LRACC Q:LRAN<1 ;R !,"What Accession number: ",X:DTIME Q:X=""!(X["^")
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
K HRCN ; IHS/MSC/MKK - LR*5.2*1031
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
LRTSTJAM ;SLC/CJS/JAH - JAM TESTS ONTO (OR OFF) ACCESSIONS ;8/10/04
+1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 121,153,291
+4 ;
EN ;
ADD IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+1 ;ADD A TEST
KILL LRPARAM
DO ^LRPARAM
IF '$DATA(LRPARAM)
GOTO END
SET LRACC=1
DO LRACC^LRTSTOUT
KILL LRACC,LRTSAD,LRNATURE
IF LRAN<1
GOTO END
+2 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,2)
WRITE !?5,"This is not a valid Accession number ",!,$CHAR(7)
GOTO ADD
+3 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):1
IF '$TEST
WRITE !?5,"Someone else is editing this entry ",!,$CHAR(7)
GOTO ADD
+4 ; 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
+5 ;
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+7 ;IHS/ANMC/CLS 08/18/96
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,HRCN
+8 ;----- END IHS MODIFICATIONS
+9 ;
+10 IF '$DATA(LRNATURE)
DO NEW^LROR6()
IF $GET(LRNATURE)=-1
WRITE !!,"...process aborted",$CHAR(7)
KILL LRNATURE
GOTO ADD
+11 WRITE !,"TESTS ALREADY ON THE ACCESSION: "
SET I=0
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)=""
LRTSP WRITE !
KILL DIC,DA
SET DIC("A")="Select Original Ordered Test "
SET DA=LRSN
SET DA(1)=LRODT
+1 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U,2)
SET DIC("S")="I $L($P($G(^(.3)),U))"
+2 SET DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET DIC(0)="AQEZNM"
+3 WRITE !
DO ^DIC
KILL DIC,DA
IF Y<1
GOTO ADD
SET LRTSP=$PIECE(Y,U,2)
WRITE !
ADDTST SET DIC("A")="Add LABORATORY TEST: "
SET DIC=60
SET DIC(0)="AEMOQ"
SET DIC("S")="I $P(^(0),U,4)'="""""_$SELECT('$DATA(^XUSEC("LRSUPER",DUZ)):",""N""'[$P(^(0),U,3)",1:"")
DO ^DIC
KILL DIC("A"),DIC("S")
IF Y<1
GOTO ADD
WRITE !," ...OK"
SET %=1
DO YN^DICN
+1 IF %=2
GOTO ADDTST
IF %'=1
GOTO ADD
SET (LRTS,I)=+Y
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
WRITE !,"The accession already has this test."
GOTO ADDTST
+2 SET LRTSUB=1
DO EXPLD^LRTSTJM1
IF $DATA(LRTSAD(1,LRTS))
WRITE !,"The accession already has this test."
GOTO ADDTST
+3 IF $DATA(^LAB(60,I,8,+DUZ(2),0))
SET J=$PIECE(^LAB(60,I,8,+DUZ(2),0),U,2)
IF J
IF J'=LRAA
WRITE !,"That test normally belongs to accession area ",$PIECE(^LRO(68,J,0),U),",",!,"are you sure"
SET %=2
DO YN^DICN
IF %'=1
GOTO ADD
+4 IF $ORDER(^LAB(60,LRTS,2,0))
SET LRTSURG=$PIECE(^LAB(60,LRTS,0),U,18)
KILL LRTSAD(2)
SET LRTSAD(2,LRTS)=""
SET LRTSUB=2
DO EXPLD^LRTSTJM1
DO COMPTST^LRTSTJM1
IF 'LRTSUB
GOTO ADDTST
+5 SET LRFLG=1
SET (LRURG,Y)=$PIECE(^LAB(60,I,0),U,18)
IF $LENGTH(Y)
GOTO SETTST
ADDURG SET DIC=62.05
SET DIC("B")="ROUTINE"
DO ^DIC
KILL DIC("B")
IF Y<1
WRITE !,"URGENCY must be defined. Test not added."
IF Y<1
GOTO ADDTST
WRITE !," ...OK"
SET %=1
DO YN^DICN
+1 IF %=2
GOTO ADDURG
IF %<1
GOTO ADD
SET LRURG=+Y
SET LRFLG=""
SETTST ;
+1 IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+2 ; CIDC
SET LRBERF=$$RFLX^LRBEBA4()
End DoDot:1
+3 GOTO EN^LRTSTSET
QUIT
+4 QUIT
IDENT ;D LRACC^LRTSTOUT Q:LREND
FXID ;R !,"What Accession number: ",X:DTIME Q:X=""!(X["^")
SET LRACC=1
DO LRACC^LRTSTOUT
KILL LRACC
IF LRAN<1
QUIT
+1 SET LRWDT1=DA(1)
IF $DATA(^LRO(68,LRAA,.3))#2
DO ^LRWLST2
GOTO FXID
+2 ;
% READ %:DTIME
IF %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 QUIT
END IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+1 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
+2 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
+3 KILL LRTSAD,LRTSUB,LRDATE,D,D0,D1,DN,LRAODT,LRFLG,LRRB,LRSAMP,LRTREA,LRTSP
+4 KILL LRURG,VA,LRX,LRBERF,LRBETN
+5 ; IHS/MSC/MKK - LR*5.2*1031
KILL HRCN
+6 QUIT
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
CHK1 IF $DATA(^LRO(68,LRWL1,1,LRWDT1,1,LRAN,3))
IF $PIECE(^(3),U,4)
SET LREND=1
QUIT
+1 IF $DATA(^LRO(69,LRODT,1,LRSN,3))
IF $PIECE(^(3),U,2)
SET LREND=1
QUIT
+2 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
+3 QUIT
