LRCKF60 ;SLC/RWF - CHECK FILE 60 ;4/4/89 20:36 ;
;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
S ZTRTN="ENT^LRCKF60" D LOG^LRCKF Q:LREND D ENT W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
ENT ;from LRCKF
U IO S U="^" W !," CHECKING LAB TEST FILE ^LAB(60 ",!," DD VERSION is ",$S($D(^DD(60,0,"VR"))#2:^("VR"),1:"Missing"),! S LRDA=0
F DA=0:0 S DA=$O(^LAB(60,DA)) Q:DA'>0 D CHK
END K LRLCS,LROKCS,LRDA,LA0,LRATOMIC,LRYES W !! W:$E(IOST,1,2)="P-" @IOF Q
Q
NAME I LRDA'=DA W !!,$P(^LAB(60,DA,0),U) S LRDA=DA
W !,?5 Q
CHK I '$D(^LAB(60,DA,0))#2 W !!,"ENTRY ",DA," HAS NO ZERO NODE.. REMOVED" K ^LAB(60,DA) Q
I $D(LRYES) Q:'$L($P(^LAB(60,DA,0),U,3)) Q:$P(^LAB(60,DA,0),U,3)="N"
S LA0=^LAB(60,DA,0),LRATOMIC=$L($P(LA0,U,5))
I LRATOMIC&($O(^LAB(60,DA,2,0))>0) D NAME W "F- A test can NOT be Atomic and Cosmic at the same time."
I LRCKW,LRATOMIC&($O(^LAB(60,DA,1,0))<1) D NAME W "W- Atomic test has no site/specimen, therefore no units or range."
I $P(LA0,U,16)<1 D NAME W "F- Test MUST have a HIGHEST URGENCY ALLOWED value."
I $P(LA0,U,5)?1"CH;".NP,$S($D(^LAB(60,DA,.2)):'+^(.2),1:1) D NAME W "F- Atomic test has a location but not a DATA NAME."
I $D(^LAB(60,DA,.2)),^(.2) S X=^(.2) I $P(LA0,U,5)'[X!($P(LA0,U,12)'[X) D NAME W "F- The data name field must be re-entered to set up location & field."
I $D(^LAB(60,DA,.2)),^(.2),$D(^DD(63.04,+^LAB(60,DA,.2),0))[0 D NAME W "F- BAD Data name."
S P1=$S($D(^LAB(60,DA,.1)):^(.1),1:"")
I '$L($P(P1,U)) D NAME W "F- Needs a print name entered."
I $L($P(P1,U,3)) S X="W "_$P(P1,U,3) D ^DIM I '$D(X) D NAME W "F- BAD print code."
I LRCKW,LRATOMIC,$S($D(^LAB(60,DA,.1)):'$P(^(.1),U,6),1:1) D NAME W "W- Does not have a print order."
I $D(^LAB(60,DA,9,0)) D CAP
F LRIX=0:0 S LRIX=$O(^LAB(60,DA,2,LRIX)) Q:LRIX<.01 I $D(^(LRIX,0))#2 S X=+^(0) D PANEL
C2 ;I $P(LA0,U,6),$D(^LRO(68,+$P(LA0,U,6),0))[0 D NAME W "F- BAD pointer to the Accession file."
I $P(LA0,U,9),$D(^LAB(62,+$P(LA0,U,9),0))[0 D NAME W "F- BAD Lab collection sample pointer to the Collection sample file."
I $P(LA0,U,10),$D(^LAB(61.5,+$P(LA0,U,10),0))[0 D NAME W "F- BAD pointer to the Procedure file."
I $P(LA0,U,14),$D(^LAB(62.07,+$P(LA0,U,14),0))[0 D NAME W "F- BAD Edit code pointer to the Execute code file."
I $D(^LAB(60,DA,4)),+^(4),$D(^LAB(62.07,+^LAB(60,DA,4),0))[0 D NAME W "F- BAD 'Batch data code' pointer to the execute code file."
F LRSSP=0:0 S LRSSP=$O(^LAB(60,DA,1,LRSSP)) Q:LRSSP<1 I $D(^(LRSSP,0))#2 S X=^(0) D SPEC
S X=$P(^LAB(60,DA,0),U,9),LRLCS=X D LROKCS:X S LRLCS=0
F LRCS=0:0 S LRCS=$O(^LAB(60,DA,3,LRCS)) Q:LRCS<1 I $D(^(LRCS,0))#2 S X=^(0) D COLSAMP
Q
PANEL I $D(^LAB(60,X,0))[0 D NAME W "F- BAD pointer in panel.. "
I X=DA D NAME W "F- Test is on it's own panel. (infinite loop)"
Q
SPEC I LRSSP='+X D NAME W "F- BAD entry in specimen/site subfile. ",LRSSP
I $D(^LAB(61,+X,0))[0 D NAME W "F- BAD specimen/site subfile pointer to file #61."
I $P(X,U,8),$D(^LAB(62.1,+$P(X,U,8),0))[0 D NAME W "F- BAD type of delta check pointer."
Q
COLSAMP I $D(^LAB(62,+X,0))[0 D NAME W "F- BAD collection sample pointer to file #62."
I $P(X,U,6),$D(^LAB(62.07,+$P(X,U,6),0))[0 D NAME W "F- BAD required comment pointer to execute code file."
D LROKCS Q
LROKCS Q:$D(^LAB(62,+X,0))[0 S Y=$P(^(0),U,2) Q:Y<1
S LROKCS=1 I $D(^LAB(60,DA,1,+Y,0))#2 S LROKCS=0
I LRCKW,LRATOMIC,LROKCS D NAME W "W- ",$S(LRLCS:"LAB ",1:""),"Collection sample ",$P(^LAB(62,+X,0),U)," does not have a matching Site/Specimen entry."
Q
CAP Q ;S (CAP,LRCAP)=0 F A=1:1 S LRCAP=$O(^LAB(60,DA,9,LRCAP)) Q:+LRCAP<1 I $D(^(LRCAP,0)),$P(^(0),U,2) S CAP=LRCAP
I A>1,'+CAP D NAME W:'+CAP "W - No WKLD code for this test"
K LRCAP,A,CAP Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCKF60 3702 printed Sep 23, 2025@19:49:20 Page 2
LRCKF60 ;SLC/RWF - CHECK FILE 60 ;4/4/89 20:36 ;
+1 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
+2 SET ZTRTN="ENT^LRCKF60"
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
SET U="^"
WRITE !," CHECKING LAB TEST FILE ^LAB(60 ",!," DD VERSION is ",$SELECT($DATA(^DD(60,0,"VR"))#2:^("VR"),1:"Missing"),!
SET LRDA=0
+2 FOR DA=0:0
SET DA=$ORDER(^LAB(60,DA))
if DA'>0
QUIT
DO CHK
END KILL LRLCS,LROKCS,LRDA,LA0,LRATOMIC,LRYES
WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
QUIT
+1 QUIT
NAME IF LRDA'=DA
WRITE !!,$PIECE(^LAB(60,DA,0),U)
SET LRDA=DA
+1 WRITE !,?5
QUIT
CHK IF '$DATA(^LAB(60,DA,0))#2
WRITE !!,"ENTRY ",DA," HAS NO ZERO NODE.. REMOVED"
KILL ^LAB(60,DA)
QUIT
+1 IF $DATA(LRYES)
if '$LENGTH($PIECE(^LAB(60,DA,0),U,3))
QUIT
if $PIECE(^LAB(60,DA,0),U,3)="N"
QUIT
+2 SET LA0=^LAB(60,DA,0)
SET LRATOMIC=$LENGTH($PIECE(LA0,U,5))
+3 IF LRATOMIC&($ORDER(^LAB(60,DA,2,0))>0)
DO NAME
WRITE "F- A test can NOT be Atomic and Cosmic at the same time."
+4 IF LRCKW
IF LRATOMIC&($ORDER(^LAB(60,DA,1,0))<1)
DO NAME
WRITE "W- Atomic test has no site/specimen, therefore no units or range."
+5 IF $PIECE(LA0,U,16)<1
DO NAME
WRITE "F- Test MUST have a HIGHEST URGENCY ALLOWED value."
+6 IF $PIECE(LA0,U,5)?1"CH;".NP
IF $SELECT($DATA(^LAB(60,DA,.2)):'+^(.2),1:1)
DO NAME
WRITE "F- Atomic test has a location but not a DATA NAME."
+7 IF $DATA(^LAB(60,DA,.2))
IF ^(.2)
SET X=^(.2)
IF $PIECE(LA0,U,5)'[X!($PIECE(LA0,U,12)'[X)
DO NAME
WRITE "F- The data name field must be re-entered to set up location & field."
+8 IF $DATA(^LAB(60,DA,.2))
IF ^(.2)
IF $DATA(^DD(63.04,+^LAB(60,DA,.2),0))[0
DO NAME
WRITE "F- BAD Data name."
+9 SET P1=$SELECT($DATA(^LAB(60,DA,.1)):^(.1),1:"")
+10 IF '$LENGTH($PIECE(P1,U))
DO NAME
WRITE "F- Needs a print name entered."
+11 IF $LENGTH($PIECE(P1,U,3))
SET X="W "_$PIECE(P1,U,3)
DO ^DIM
IF '$DATA(X)
DO NAME
WRITE "F- BAD print code."
+12 IF LRCKW
IF LRATOMIC
IF $SELECT($DATA(^LAB(60,DA,.1)):'$PIECE(^(.1),U,6),1:1)
DO NAME
WRITE "W- Does not have a print order."
+13 IF $DATA(^LAB(60,DA,9,0))
DO CAP
+14 FOR LRIX=0:0
SET LRIX=$ORDER(^LAB(60,DA,2,LRIX))
if LRIX<.01
QUIT
IF $DATA(^(LRIX,0))#2
SET X=+^(0)
DO PANEL
C2 ;I $P(LA0,U,6),$D(^LRO(68,+$P(LA0,U,6),0))[0 D NAME W "F- BAD pointer to the Accession file."
+1 IF $PIECE(LA0,U,9)
IF $DATA(^LAB(62,+$PIECE(LA0,U,9),0))[0
DO NAME
WRITE "F- BAD Lab collection sample pointer to the Collection sample file."
+2 IF $PIECE(LA0,U,10)
IF $DATA(^LAB(61.5,+$PIECE(LA0,U,10),0))[0
DO NAME
WRITE "F- BAD pointer to the Procedure file."
+3 IF $PIECE(LA0,U,14)
IF $DATA(^LAB(62.07,+$PIECE(LA0,U,14),0))[0
DO NAME
WRITE "F- BAD Edit code pointer to the Execute code file."
+4 IF $DATA(^LAB(60,DA,4))
IF +^(4)
IF $DATA(^LAB(62.07,+^LAB(60,DA,4),0))[0
DO NAME
WRITE "F- BAD 'Batch data code' pointer to the execute code file."
+5 FOR LRSSP=0:0
SET LRSSP=$ORDER(^LAB(60,DA,1,LRSSP))
if LRSSP<1
QUIT
IF $DATA(^(LRSSP,0))#2
SET X=^(0)
DO SPEC
+6 SET X=$PIECE(^LAB(60,DA,0),U,9)
SET LRLCS=X
if X
DO LROKCS
SET LRLCS=0
+7 FOR LRCS=0:0
SET LRCS=$ORDER(^LAB(60,DA,3,LRCS))
if LRCS<1
QUIT
IF $DATA(^(LRCS,0))#2
SET X=^(0)
DO COLSAMP
+8 QUIT
PANEL IF $DATA(^LAB(60,X,0))[0
DO NAME
WRITE "F- BAD pointer in panel.. "
+1 IF X=DA
DO NAME
WRITE "F- Test is on it's own panel. (infinite loop)"
+2 QUIT
SPEC IF LRSSP='+X
DO NAME
WRITE "F- BAD entry in specimen/site subfile. ",LRSSP
+1 IF $DATA(^LAB(61,+X,0))[0
DO NAME
WRITE "F- BAD specimen/site subfile pointer to file #61."
+2 IF $PIECE(X,U,8)
IF $DATA(^LAB(62.1,+$PIECE(X,U,8),0))[0
DO NAME
WRITE "F- BAD type of delta check pointer."
+3 QUIT
COLSAMP IF $DATA(^LAB(62,+X,0))[0
DO NAME
WRITE "F- BAD collection sample pointer to file #62."
+1 IF $PIECE(X,U,6)
IF $DATA(^LAB(62.07,+$PIECE(X,U,6),0))[0
DO NAME
WRITE "F- BAD required comment pointer to execute code file."
+2 DO LROKCS
QUIT
LROKCS if $DATA(^LAB(62,+X,0))[0
QUIT
SET Y=$PIECE(^(0),U,2)
if Y<1
QUIT
+1 SET LROKCS=1
IF $DATA(^LAB(60,DA,1,+Y,0))#2
SET LROKCS=0
+2 IF LRCKW
IF LRATOMIC
IF LROKCS
DO NAME
WRITE "W- ",$SELECT(LRLCS:"LAB ",1:""),"Collection sample ",$PIECE(^LAB(62,+X,0),U)," does not have a matching Site/Specimen entry."
+3 QUIT
CAP ;S (CAP,LRCAP)=0 F A=1:1 S LRCAP=$O(^LAB(60,DA,9,LRCAP)) Q:+LRCAP<1 I $D(^(LRCAP,0)),$P(^(0),U,2) S CAP=LRCAP
QUIT
+1 IF A>1
IF '+CAP
DO NAME
if '+CAP
WRITE "W - No WKLD code for this test"
+2 KILL LRCAP,A,CAP
QUIT
