- LRWLST ;VA/FHS/DALOI - ACCESSION SETUP. LROE1,LRSTIK & LRFAST CALL HERE ; Aug 9, 2004
- ;;5.2;LAB SERVICE;**1018,1025,1030,1031**;NOV 01, 1997
- ;
- ;;VA LR Patch(s): 46,65,100,121,153,202,290
- ;
- EP ; EP
- N LRPWL,LRPWDT,LRPWLE
- D DT^LRX
- Q:$G(LRKIL)
- D:$D(XRTL) T0^%ZOSV ; START RESPONSE TIME LOGGING
- ; S LRCDT=+^LRO(69,LRODT,1,LRSN,1),LREAL=$P(^(1),U,2),X=^(0),LRLLOC=$P(X,U,7),LROLLOC=$P(X,U,9),LRORIFN=$P(X,"^",11)
- ;
- ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
- ; Need to remove the naked references because they are causing
- ; <UNDEFINED> errors at numerous IHS sites.
- S LRCDT=+$G(^LRO(69,LRODT,1,LRSN,1))
- S LREAL=$P($G(^LRO(69,LRODT,1,LRSN,1)),U,2)
- S X=$G(^LRO(69,LRODT,1,LRSN,0))
- S LRLLOC=$P(X,U,7)
- S LROLLOC=$P(X,U,9)
- S LRORIFN=$P(X,"^",11)
- ; ----- END IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
- ;
- D LRAA,^LRWLST1
- S LRCDT=(+LRCDT)_"^"_LREAL
- I '$L($P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)) S CONTROL=$S($L(LRORIFN):"SC",1:"SN") D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
- K LRTSTS,^TMP("LR",$J,"TMP"),LRNM,DIC,I,LRORIFN,LRBACK
- I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV ; STOP RESPONSE TIME LOGGING
- ;
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- ; Cannot call at LRFASTS option -- no Ask-At-Order questions have been asked yet
- ; If not LRFASTS option, then AAO questions have been asked, so store
- D:$G(XQZ)'="LRFASTS" ORDNSTOR^BLRAAORU(+$G(^LRO(69,LRODT,1,LRSN,.1))) ;
- ; ----- END IHS/OIT/MKK - LR*5.2*1030
- ;
- Q
- ;
- LRAA ; EP
- K LRTSTS,^TMP("LR",$J,"TMP")
- S LRTSTS=0,LRIX=0,S5=0,LRTN=0
- F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1 D
- . N LRX
- . S LRX=^(LRTN,0) I '$P(LRX,U,3),'$P(LRX,U,6),'$P(LRX,U,8),'$P(LRX,U,11) S LRORIFN=$P(LRX,"^",7),LRBACK=$P(LRX,"^",14) D SET
- ;
- WL1 ; EP
- ; LRDAA is used by POC interface to specify the POC accession area.
- S LRIX=0
- F S LRIX=$O(^TMP("LR",$J,"TMP",LRIX)) Q:LRIX<1 D
- . S X=^(LRIX),LRTSTS=+X,LRURG=$P(X,"^",2),LRORIFN=$P(X,"^",4),LRBACK=$P(X,"^",5)
- . S LRST=^LAB(60,LRTSTS,0)
- . S LRAA=$S($G(LRDAA)>0:LRDAA,$D(^LAB(60,LRTSTS,8,$S($G(LRDUZ(2))>0:LRDUZ(2),1:DUZ(2)),0)):$P(^(0),U,2),1:"")
- . S LRNM=$P(LRST,U),LRUNQ=+$P(LRST,U,7)
- . D WL2
- ;
- Q
- ;
- WL2 ; EP
- D FWL:$G(LRAA)="" Q:LRAA=""
- S LRWL0=^LRO(68,LRAA,0),LRSS=$P(LRWL0,U,2),LRIDIV=$S($L($P(LRWL0,U,19)):$P(LRWL0,U,19),1:"CP")
- I '$D(LRPHSET),$D(LRNCWL) W !,LRNM," TO ",$P(^LRO(68,LRAA,0),U)," accessions","? Y//" D YN Q:X="^" IF X["N" S LRAA="" G WL2
- ;added following line to support unique ID/DALISC/JRR
- I $P($G(^LRO(68,LRAA,.4)),U)="" D S LRAA="" Q
- . W:'$D(LRPHSET) !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!",!?10,"Accession Area ",$P($G(^LRO(68,+$G(LRAA),0)),U),!
- . D UNDO
- S LRPWL=$P($G(^LRO(68,LRAA,0)),U,4)
- I LRPWL,$P($G(^LRO(68,LRPWL,.4)),U)="" D S LRAA="" Q
- . I $G(LRQUIET) D UNDO Q
- . W:'$D(LRPHSET) !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!"
- . W !?10,"COMMON Accession Area ",$P($G(^LRO(68,+$G(LRPWL),0)),U),!
- . D UNDO
- ;
- S LRWLC=$P(LRWL0,U,4)
- S:'LRWLC LRWLC=LRAA
- S LRTSTS(LRWLC,LRUNQ,LRAA)=LRSS_U_$P(LRWL0,U,12),LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)=^TMP("LR",$J,"TMP",LRIX)
- Q
- ;
- SET ;
- I $G(LRORDRR)="R" S LRTEST(LRTN)=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
- S S5=S5+1,I5=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
- I I5 S ^TMP("LR",$J,"TMP",S5)=$P(I5,U)_U_$P(I5,U,2)_U_LRTN_U_LRORIFN_U_LRBACK_U_$S($G(LRTSP):LRTSP,1:$P(I5,U)),I5=LRTN
- Q
- ;
- FWL ;
- I $O(^LAB(60,LRTSTS,2,0))>0 D EXP S $P(^LRO(69,LRODT,1,LRSN,2,$P(^TMP("LR",$J,"TMP",LRIX),U,3),0),U,8)=1 Q
- I '$D(LRNCWL),$D(LRPHSET),LRPHSET W !,"NO ACCESSION AREA FOR ORDER NUMBER ",^LRO(69,LRODT,1,LRSN,.1)," TEST ",$P(^LAB(60,LRTSTS,0),U),! D UNDO Q
- ; I '$D(LRNCWL) W !,LRNM," does not have an appropriate accession area.",!,"ORDER # ",LRORD," IS NOT ACCESSIONED",! S LRAA="" D UNDO Q
- I '$D(LRNCWL) D Q
- . D:+$P($G(^BLRSITE($G(DUZ(2)),0)),U,10) ENTRYAUD^BLRUTIL("FWL^LRWLST 2.0")
- . W !,LRNM," does not have an appropriate accession area.",!,"ORDER # ",LRORD," IS NOT ACCESSIONED",!
- . S LRAA=""
- . D UNDO
- ;
- W !,"For test: ",LRNM
- K DIC
- S DIC("S")="I '$L($P(^(0),U,17))",DIC="^LRO(68,",DIC(0)="AEFOQZ"
- D ^DIC
- K DIC
- I $D(DUOUT) S LRAA="" Q
- G:Y<1 FWL
- S LRAA=+Y
- Q
- ;
- EXP ;
- S I=0
- F S I=$O(^LAB(60,LRTSTS,2,I)) Q:I<1 S J=+^(I,0) I $D(^LAB(60,J,8,DUZ(2),0)) S S5=S5+1,I5=I5+1,^TMP("LR",$J,"TMP",S5)=J_"^"_LRURG_"^"_I5_"^"_LRORIFN_"^"_LRBACK_"^"_$S($G(LRTSP):LRTSP,1:LRTSTS)
- Q
- ;
- PRESET ;
- I '($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2) K ^LRO(68,LRAA,1,LRAD,1,LRAN) Q
- S LROLRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
- ; I $L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)) S LRDPF=$P(^LR(LROLRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM," ",SSN," has that log #." S LREND=1 Q ;W !," OK to change it? N//" D YN I X=""!(X'["Y") S LREND=1 Q
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- I $L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)) S LRDPF=$P(^LR(LROLRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM," ",HRCN," has that log #." S LREND=1 Q ;W !," OK to change it? N//" D YN I X=""!(X'["Y") S LREND=1 Q ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- S LRIDT=9999999-^LRO(68,LRAA,1,LRAD,1,LRAN,3)
- Q:'$D(^LR(LROLRDFN,LRSS,LRIDT,0))
- ;
- PR2 ;
- S LRNIDT=9999999-LRCDT
- F Q:'$D(^LR(LRDFN,LRSS,LRNIDT,0)) D
- . S LRCDT=$$FMADD^XLFDT(LRCDT,,,,1)
- . S LRNIDT=9999999-LRCDT
- I $P(^LR(LROLRDFN,LRSS,LRIDT,0),U,3) S LREND=1 W !,$C(7),"CAN'T DO IT. The data has been verified for that log number." Q
- S ^LR(LRDFN,LRSS,LRNIDT,0)=LRCDT_U_LREAL_U_$P(^LR(LROLRDFN,LRSS,LRIDT,0),U,3,4)_U_U_$P(^(0),U,6,99)
- S J=0 F S J=$O(^LR(LROLRDFN,LRSS,LRIDT,J)) Q:J<1 S ^LR(LRDFN,LRSS,LRNIDT,J)=^LR(LROLRDFN,LRSS,LRIDT,J)
- S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LROSN=$P(X,U,5),LROID=$P(X,U,6),LROCN=$S($D(^(.1)):$P(^(.1),U),1:"")
- K:$L(LROID) ^LRO(68,LRAA,1,LRAD,1,"C",LROID,LRAN)
- K:$L(LROCN) ^LRO(68,LRAA,1,LRAD,1,"D",LROCN,LRAN)
- K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LR(LROLRDFN,LRSS,LRIDT)
- Q
- ;
- YN ;
- R X:DTIME
- S:'$T DTOUT=1
- Q:X=""!(X["N")!(X["Y")
- W !,"Answer 'Y' or 'N': " G YN
- ;
- UNDO ;Clean up ^LRO(69
- N X,TST
- S LRIFN=+$O(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,0)) Q:LRIFN<1
- S $P(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^"
- S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="U" ;,$P(^(1),U,6)=LRNM_" NOT ACCESSIONED - TEST DEFINITION INCOMPLETE"
- Q
- S X=$G(^LRO(69,LRODT,1,LRSN,2,LRIFN,0)) Q:'X S TST(+X)=""
- S X=$S($D(^LRO(69,LRODT,1,LRSN,2,LRIFN,1.1,0)):$P(^(0),"^",3),1:0)+1,^(0)="^^"_X_"^"_X_"^"_DT,^(X,0)="Not accessioned - Test definition incomplete"
- D NEW^LR7OB1(LRODT,LRSN,"OC",,.TST)
- S $P(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ
- Q
- ;
- OR ;from LRPHITEM
- I $G(LRORDRR)="R" S LRTEST(LRTN)=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
- ;
- ; ----- BEGIN IHS/MSC/MKK -- LR*5.2*1031 -- Restoring LR*5.2*1018 code
- I $$VER^LR7OU1>2.5 D Q
- . S LRI=LRTN
- . S LRORD=+^LRO(69,LRODT,1,LRSN,.1)
- . S LRLWC=$P(^(0),"^",4)
- . S LRSAMP=$P(^(0),"^",3)
- . S LRSPEC=$S($O(^(4,0))'="":$P(^($O(^(0)),0),"^"),1:"")
- . S LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
- ;
- I 'LRORIFN D Q
- . S LRI=LRTN
- . S LRORD=+^LRO(69,LRODT,1,LRSN,.1)
- . S LRLWC=$P(^(0),"^",4)
- . S LRSAMP=$P(^(0),"^",3)
- . S LRSPEC=$S($O(^(4,0))'="":$P(^($O(^(0)),0),"^"),1:"")
- . S LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
- . D SET^LROR
- ;
- ; LRORIFN>0
- S ORIFN=LRORIFN
- S ORSTS=6
- D ST^ORX
- K ORSTS,ORIFN
- ; ----- END IHS/MSC/MKK - LR*5.2*1031
- ;
- Q
- LRWLST ;VA/FHS/DALOI - ACCESSION SETUP. LROE1,LRSTIK & LRFAST CALL HERE ; Aug 9, 2004
- +1 ;;5.2;LAB SERVICE;**1018,1025,1030,1031**;NOV 01, 1997
- +2 ;
- +3 ;;VA LR Patch(s): 46,65,100,121,153,202,290
- +4 ;
- EP ; EP
- +1 NEW LRPWL,LRPWDT,LRPWLE
- +2 DO DT^LRX
- +3 IF $GET(LRKIL)
- QUIT
- +4 ; START RESPONSE TIME LOGGING
- IF $DATA(XRTL)
- DO T0^%ZOSV
- +5 ; S LRCDT=+^LRO(69,LRODT,1,LRSN,1),LREAL=$P(^(1),U,2),X=^(0),LRLLOC=$P(X,U,7),LROLLOC=$P(X,U,9),LRORIFN=$P(X,"^",11)
- +6 ;
- +7 ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
- +8 ; Need to remove the naked references because they are causing
- +9 ; <UNDEFINED> errors at numerous IHS sites.
- +10 SET LRCDT=+$GET(^LRO(69,LRODT,1,LRSN,1))
- +11 SET LREAL=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,2)
- +12 SET X=$GET(^LRO(69,LRODT,1,LRSN,0))
- +13 SET LRLLOC=$PIECE(X,U,7)
- +14 SET LROLLOC=$PIECE(X,U,9)
- +15 SET LRORIFN=$PIECE(X,"^",11)
- +16 ; ----- END IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
- +17 ;
- +18 DO LRAA
- DO ^LRWLST1
- +19 SET LRCDT=(+LRCDT)_"^"_LREAL
- +20 IF '$LENGTH($PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7))
- SET CONTROL=$SELECT($LENGTH(LRORIFN):"SC",1:"SN")
- DO NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
- +21 KILL LRTSTS,^TMP("LR",$JOB,"TMP"),LRNM,DIC,I,LRORIFN,LRBACK
- +22 ; STOP RESPONSE TIME LOGGING
- IF $DATA(XRT0)
- SET XRTN=$TEXT(+0)
- DO T1^%ZOSV
- +23 ;
- +24 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- +25 ; Cannot call at LRFASTS option -- no Ask-At-Order questions have been asked yet
- +26 ; If not LRFASTS option, then AAO questions have been asked, so store
- +27 ;
- IF $GET(XQZ)'="LRFASTS"
- DO ORDNSTOR^BLRAAORU(+$GET(^LRO(69,LRODT,1,LRSN,.1)))
- +28 ; ----- END IHS/OIT/MKK - LR*5.2*1030
- +29 ;
- +30 QUIT
- +31 ;
- LRAA ; EP
- +1 KILL LRTSTS,^TMP("LR",$JOB,"TMP")
- +2 SET LRTSTS=0
- SET LRIX=0
- SET S5=0
- SET LRTN=0
- +3 FOR
- SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
- IF LRTN<1
- QUIT
- Begin DoDot:1
- +4 NEW LRX
- +5 SET LRX=^(LRTN,0)
- IF '$PIECE(LRX,U,3)
- IF '$PIECE(LRX,U,6)
- IF '$PIECE(LRX,U,8)
- IF '$PIECE(LRX,U,11)
- SET LRORIFN=$PIECE(LRX,"^",7)
- SET LRBACK=$PIECE(LRX,"^",14)
- DO SET
- End DoDot:1
- +6 ;
- WL1 ; EP
- +1 ; LRDAA is used by POC interface to specify the POC accession area.
- +2 SET LRIX=0
- +3 FOR
- SET LRIX=$ORDER(^TMP("LR",$JOB,"TMP",LRIX))
- IF LRIX<1
- QUIT
- Begin DoDot:1
- +4 SET X=^(LRIX)
- SET LRTSTS=+X
- SET LRURG=$PIECE(X,"^",2)
- SET LRORIFN=$PIECE(X,"^",4)
- SET LRBACK=$PIECE(X,"^",5)
- +5 SET LRST=^LAB(60,LRTSTS,0)
- +6 SET LRAA=$SELECT($GET(LRDAA)>0:LRDAA,$DATA(^LAB(60,LRTSTS,8,$SELECT($GET(LRDUZ(2))>0:LRDUZ(2),1:DUZ(2)),0)):$PIECE(^(0),U,2),1:"")
- +7 SET LRNM=$PIECE(LRST,U)
- SET LRUNQ=+$PIECE(LRST,U,7)
- +8 DO WL2
- End DoDot:1
- +9 ;
- +10 QUIT
- +11 ;
- WL2 ; EP
- +1 IF $GET(LRAA)=""
- DO FWL
- IF LRAA=""
- QUIT
- +2 SET LRWL0=^LRO(68,LRAA,0)
- SET LRSS=$PIECE(LRWL0,U,2)
- SET LRIDIV=$SELECT($LENGTH($PIECE(LRWL0,U,19)):$PIECE(LRWL0,U,19),1:"CP")
- +3 IF '$DATA(LRPHSET)
- IF $DATA(LRNCWL)
- WRITE !,LRNM," TO ",$PIECE(^LRO(68,LRAA,0),U)," accessions","? Y//"
- DO YN
- IF X="^"
- QUIT
- IF X["N"
- SET LRAA=""
- GOTO WL2
- +4 ;added following line to support unique ID/DALISC/JRR
- +5 IF $PIECE($GET(^LRO(68,LRAA,.4)),U)=""
- Begin DoDot:1
- +6 IF '$DATA(LRPHSET)
- WRITE !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!",!?10,"Accession Area ",$PIECE($GET(^LRO(68,+$GET(LRAA),0)),U),!
- +7 DO UNDO
- End DoDot:1
- SET LRAA=""
- QUIT
- +8 SET LRPWL=$PIECE($GET(^LRO(68,LRAA,0)),U,4)
- +9 IF LRPWL
- IF $PIECE($GET(^LRO(68,LRPWL,.4)),U)=""
- Begin DoDot:1
- +10 IF $GET(LRQUIET)
- DO UNDO
- QUIT
- +11 IF '$DATA(LRPHSET)
- WRITE !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!"
- +12 WRITE !?10,"COMMON Accession Area ",$PIECE($GET(^LRO(68,+$GET(LRPWL),0)),U),!
- +13 DO UNDO
- End DoDot:1
- SET LRAA=""
- QUIT
- +14 ;
- +15 SET LRWLC=$PIECE(LRWL0,U,4)
- +16 IF 'LRWLC
- SET LRWLC=LRAA
- +17 SET LRTSTS(LRWLC,LRUNQ,LRAA)=LRSS_U_$PIECE(LRWL0,U,12)
- SET LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)=^TMP("LR",$JOB,"TMP",LRIX)
- +18 QUIT
- +19 ;
- SET ;
- +1 IF $GET(LRORDRR)="R"
- SET LRTEST(LRTN)=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
- +2 SET S5=S5+1
- SET I5=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
- +3 IF I5
- SET ^TMP("LR",$JOB,"TMP",S5)=$PIECE(I5,U)_U_$PIECE(I5,U,2)_U_LRTN_U_LRORIFN_U_LRBACK_U_$SELECT($GET(LRTSP):LRTSP,1:$PIECE(I5,U))
- SET I5=LRTN
- +4 QUIT
- +5 ;
- FWL ;
- +1 IF $ORDER(^LAB(60,LRTSTS,2,0))>0
- DO EXP
- SET $PIECE(^LRO(69,LRODT,1,LRSN,2,$PIECE(^TMP("LR",$JOB,"TMP",LRIX),U,3),0),U,8)=1
- QUIT
- +2 IF '$DATA(LRNCWL)
- IF $DATA(LRPHSET)
- IF LRPHSET
- WRITE !,"NO ACCESSION AREA FOR ORDER NUMBER ",^LRO(69,LRODT,1,LRSN,.1)," TEST ",$PIECE(^LAB(60,LRTSTS,0),U),!
- DO UNDO
- QUIT
- +3 ; I '$D(LRNCWL) W !,LRNM," does not have an appropriate accession area.",!,"ORDER # ",LRORD," IS NOT ACCESSIONED",! S LRAA="" D UNDO Q
- +4 IF '$DATA(LRNCWL)
- Begin DoDot:1
- +5 IF +$PIECE($GET(^BLRSITE($GET(DUZ(2)),0)),U,10)
- DO ENTRYAUD^BLRUTIL("FWL^LRWLST 2.0")
- +6 WRITE !,LRNM," does not have an appropriate accession area.",!,"ORDER # ",LRORD," IS NOT ACCESSIONED",!
- +7 SET LRAA=""
- +8 DO UNDO
- End DoDot:1
- QUIT
- +9 ;
- +10 WRITE !,"For test: ",LRNM
- +11 KILL DIC
- +12 SET DIC("S")="I '$L($P(^(0),U,17))"
- SET DIC="^LRO(68,"
- SET DIC(0)="AEFOQZ"
- +13 DO ^DIC
- +14 KILL DIC
- +15 IF $DATA(DUOUT)
- SET LRAA=""
- QUIT
- +16 IF Y<1
- GOTO FWL
- +17 SET LRAA=+Y
- +18 QUIT
- +19 ;
- EXP ;
- +1 SET I=0
- +2 FOR
- SET I=$ORDER(^LAB(60,LRTSTS,2,I))
- IF I<1
- QUIT
- SET J=+^(I,0)
- IF $DATA(^LAB(60,J,8,DUZ(2),0))
- SET S5=S5+1
- SET I5=I5+1
- SET ^TMP("LR",$JOB,"TMP",S5)=J_"^"_LRURG_"^"_I5_"^"_LRORIFN_"^"_LRBACK_"^"_$SELECT($GET(LRTSP):LRTSP,1:LRTSTS)
- +3 QUIT
- +4 ;
- PRESET ;
- +1 IF '($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2)
- KILL ^LRO(68,LRAA,1,LRAD,1,LRAN)
- QUIT
- +2 SET LROLRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
- +3 ; I $L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)) S LRDPF=$P(^LR(LROLRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM," ",SSN," has that log #." S LREND=1 Q ;W !," OK to change it? N//" D YN I X=""!(X'["Y") S LREND=1 Q
- +4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +5 ;W !," OK to change it? N//" D YN I X=""!(X'["Y") S LREND=1 Q ;IHS/ANMC/CLS 08/18/96
- IF $LENGTH($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5))
- SET LRDPF=$PIECE(^LR(LROLRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- WRITE !,PNM," ",HRCN," has that log #."
- SET LREND=1
- QUIT
- +6 ;----- END IHS MODIFICATIONS
- +7 SET LRIDT=9999999-^LRO(68,LRAA,1,LRAD,1,LRAN,3)
- +8 IF '$DATA(^LR(LROLRDFN,LRSS,LRIDT,0))
- QUIT
- +9 ;
- PR2 ;
- +1 SET LRNIDT=9999999-LRCDT
- +2 FOR
- IF '$DATA(^LR(LRDFN,LRSS,LRNIDT,0))
- QUIT
- Begin DoDot:1
- +3 SET LRCDT=$$FMADD^XLFDT(LRCDT,,,,1)
- +4 SET LRNIDT=9999999-LRCDT
- End DoDot:1
- +5 IF $PIECE(^LR(LROLRDFN,LRSS,LRIDT,0),U,3)
- SET LREND=1
- WRITE !,$CHAR(7),"CAN'T DO IT. The data has been verified for that log number."
- QUIT
- +6 SET ^LR(LRDFN,LRSS,LRNIDT,0)=LRCDT_U_LREAL_U_$PIECE(^LR(LROLRDFN,LRSS,LRIDT,0),U,3,4)_U_U_$PIECE(^(0),U,6,99)
- +7 SET J=0
- FOR
- SET J=$ORDER(^LR(LROLRDFN,LRSS,LRIDT,J))
- IF J<1
- QUIT
- SET ^LR(LRDFN,LRSS,LRNIDT,J)=^LR(LROLRDFN,LRSS,LRIDT,J)
- +8 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
- SET LROSN=$PIECE(X,U,5)
- SET LROID=$PIECE(X,U,6)
- SET LROCN=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:"")
- +9 IF $LENGTH(LROID)
- KILL ^LRO(68,LRAA,1,LRAD,1,"C",LROID,LRAN)
- +10 IF $LENGTH(LROCN)
- KILL ^LRO(68,LRAA,1,LRAD,1,"D",LROCN,LRAN)
- +11 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LR(LROLRDFN,LRSS,LRIDT)
- +12 QUIT
- +13 ;
- YN ;
- +1 READ X:DTIME
- +2 IF '$TEST
- SET DTOUT=1
- +3 IF X=""!(X["N")!(X["Y")
- QUIT
- +4 WRITE !,"Answer 'Y' or 'N': "
- GOTO YN
- +5 ;
- UNDO ;Clean up ^LRO(69
- +1 NEW X,TST
- +2 SET LRIFN=+$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,0))
- IF LRIFN<1
- QUIT
- +3 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^"
- +4 ;,$P(^(1),U,6)=LRNM_" NOT ACCESSIONED - TEST DEFINITION INCOMPLETE"
- SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)="U"
- +5 QUIT
- +6 SET X=$GET(^LRO(69,LRODT,1,LRSN,2,LRIFN,0))
- IF 'X
- QUIT
- SET TST(+X)=""
- +7 SET X=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,2,LRIFN,1.1,0)):$PIECE(^(0),"^",3),1:0)+1
- SET ^(0)="^^"_X_"^"_X_"^"_DT
- SET ^(X,0)="Not accessioned - Test definition incomplete"
- +8 DO NEW^LR7OB1(LRODT,LRSN,"OC",,.TST)
- +9 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^"
- SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
- +10 QUIT
- +11 ;
- OR ;from LRPHITEM
- +1 IF $GET(LRORDRR)="R"
- SET LRTEST(LRTN)=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
- QUIT
- +2 ;
- +3 ; ----- BEGIN IHS/MSC/MKK -- LR*5.2*1031 -- Restoring LR*5.2*1018 code
- +4 IF $$VER^LR7OU1>2.5
- Begin DoDot:1
- +5 SET LRI=LRTN
- +6 SET LRORD=+^LRO(69,LRODT,1,LRSN,.1)
- +7 SET LRLWC=$PIECE(^(0),"^",4)
- +8 SET LRSAMP=$PIECE(^(0),"^",3)
- +9 SET LRSPEC=$SELECT($ORDER(^(4,0))'="":$PIECE(^($ORDER(^(0)),0),"^"),1:"")
- +10 SET LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
- End DoDot:1
- QUIT
- +11 ;
- +12 IF 'LRORIFN
- Begin DoDot:1
- +13 SET LRI=LRTN
- +14 SET LRORD=+^LRO(69,LRODT,1,LRSN,.1)
- +15 SET LRLWC=$PIECE(^(0),"^",4)
- +16 SET LRSAMP=$PIECE(^(0),"^",3)
- +17 SET LRSPEC=$SELECT($ORDER(^(4,0))'="":$PIECE(^($ORDER(^(0)),0),"^"),1:"")
- +18 SET LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
- +19 DO SET^LROR
- End DoDot:1
- QUIT
- +20 ;
- +21 ; LRORIFN>0
- +22 SET ORIFN=LRORIFN
- +23 SET ORSTS=6
- +24 DO ST^ORX
- +25 KILL ORSTS,ORIFN
- +26 ; ----- END IHS/MSC/MKK - LR*5.2*1031
- +27 ;
- +28 QUIT
