LRCKF68 ;SLC/RWF - CHECK FILE 68 ; 8/27/87 10:32 ;
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCKF68 3930 printed Dec 13, 2024@02:13:43 Page 2
LRCKF68 ;SLC/RWF - CHECK FILE 68 ; 8/27/87 10:32 ;
+1 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
+2 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
