- LRCKF60 ;SLC/RWF - CHECK FILE 60 ;4/4/89 20:36 ;
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;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
- LRCKF60 ;SLC/RWF - CHECK FILE 60 ;4/4/89 20:36 ;
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
- +3 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
