LRCKF64 ;DALOI/KML/RLM-CHECK WKLD CODE FILE FOR DISCREPANCIES ;2/22/87
;;5.2;LAB SERVICE;**272**;Sep 27, 1994
; Reference to ^%ZISC supported by IA #10089
; Reference to CHK^DIE supported by IA #2053
; Reference to ^DD(63.04 supported by IA #999
;
S ZTRTN="DQ^LRCKF64",LRCKF="LRCKF64",LRJOB=$J,(LREND,LRWARN)=0
D LOG^LRCKF Q:LREND
DQ U IO S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP(LRCKF)
D ENT,PRT^LRCKF(LRCKF,LRJOB)
W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
Q
ENT ;from LRCKF
U IO S LRFL=$P(^LAM(0),U),LRDA=0
S LRTMPGL="^TMP(LRCKF,LRJOB,LRFL)",@LRTMPGL=LRFL_" file (#64)"
W !!,"Validating "_LRFL_" File (#64)"
S DA=0 F S DA=$O(^LAM(DA)) Q:DA<1 D VAL64
Q
VAL64 ; validate data elements in the WKLD CODE file
I $D(^LAM(DA,0))[0 S @LRTMPGL@(DA)=">>FATAL<< - Missing zero node for entry: "_DA Q
S LA=^LAM(DA,0)
S Z="" D CHK^DIE(64,.01,"E",$P(LA,U),.Z) I Z=U D LABEL S @LRTMPGL@(DA,"64,.01")=">>FATAL<< - The value '"_$P(LA,U)_"' for field PROCEDURE is not valid."
I '$L($P(LA,U,2)) D LABEL S @LRTMPGL@(DA,"64,1")=">>FATAL<< - WKLD CODE field (#1) does not contain a value."
I $L($P(LA,U,2)) D
. S X=$P(LA,U,2) I $A(X)=45!($L(X)>12)!($L(X)<10)!(X'?5N1"."4.5N) D LABEL S @LRTMPGL(DA,"64.1")=">>FATAL<< - WKLD CODE is not valid (field #1)." Q
. S X=$O(^LAM("E",$P(LA,U,2),DA)) I X]"" D LABEL S @LRTMPGL@(DA,"64,1")=">>CRITICAL<< - Multiple WKLD CODE cross-references ('E' x-ref) exist for '"_$P(LA,U,2)_"' (field #1)."
I $D(^LAB(64.22,+$P(LA,U,7),0))[0 D LABEL S @LRTMPGL@(DA,"64,6")=">>FATAL<< - Invalid UNIT FOR COUNT pointer to WKLD ITEM FOR COUNT file (#64.22)."
I $L($P(LA,U,14)),$D(^LAB(64.3,$P(LA,U,14),0))[0 D LABEL S @LRTMPGL@(DA,"64,12")=">>FATAL<< - Invalid MANUFACTURER pointer to WKLD INSTRUMENT MANUFACTURER file (#64.3)."
I $D(^LAB(64.21,+$P(LA,U,15),0))[0 D LABEL S @LRTMPGL@(DA,"64,13")=">>FATAL<< - Invalid WKLD CODE LAB SECTION pointer to WKLD CODE LAB SECT file (#64.21)."
S LA6=$G(^LAM(DA,6)) I $L($P(LA6,U)),$D(^LRO(68,$P(LA6,U),0))[0 D LABEL S @LRTMPGL@(DA,6,"64,21")=">>FATAL<< - Invalid LOCAL ACC AREA pointer to ACCESSION file (#68)."
; S CODE=0 F S CODE=$O(^LAM(DA,4,CODE)) Q:CODE<1 I $D(^(CODE,0))#2 S LA4=^(0) D CODEV ; this code will become active at a later date
S SPEC=0 F S SPEC=$O(^LAM(DA,5,SPEC)) Q:SPEC<1 I $D(^(SPEC,0))#2 S LA5=^(0) D SPECV
S NAME=0 F S NAME=$O(^LAM(DA,7,NAME)) Q:NAME<1 I $D(^(NAME,0))#2 S LA7=$P(^(0),U) D ASSOCV
Q
CODEV ; validation of CODE subfile data elements (multiple 64.018)
; code to be developed as soon as specifications are determined
; TYPE field (#64.018,5) of file 64 will, at some point in time, have
; its DATA TYPE changed from SET OF CODES to a POINTER (according to
; F. Stalling). Once this occurs, then validation of the data element
; in the data file will need to be incorporated into program code.
Q
SPECV ; validation of SPECIMEN subfile data elements (multiple 64.01)
I $L($P(LA5,U)),$D(^LAB(61,$P(LA5,U),0))[0 D LABEL S @LRTMPGL@(DA,5,SPEC,"64.01,.01")=">>FATAL<< - Invalid SPECIMEN pointer to TOPOGRAPHY FIELD file (#61) found at SPECIMEN subfile. Entry: "_SPEC
S TIME=0 F S TIME=$O(^LAM(DA,5,SPEC,1,TIME)) Q:TIME<1 I $D(^(TIME,0))#2 S LA5T=^(0) D TIMEV
Q
TIMEV ; validation of data elements within the TIME ASPECT multiple of the SPECIMEN subfile
I $L($P(LA5T,U)),$D(^LAB(64.061,$P(LA5T,U),0))[0 D LABEL D
. S @LRTMPGL@(DA,5,SPEC,TIME,"64.02,.01")=">>FATAL<< - Invalid TIME ASPECT pointer to LAB ELECTRONIC CODES file (#64.061) found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
I $L($P(LA5T,U,2)),$D(^LAB(64.061,$P(LA5T,U,2),0))[0 D LABEL D
. S @LRTMPGL@(DA,5,SPEC,TIME,"64.02,1")=">>FATAL<< - Invalid UNITS pointer to LAB ELECTRONICS CODES file (#64.061) found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
I $L($P(LA5T,U,3)),$D(^DD(63.04,$P(LA5T,U,3),0))[0 D LABEL S @LRTMPGL@(DA,5,SPEC,TIME,"64.02,2")=">>FATAL<< - Invalid DATA LOCATION found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
I $L($P(LA5T,U,4)),$D(^LAB(60,$P(LA5T,U,4),0))[0 D LABEL D
. S @LRTMPGL@(DA,5,SPEC,TIME,"64.02,3")=">>FATAL<< - Invalid TEST pointer to LABORATORY TEST file (#60) found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
Q
ASSOCV ; validation of data elements at the ASSOCIATED NAME subfile
S X=U_$P(LA7,";",2)_$P(LA7,";")_",0)"
I $D(@X)[0 D LABEL S @LRTMPGL@(DA,7,NAME,"64.023,.01")=">>FATAL<< - Invalid VARIABLE POINTER field found at ASSOCIATED NAME subfile for entry "_NAME
I LRWARN,$D(^LAM("AE",$P(LA7,";",2),$P(LA7,";"),DA))[0 D LABEL S @LRTMPGL@(DA,7,NAME,"64.023,.01",1)=">>WARNING<< - ASSOCIATED NAME cross-reference does not exist for entry "_NAME
Q
LABEL ;
I LRDA'=DA S @LRTMPGL@(DA)=$P(LA,U) S LRDA=DA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCKF64 4850 printed Sep 23, 2025@19:49:22 Page 2
LRCKF64 ;DALOI/KML/RLM-CHECK WKLD CODE FILE FOR DISCREPANCIES ;2/22/87
+1 ;;5.2;LAB SERVICE;**272**;Sep 27, 1994
+2 ; Reference to ^%ZISC supported by IA #10089
+3 ; Reference to CHK^DIE supported by IA #2053
+4 ; Reference to ^DD(63.04 supported by IA #999
+5 ;
+6 SET ZTRTN="DQ^LRCKF64"
SET LRCKF="LRCKF64"
SET LRJOB=$JOB
SET (LREND,LRWARN)=0
+7 DO LOG^LRCKF
if LREND
QUIT
DQ USE IO
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 KILL ^TMP(LRCKF)
+2 DO ENT
DO PRT^LRCKF(LRCKF,LRJOB)
+3 WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
+4 QUIT
ENT ;from LRCKF
+1 USE IO
SET LRFL=$PIECE(^LAM(0),U)
SET LRDA=0
+2 SET LRTMPGL="^TMP(LRCKF,LRJOB,LRFL)"
SET @LRTMPGL=LRFL_" file (#64)"
+3 WRITE !!,"Validating "_LRFL_" File (#64)"
+4 SET DA=0
FOR
SET DA=$ORDER(^LAM(DA))
if DA<1
QUIT
DO VAL64
+5 QUIT
VAL64 ; validate data elements in the WKLD CODE file
+1 IF $DATA(^LAM(DA,0))[0
SET @LRTMPGL@(DA)=">>FATAL<< - Missing zero node for entry: "_DA
QUIT
+2 SET LA=^LAM(DA,0)
+3 SET Z=""
DO CHK^DIE(64,.01,"E",$PIECE(LA,U),.Z)
IF Z=U
DO LABEL
SET @LRTMPGL@(DA,"64,.01")=">>FATAL<< - The value '"_$PIECE(LA,U)_"' for field PROCEDURE is not valid."
+4 IF '$LENGTH($PIECE(LA,U,2))
DO LABEL
SET @LRTMPGL@(DA,"64,1")=">>FATAL<< - WKLD CODE field (#1) does not contain a value."
+5 IF $LENGTH($PIECE(LA,U,2))
Begin DoDot:1
+6 SET X=$PIECE(LA,U,2)
IF $ASCII(X)=45!($LENGTH(X)>12)!($LENGTH(X)<10)!(X'?5N1"."4.5N)
DO LABEL
SET @LRTMPGL(DA,"64.1")=">>FATAL<< - WKLD CODE is not valid (field #1)."
QUIT
+7 SET X=$ORDER(^LAM("E",$PIECE(LA,U,2),DA))
IF X]""
DO LABEL
SET @LRTMPGL@(DA,"64,1")=">>CRITICAL<< - Multiple WKLD CODE cross-references ('E' x-ref) exist for '"_$PIECE(LA,U,2)_"' (field #1)."
End DoDot:1
+8 IF $DATA(^LAB(64.22,+$PIECE(LA,U,7),0))[0
DO LABEL
SET @LRTMPGL@(DA,"64,6")=">>FATAL<< - Invalid UNIT FOR COUNT pointer to WKLD ITEM FOR COUNT file (#64.22)."
+9 IF $LENGTH($PIECE(LA,U,14))
IF $DATA(^LAB(64.3,$PIECE(LA,U,14),0))[0
DO LABEL
SET @LRTMPGL@(DA,"64,12")=">>FATAL<< - Invalid MANUFACTURER pointer to WKLD INSTRUMENT MANUFACTURER file (#64.3)."
+10 IF $DATA(^LAB(64.21,+$PIECE(LA,U,15),0))[0
DO LABEL
SET @LRTMPGL@(DA,"64,13")=">>FATAL<< - Invalid WKLD CODE LAB SECTION pointer to WKLD CODE LAB SECT file (#64.21)."
+11 SET LA6=$GET(^LAM(DA,6))
IF $LENGTH($PIECE(LA6,U))
IF $DATA(^LRO(68,$PIECE(LA6,U),0))[0
DO LABEL
SET @LRTMPGL@(DA,6,"64,21")=">>FATAL<< - Invalid LOCAL ACC AREA pointer to ACCESSION file (#68)."
+12 ; S CODE=0 F S CODE=$O(^LAM(DA,4,CODE)) Q:CODE<1 I $D(^(CODE,0))#2 S LA4=^(0) D CODEV ; this code will become active at a later date
+13 SET SPEC=0
FOR
SET SPEC=$ORDER(^LAM(DA,5,SPEC))
if SPEC<1
QUIT
IF $DATA(^(SPEC,0))#2
SET LA5=^(0)
DO SPECV
+14 SET NAME=0
FOR
SET NAME=$ORDER(^LAM(DA,7,NAME))
if NAME<1
QUIT
IF $DATA(^(NAME,0))#2
SET LA7=$PIECE(^(0),U)
DO ASSOCV
+15 QUIT
CODEV ; validation of CODE subfile data elements (multiple 64.018)
+1 ; code to be developed as soon as specifications are determined
+2 ; TYPE field (#64.018,5) of file 64 will, at some point in time, have
+3 ; its DATA TYPE changed from SET OF CODES to a POINTER (according to
+4 ; F. Stalling). Once this occurs, then validation of the data element
+5 ; in the data file will need to be incorporated into program code.
+6 QUIT
SPECV ; validation of SPECIMEN subfile data elements (multiple 64.01)
+1 IF $LENGTH($PIECE(LA5,U))
IF $DATA(^LAB(61,$PIECE(LA5,U),0))[0
DO LABEL
SET @LRTMPGL@(DA,5,SPEC,"64.01,.01")=">>FATAL<< - Invalid SPECIMEN pointer to TOPOGRAPHY FIELD file (#61) found at SPECIMEN subfile. Entry: "_SPEC
+2 SET TIME=0
FOR
SET TIME=$ORDER(^LAM(DA,5,SPEC,1,TIME))
if TIME<1
QUIT
IF $DATA(^(TIME,0))#2
SET LA5T=^(0)
DO TIMEV
+3 QUIT
TIMEV ; validation of data elements within the TIME ASPECT multiple of the SPECIMEN subfile
+1 IF $LENGTH($PIECE(LA5T,U))
IF $DATA(^LAB(64.061,$PIECE(LA5T,U),0))[0
DO LABEL
Begin DoDot:1
+2 SET @LRTMPGL@(DA,5,SPEC,TIME,"64.02,.01")=">>FATAL<< - Invalid TIME ASPECT pointer to LAB ELECTRONIC CODES file (#64.061) found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
End DoDot:1
+3 IF $LENGTH($PIECE(LA5T,U,2))
IF $DATA(^LAB(64.061,$PIECE(LA5T,U,2),0))[0
DO LABEL
Begin DoDot:1
+4 SET @LRTMPGL@(DA,5,SPEC,TIME,"64.02,1")=">>FATAL<< - Invalid UNITS pointer to LAB ELECTRONICS CODES file (#64.061) found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
End DoDot:1
+5 IF $LENGTH($PIECE(LA5T,U,3))
IF $DATA(^DD(63.04,$PIECE(LA5T,U,3),0))[0
DO LABEL
SET @LRTMPGL@(DA,5,SPEC,TIME,"64.02,2")=">>FATAL<< - Invalid DATA LOCATION found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
+6 IF $LENGTH($PIECE(LA5T,U,4))
IF $DATA(^LAB(60,$PIECE(LA5T,U,4),0))[0
DO LABEL
Begin DoDot:1
+7 SET @LRTMPGL@(DA,5,SPEC,TIME,"64.02,3")=">>FATAL<< - Invalid TEST pointer to LABORATORY TEST file (#60) found at TIME ASPECT multiple of the SPECIMEN subfile. Entry: "_SPEC_" Subentry: "_TIME
End DoDot:1
+8 QUIT
ASSOCV ; validation of data elements at the ASSOCIATED NAME subfile
+1 SET X=U_$PIECE(LA7,";",2)_$PIECE(LA7,";")_",0)"
+2 IF $DATA(@X)[0
DO LABEL
SET @LRTMPGL@(DA,7,NAME,"64.023,.01")=">>FATAL<< - Invalid VARIABLE POINTER field found at ASSOCIATED NAME subfile for entry "_NAME
+3 IF LRWARN
IF $DATA(^LAM("AE",$PIECE(LA7,";",2),$PIECE(LA7,";"),DA))[0
DO LABEL
SET @LRTMPGL@(DA,7,NAME,"64.023,.01",1)=">>WARNING<< - ASSOCIATED NAME cross-reference does not exist for entry "_NAME
+4 QUIT
LABEL ;
+1 IF LRDA'=DA
SET @LRTMPGL@(DA)=$PIECE(LA,U)
SET LRDA=DA
+2 QUIT
