- 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 Jan 18, 2025@03:14:28 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