- LRCKF68 ;SLC/RWF - CHECK FILE 68 ; 8/27/87 10:32 ;
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
- S ZTRTN="ENT^LRCKF68" D LOG^LRCKF Q:LREND W !,"QUICK REVIEW" S %=1 D YN^DICN Q:%<1 S:%=1 LRQUICK=1 D ENT W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
- ENT ;from LRCKF
- U IO W !," CHECKING FILE 68" S LRPACC=0,LRPWL=0,LRPWDT=0,U="^" F I=1:1:10 S E(8,I)=0
- F LRAA=0:0 S LRAA=$O(^LRO(68,LRAA)) Q:LRAA'>0 D LRAD
- K LRPACC,LRPWL,LRPWDT,LRQUICK W !! W:$E(IOST,1,2)="P-" @IOF Q
- LRAD I '$D(^LRO(68,LRAA,0))#2 W:$Y'<IOSL @IOF W !,"**** ACCESSION AREA # "_LRAA_" IS CORRUPTED ****",! Q
- S LR0=^LRO(68,LRAA,0) W:$Y'<IOSL @IOF W !,"ACCESSION AREA: ",$P(LR0,U) I '$L($P(LR0,U,2)) W !?5,"F- Missing the LR SUBSCRIPT entry."
- I '$P(LR0,U,8) W !?5,"W- Missing print order."
- I '$L($P(LR0,U,11)) W !?5,"F- Has no ABBREVIATION."
- I LRCKW,'$L($P(LR0,U,3)) W !?5,"W- missing the Clean up field."
- I $P(LR0,U,4),$D(^LRO(68,+$P(LR0,U,4),0))[0 W !?5,"F- BAD common accession # pointer to the accession file."
- I $P(LR0,U,5),$D(^LAB(62.07,+$P(LR0,U,5),0))[0 W !?5,"F- BAD accession transform pointer to the execute code file."
- I $S($D(^LAB(62.07,+$P(LR0,U,5),.1)):^(.1),1:"")'=$S($D(^LRO(68,LRAA,.1)):^(.1),1:1) W !?5,"F- Accession transform field and execute code file don't match."
- I $P(LR0,U,6),$D(^LAB(62.07,+$P(LR0,U,6),0))[0 W !?5,"F- BAD verification code pointer to the execute code file."
- I $P(LR0,U,6),$S($D(^LAB(62.07,+$P(LR0,U,6),.1)):^(.1),1:"")'=$S($D(^LRO(68,LRAA,.2)):^(.2),1:1) W !?5,"F- Verification code and execute code file don't match."
- F LRIN=0:0 S LRIN=$O(^LRO(68,LRAA,.5,LRIN)) Q:LRIN<1 I $D(^(LRIN,0))#2 S X=^(0) D INST
- I '$D(LRQUICK) F LRAD=0:0 S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1 D LRAN
- Q
- LRAN F LRAN=0:0 S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:LRAN'>0 D CHK68
- Q
- NAME S E(8,E)=1+E(8,E) I E(8,E)>20 S E=0 Q
- I LRPWDT'=LRAD!(LRAA'=LRPWL) S Y=LRAD D DD^LRX W:$Y'<IOSL @IOF W !!,"ACCESSION AREA: ",$P(^LRO(68,LRAA,0),U)," for date: ",Y S LRPWL=LRAA,LRPWDT=LRAD
- I LRPACC'=LRACC W !,"ACCESSION: ",LRACC S LRPACC=LRACC
- Q
- CHK68 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))[0 Q ;MUST BE A PLACE HOLDER
- S LA=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRDFN=+LA,LRORDER=$S($D(^(.1)):^(.1),1:""),LRACC=$S($D(^(.2)):^(.2),1:""),LRCTRL=$S($D(^LR(LRDFN,0))#2:$P(^(0),U,2),1:0),LRCTRL=(LRCTRL>60&(LRCTRL<70))
- I $D(^LR(LRDFN,0))[0 S E=1 D NAME I E W !?5,"F- Entry ",LRDFN," in ^LR( is missing."
- I LRACC="" S E=2,LRACC="ENTRY: "_LRAN D NAME I E W !?5,"F- Does not have an ACCESSION."
- Q:LRCTRL
- I LRCKW,LRORDER="" S E=3 D NAME I E W !?5,"W- Does not have an LRORDER number."
- I LRCKW,$D(^LRO(69,+$P(LA,U,4),1,+$P(LA,U,5),0))[0 S E=4 D NAME I E W !?5,"W- Does not have an Order on file."
- F T=0:0 S T=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T)) Q:T'>0 I $D(^(T,0))#2 S X=^(0) D TEST
- F T=0:0 S T=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,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 Y=$P(X,U,3) Q:'+Y S LRLL=+Y,LRTRAY=$P(Y,";",2),LRCUP=$P(Y,";",3),L=$S($D(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0)):^(0),1:"")
- I L="" S E=9 D NAME I E W !?5,"W- Accession points to a load/work list entry that is missing" Q
- I $P(L,U,1,3)'=(LRAA_U_LRAD_U_LRAN) S E=10 D NAME I E W !?5,"W- Load/work list (",LRLL,";",LRTRAY,";",LRCUP,") doesn't point back to here. (",$P(L,U,1,3),")" Q
- Q
- SPEC I $D(^LAB(61,+X,0))[0 S E=7 D NAME I E W !?5,"F- BAD pointer to the specimen file (61)."
- I $D(^LAB(62,+$P(X,U,2),0))[0 S E=8 D NAME I E W !?5,"F- BAD pointer to collection file (62)."
- Q
- INST I $D(^LAB(62.4,+X,0))[0 W !?5,"F- BAD instrument pointer to the auto instrument file."
- F LRCT=0:0 S LRCT=$O(^LRO(68,LRAA,.5,LRIN,1,LRCT)) Q:LRCT<1 I $D(^(LRCT,0))#2 S X=^(0) I $D(^LAB(62.3,+X,0))[0 W !?5,"F- BAD control name pointer to the control name file."
- Q
- LRCKF68 ;SLC/RWF - CHECK FILE 68 ; 8/27/87 10:32 ;
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
- +3 SET ZTRTN="ENT^LRCKF68"
- DO LOG^LRCKF
- IF LREND
- QUIT
- WRITE !,"QUICK REVIEW"
- SET %=1
- DO YN^DICN
- IF %<1
- QUIT
- IF %=1
- SET LRQUICK=1
- DO ENT
- WRITE !!
- IF $EXTRACT(IOST,1,2)="P-"
- WRITE @IOF
- DO ^%ZISC
- QUIT
- ENT ;from LRCKF
- +1 USE IO
- WRITE !," CHECKING FILE 68"
- SET LRPACC=0
- SET LRPWL=0
- SET LRPWDT=0
- SET U="^"
- FOR I=1:1:10
- SET E(8,I)=0
- +2 FOR LRAA=0:0
- SET LRAA=$ORDER(^LRO(68,LRAA))
- IF LRAA'>0
- QUIT
- DO LRAD
- +3 KILL LRPACC,LRPWL,LRPWDT,LRQUICK
- WRITE !!
- IF $EXTRACT(IOST,1,2)="P-"
- WRITE @IOF
- QUIT
- LRAD IF '$DATA(^LRO(68,LRAA,0))#2
- IF $Y'<IOSL
- WRITE @IOF
- WRITE !,"**** ACCESSION AREA # "_LRAA_" IS CORRUPTED ****",!
- QUIT
- +1 SET LR0=^LRO(68,LRAA,0)
- IF $Y'<IOSL
- WRITE @IOF
- WRITE !,"ACCESSION AREA: ",$PIECE(LR0,U)
- IF '$LENGTH($PIECE(LR0,U,2))
- WRITE !?5,"F- Missing the LR SUBSCRIPT entry."
- +2 IF '$PIECE(LR0,U,8)
- WRITE !?5,"W- Missing print order."
- +3 IF '$LENGTH($PIECE(LR0,U,11))
- WRITE !?5,"F- Has no ABBREVIATION."
- +4 IF LRCKW
- IF '$LENGTH($PIECE(LR0,U,3))
- WRITE !?5,"W- missing the Clean up field."
- +5 IF $PIECE(LR0,U,4)
- IF $DATA(^LRO(68,+$PIECE(LR0,U,4),0))[0
- WRITE !?5,"F- BAD common accession # pointer to the accession file."
- +6 IF $PIECE(LR0,U,5)
- IF $DATA(^LAB(62.07,+$PIECE(LR0,U,5),0))[0
- WRITE !?5,"F- BAD accession transform pointer to the execute code file."
- +7 IF $SELECT($DATA(^LAB(62.07,+$PIECE(LR0,U,5),.1)):^(.1),1:"")'=$SELECT($DATA(^LRO(68,LRAA,.1)):^(.1),1:1)
- WRITE !?5,"F- Accession transform field and execute code file don't match."
- +8 IF $PIECE(LR0,U,6)
- IF $DATA(^LAB(62.07,+$PIECE(LR0,U,6),0))[0
- WRITE !?5,"F- BAD verification code pointer to the execute code file."
- +9 IF $PIECE(LR0,U,6)
- IF $SELECT($DATA(^LAB(62.07,+$PIECE(LR0,U,6),.1)):^(.1),1:"")'=$SELECT($DATA(^LRO(68,LRAA,.2)):^(.2),1:1)
- WRITE !?5,"F- Verification code and execute code file don't match."
- +10 FOR LRIN=0:0
- SET LRIN=$ORDER(^LRO(68,LRAA,.5,LRIN))
- IF LRIN<1
- QUIT
- IF $DATA(^(LRIN,0))#2
- SET X=^(0)
- DO INST
- +11 IF '$DATA(LRQUICK)
- FOR LRAD=0:0
- SET LRAD=$ORDER(^LRO(68,LRAA,1,LRAD))
- IF LRAD<1
- QUIT
- DO LRAN
- +12 QUIT
- LRAN FOR LRAN=0:0
- SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
- IF LRAN'>0
- QUIT
- DO CHK68
- +1 QUIT
- NAME SET E(8,E)=1+E(8,E)
- IF E(8,E)>20
- SET E=0
- QUIT
- +1 IF LRPWDT'=LRAD!(LRAA'=LRPWL)
- SET Y=LRAD
- DO DD^LRX
- IF $Y'<IOSL
- WRITE @IOF
- WRITE !!,"ACCESSION AREA: ",$PIECE(^LRO(68,LRAA,0),U)," for date: ",Y
- SET LRPWL=LRAA
- SET LRPWDT=LRAD
- +2 IF LRPACC'=LRACC
- WRITE !,"ACCESSION: ",LRACC
- SET LRPACC=LRACC
- +3 QUIT
- CHK68 ;MUST BE A PLACE HOLDER
- IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))[0
- QUIT
- +1 SET LA=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
- SET LRDFN=+LA
- SET LRORDER=$SELECT($DATA(^(.1)):^(.1),1:"")
- SET LRACC=$SELECT($DATA(^(.2)):^(.2),1:"")
- SET LRCTRL=$SELECT($DATA(^LR(LRDFN,0))#2:$PIECE(^(0),U,2),1:0)
- SET LRCTRL=(LRCTRL>60&(LRCTRL<70))
- +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 LRACC=""
- SET E=2
- SET LRACC="ENTRY: "_LRAN
- DO NAME
- IF E
- WRITE !?5,"F- Does not have an ACCESSION."
- +4 IF LRCTRL
- QUIT
- +5 IF LRCKW
- IF LRORDER=""
- SET E=3
- DO NAME
- IF E
- WRITE !?5,"W- Does not have an LRORDER number."
- +6 IF LRCKW
- IF $DATA(^LRO(69,+$PIECE(LA,U,4),1,+$PIECE(LA,U,5),0))[0
- SET E=4
- DO NAME
- IF E
- WRITE !?5,"W- Does not have an Order on file."
- +7 FOR T=0:0
- SET T=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T))
- IF T'>0
- QUIT
- IF $DATA(^(T,0))#2
- SET X=^(0)
- DO TEST
- +8 FOR T=0:0
- SET T=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,5,T))
- IF T'>0
- QUIT
- IF $DATA(^(T,0))#2
- SET X=^(0)
- DO SPEC
- +9 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 Y=$PIECE(X,U,3)
- IF '+Y
- QUIT
- SET LRLL=+Y
- SET LRTRAY=$PIECE(Y,";",2)
- SET LRCUP=$PIECE(Y,";",3)
- SET L=$SELECT($DATA(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0)):^(0),1:"")
- +3 IF L=""
- SET E=9
- DO NAME
- IF E
- WRITE !?5,"W- Accession points to a load/work list entry that is missing"
- QUIT
- +4 IF $PIECE(L,U,1,3)'=(LRAA_U_LRAD_U_LRAN)
- SET E=10
- DO NAME
- IF E
- WRITE !?5,"W- Load/work list (",LRLL,";",LRTRAY,";",LRCUP,") doesn't point back to here. (",$PIECE(L,U,1,3),")"
- QUIT
- +5 QUIT
- SPEC IF $DATA(^LAB(61,+X,0))[0
- SET E=7
- DO NAME
- IF E
- WRITE !?5,"F- BAD pointer to the specimen file (61)."
- +1 IF $DATA(^LAB(62,+$PIECE(X,U,2),0))[0
- SET E=8
- DO NAME
- IF E
- WRITE !?5,"F- BAD pointer to collection file (62)."
- +2 QUIT
- INST IF $DATA(^LAB(62.4,+X,0))[0
- WRITE !?5,"F- BAD instrument pointer to the auto instrument file."
- +1 FOR LRCT=0:0
- SET LRCT=$ORDER(^LRO(68,LRAA,.5,LRIN,1,LRCT))
- IF LRCT<1
- QUIT
- IF $DATA(^(LRCT,0))#2
- SET X=^(0)
- IF $DATA(^LAB(62.3,+X,0))[0
- WRITE !?5,"F- BAD control name pointer to the control name file."
- +2 QUIT
