LRCKF69 ;SLC/RWF - CHECK FILE 69 ; 2/22/87 1:47 PM ;
;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
S ZTRTN="ENT^LRCKF69" D LOG^LRCKF Q:LREND D ENT W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
ENT ;from LRCKF
U IO W !," CHECKING FILE 69",! S LRPSN=0,U="^" S:'$D(LRODT) LRODT=DT F I=1:1:10 S E(9,I)=0
F LRODT=0:0 S LRODT=$O(^LRO(69,LRODT)) Q:LRODT<1 D LRSN
W !! W:$E(IOST,1,2)="P-" @IOF Q
Q
LRSN I '$O(^LRO(69,LRODT,1,0)) W "." Q
S Y=LRODT D DD^LRX W:$Y'<IOSL @IOF W !,"ORDER DATE: ",Y
I LRODT["." W !?10,"BAD ORDER DATE ",!
F LRSN=0:0 S LRSN=$O(^LRO(69,LRODT,1,LRSN)) Q:LRSN'>0 D CHK69
Q
NAME S E(9,E)=1+E(9,E) I E(9,E)>20 S E=0 Q
I LRPSN'=LRSN W !!,"ORDER: ",LRORDER," LRSN: ",LRSN S LRPSN=LRSN
Q
CHK69 I $D(^LRO(69,LRODT,1,LRSN,0))[0 Q ;MUST BE A PLACE HOLDER
S LA=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LA,LRORDER=$S($D(^(.1)):^(.1),1:""),LRCTRL=$S($D(^LR(LRDFN,0))#2:$P(^(0),U,2),1:0)=62.3
I $D(^LR(LRDFN,0))[0 S E=1 D NAME I E W !?5,"F- Entry ",LRDFN," in ^LR( is missing."
I 'LRCTRL,LRORDER="" S E=2 D NAME I E W !?5,"F- Does not have an ORDER number."
I 'LRCTRL,$D(^LAB(62,+$P(LA,U,3),0))[0 S E=3 D NAME I E W !?5,"F- BAD pointer (",$P(LA,U,3),") to collection file."
I 'LRCTRL,$D(^VA(200,+$P(LA,U,2),0))[0 S E=4 D NAME I E W !?5,"F- BAD pointer to user New Person file."
F T=0:0 S T=$O(^LRO(69,LRODT,1,LRSN,2,T)) Q:T'>0 I $D(^(T,0))#2 S X=^(0) D TEST
F T=0:0 S T=$O(^LRO(69,LRODT,1,LRSN,4,T)) Q:T'>0 I $D(^(T,0))#2 S X=^(0) D SPEC
Q
TEST I $D(^LAB(60,+X,0))[0 S E=5 D NAME I E W !?5,"F- BAD pointer to test file (60)."
I $D(^LAB(62.05,+$P(X,U,2),0))[0 S E=6 D NAME I E W !?5,"F- BAD pointer to urgency file (62.05)."
S LRAD=$P(X,U,3),LRAA=$P(X,U,4),LRAN=$P(X,U,5)
I LRAA,LRAD,LRAN,$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))[0 S E=7 D NAME I E W !?5,"F- BAD pointer to the accession file."
Q
SPEC I $D(^LAB(61,+X,0))[0 S E=8 D NAME I E W !?5,"F- BAD pointer to the specimen file (61)."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCKF69 1936 printed Oct 16, 2024@18:14:30 Page 2
LRCKF69 ;SLC/RWF - CHECK FILE 69 ; 2/22/87 1:47 PM ;
+1 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
+2 SET ZTRTN="ENT^LRCKF69"
DO LOG^LRCKF
if LREND
QUIT
DO ENT
WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
QUIT
ENT ;from LRCKF
+1 USE IO
WRITE !," CHECKING FILE 69",!
SET LRPSN=0
SET U="^"
if '$DATA(LRODT)
SET LRODT=DT
FOR I=1:1:10
SET E(9,I)=0
+2 FOR LRODT=0:0
SET LRODT=$ORDER(^LRO(69,LRODT))
if LRODT<1
QUIT
DO LRSN
+3 WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
QUIT
+4 QUIT
LRSN IF '$ORDER(^LRO(69,LRODT,1,0))
WRITE "."
QUIT
+1 SET Y=LRODT
DO DD^LRX
if $Y'<IOSL
WRITE @IOF
WRITE !,"ORDER DATE: ",Y
+2 IF LRODT["."
WRITE !?10,"BAD ORDER DATE ",!
+3 FOR LRSN=0:0
SET LRSN=$ORDER(^LRO(69,LRODT,1,LRSN))
if LRSN'>0
QUIT
DO CHK69
+4 QUIT
NAME SET E(9,E)=1+E(9,E)
IF E(9,E)>20
SET E=0
QUIT
+1 IF LRPSN'=LRSN
WRITE !!,"ORDER: ",LRORDER," LRSN: ",LRSN
SET LRPSN=LRSN
+2 QUIT
CHK69 ;MUST BE A PLACE HOLDER
IF $DATA(^LRO(69,LRODT,1,LRSN,0))[0
QUIT
+1 SET LA=^LRO(69,LRODT,1,LRSN,0)
SET LRDFN=+LA
SET LRORDER=$SELECT($DATA(^(.1)):^(.1),1:"")
SET LRCTRL=$SELECT($DATA(^LR(LRDFN,0))#2:$PIECE(^(0),U,2),1:0)=62.3
+2 IF $DATA(^LR(LRDFN,0))[0
SET E=1
DO NAME
IF E
WRITE !?5,"F- Entry ",LRDFN," in ^LR( is missing."
+3 IF 'LRCTRL
IF LRORDER=""
SET E=2
DO NAME
IF E
WRITE !?5,"F- Does not have an ORDER number."
+4 IF 'LRCTRL
IF $DATA(^LAB(62,+$PIECE(LA,U,3),0))[0
SET E=3
DO NAME
IF E
WRITE !?5,"F- BAD pointer (",$PIECE(LA,U,3),") to collection file."
+5 IF 'LRCTRL
IF $DATA(^VA(200,+$PIECE(LA,U,2),0))[0
SET E=4
DO NAME
IF E
WRITE !?5,"F- BAD pointer to user New Person file."
+6 FOR T=0:0
SET T=$ORDER(^LRO(69,LRODT,1,LRSN,2,T))
if T'>0
QUIT
IF $DATA(^(T,0))#2
SET X=^(0)
DO TEST
+7 FOR T=0:0
SET T=$ORDER(^LRO(69,LRODT,1,LRSN,4,T))
if T'>0
QUIT
IF $DATA(^(T,0))#2
SET X=^(0)
DO SPEC
+8 QUIT
TEST IF $DATA(^LAB(60,+X,0))[0
SET E=5
DO NAME
IF E
WRITE !?5,"F- BAD pointer to test file (60)."
+1 IF $DATA(^LAB(62.05,+$PIECE(X,U,2),0))[0
SET E=6
DO NAME
IF E
WRITE !?5,"F- BAD pointer to urgency file (62.05)."
+2 SET LRAD=$PIECE(X,U,3)
SET LRAA=$PIECE(X,U,4)
SET LRAN=$PIECE(X,U,5)
+3 IF LRAA
IF LRAD
IF LRAN
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))[0
SET E=7
DO NAME
IF E
WRITE !?5,"F- BAD pointer to the accession file."
+4 QUIT
SPEC IF $DATA(^LAB(61,+X,0))[0
SET E=8
DO NAME
IF E
WRITE !?5,"F- BAD pointer to the specimen file (61)."
+1 QUIT
