- 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
