XDRDVAL ;CIOFO-SF.SEA/JLI - Check validity of data elements ;10/02/2000 08:00
;;7.3;TOOLKIT;**23,32,51**;Apr 25, 1995
;;
Q
;
DOENTRY(FILE,IEN,OUTROOT,HELP) ; ENTRY POINT TO PROCESS A SINGLE ENTRY
;N DATAROOT,MESGROOT,TEMPROOT,IENS,FIELD,X
N ZTQUEUED ;S ZTQUEUED=1
S DATAROOT=$NA(^TMP($J,"XDRDVAL","DATA"))
S MESGROOT=$NA(^TMP($J,"XDRDVAL","MESG"))
S TEMPROOT=$NA(^TMP($J,"XDRDVAL","TEMP"))
K @DATAROOT,@MESGROOT,@TEMPROOT
D DOGETS
I $D(@TEMPROOT) D VALIDATE(TEMPROOT,$NA(@MESGROOT@(IEN,"VAL")))
M @OUTROOT@(IEN)=@MESGROOT@(IEN)
Q
DOGETS ;
D GETS^DIQ(FILE,IEN,"**","EIN",DATAROOT,MESGROOT)
;I $D(@MESGROOT@("DIERR"))>1 M @OUTROOT@(FILE,IEN,"GET","DIERR")=@MESGROOT@("DIERR")
K @MESGROOT
F FILE=0:0 S FILE=$O(@DATAROOT@(FILE)) Q:FILE'>0 D
. S IENS="" F S IENS=$O(@DATAROOT@(FILE,IENS)) Q:IENS="" D
. . F FIELD=0:0 S FIELD=$O(@DATAROOT@(FILE,IENS,FIELD)) Q:FIELD'>0 D
. . . I FILE=70.03,FIELD=.01 Q ; RADIOLOGY LOGIC REQUIRES USER INPUT
. . . I $O(@DATAROOT@(FILE,IENS,FIELD,""))>0 K @DATAROOT@(FILE,IENS,FIELD) Q ; WORD PROCESSING FIELDS - SKIP
. . . S Y=$G(@DATAROOT@(FILE,IENS,FIELD,"I")) I Y="" Q ; SKIP COMPUTED FIELDS
. . . S X=$G(@DATAROOT@(FILE,IENS,FIELD,"E"))
. . . S @TEMPROOT@(FILE,IENS,FIELD)=$S(X=Y:X,1:X_U_Y)
. . . Q
. . Q
. Q
Q
;
VALIDATE(DATA,MESG) ; VALIDATE DATA IN 'DATA' RETURN ERRORS IN 'MESG'
;N FILE,FIELD,RESULT,VAL,IENS,I,XDRDVALF,TOPFILE,FIRSTLVL
S XDRDVALF=1
F FILE=0:0 S FILE=$O(@DATA@(FILE)) Q:FILE'>0 D
. S TOPFILE=($G(^DD(FILE,0,"UP"))'>0),FIRSTLVL=0
. I 'TOPFILE S I=$G(^DD(FILE,0,"UP")) I $G(^DD(I,0,"UP"))'>0 S FIRSTLVL=1
. S IENS="" F S IENS=$O(@DATA@(FILE,IENS)) Q:IENS="" D
. . F FIELD=0:0 S FIELD=$O(@DATA@(FILE,IENS,FIELD)) Q:FIELD'>0 D
. . . S (X,VAL)=$P(@DATA@(FILE,IENS,FIELD),U)
. . . S YVAL=$S(@DATA@(FILE,IENS,FIELD)[U:$P(@DATA@(FILE,IENS,FIELD),U,2),1:X)
. . . I 'TOPFILE,(FIRSTLVL&(FIELD'=.01))!'FIRSTLVL Q
. . . I FILE=2.101,FIELD=.01 Q ; DISPOSITON DATE/TIME HAS SPCL PROCESSING
. . . I FILE=2,FIELD=63 Q ; LAB POINTER HAS SPCL PROCESSING
. . . I FILE=2,FIELD=.09 Q ; SSN WILL BE ENTERED AS INTERNAL VALUE
. . . I FILE=2,$P(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2" Q ;no NOK
. . . I FILE=354,FIELD=.03 Q ; COPAY EXEMPT STATUS DATE -- BAD
. . . D CHKVALID(MESG,FILE,IENS,FIELD,VAL,YVAL)
. . . Q
. . Q
. Q
Q
;
CHKVALID(MESG,FILE,IENS,FIELD,EXTVAL,INTVAL,HELP) ;
;
Q:FIELD=.001
I $$NEWERR^%ZTER() N $ETRAP,$ESTACK S $ETRAP="D ERR^XDRDVAL"
E S X="ERR^XDRDVAL",@^%ZOSF("TRAP")
S IOP="XDRBROWSER1" D ^%ZIS Q:POP U IO
S XMESG=$NA(^TMP("XDRDVAL-M")) K @XMESG
S ^TMP($J,"LAST","FILE")=FILE,^("IENS")=IENS,^("FIELD")=FIELD,^("X")=EXTVAL,^("Y")=INTVAL
S Y1=EXTVAL D
. S RESULT="^"
. I $P(^DD(FILE,FIELD,0),U,2)["S" S Y1=INTVAL
. I $P(^DD(FILE,FIELD,0),U,2)["V" D
. . N Z S Z=$P(INTVAL,";",2) Q:Z=""
. . S Z=$P($G(@("^"_Z_"0)")),U,1)
. . S Y1=Z_".`"_$P(INTVAL,";")
. . Q
. N DA,D0,DIC,DIE
. D MAKEGLO(FILE,IENS,.DIC,.DA) Q:DA'>0
. S D0=$P(IENS,",",$L(IENS,",")-1),DIE=DIC,DIC(0)=""
. S EXCODE=$P(^DD(FILE,FIELD,0),U,5,999)
. I $P(^DD(FILE,FIELD,0),U,2)["P" S Y1=$S(FILE=2.001:"",1:"`")_INTVAL,Y=INTVAL S Z=U_$P(^(0),U,3),DIC=Z I $D(@(Z_INTVAL_",0)")) S RESULT="" Q
. S X=Y1,FILEA=FILE X EXCODE I $D(X) S RESULT=""
. Q
I $G(RESULT)="^",$G(HELP)["E" M @MESG@(FILE,IENS,FIELD)=^TMP("XDRDVAL-M")
K @XMESG
I RESULT="",FIELD=.01 D CHKNM ; CHECK FOR ,0,"NM", PROBLEM
I $G(RESULT)="^" S @MESG@(FILE,IENS,FIELD,"INVALID")=INTVAL_$S(INTVAL'=EXTVAL:U_EXTVAL,1:"")
U IO D ^%ZISC K ^TMP("DDB",$J,1)
F I=2:1 Q:'$D(^TMP("DDB",$J,I)) S ^(I-1)=^TMP("DDB",$J,I) K ^(I)
I $D(^TMP("DDB",$J)) M @MESG@(FILE,IENS,FIELD,"NOTE")=^TMP("DDB",$J)
Q
;
MAKEGLO(FILENUM,IENS,GLOB,DASTR) ;
N I,ERRFLG,DAVAL,J,FILE,FLD,NODE
S GLOB="",ERRFLG=0 K DASTR
F I=1:1 S FILE=FILENUM,DAVAL(I)=+IENS Q:$D(^DIC(FILE,0,"GL")) D Q:ERRFLG
. S FILENUM=$G(^DD(FILE,0,"UP")) I FILENUM="" S ERRFLG=1 Q
. S FLD=$O(^DD(FILENUM,"SB",FILE,0)) I FLD'>0 S ERRFLG=1 Q
. S NODE=$P($P($G(^DD(FILENUM,FLD,0)),U,4),";") I NODE="" S ERRFLG=1 Q
. S GLOB=""""_NODE_""","_$S(GLOB="":"",1:DAVAL(I)_",")_GLOB
. S IENS=$P(IENS,",",2,99)
. Q
I ERRFLG S DASTR=-1,GLOB="" Q
S GLOB=^DIC(FILE,0,"GL")_$S(GLOB="":"",1:DAVAL(I)_",")_GLOB
F J=2:1:I S DASTR(J-1)=DAVAL(J)
S DASTR=DAVAL(1)
Q
;
CHKNM ; CHECK FOR PROBLEM WITH NM NODE OF SUBFILE NOT BEING CORRECT
N UFILE,UNAME,UFLD
S UFILE=$G(^DD(FILE,0,"UP")) I UFILE'>0 Q
S UFLD=$O(^DD(UFILE,"SB",FILE,"")) Q:UFLD'>0
S UNAME=$P(^DD(UFILE,UFLD,0),U)
I $O(^DD(FILE,0,"NM",""))'=UNAME D
. S RESULT="^"
. W !,"First entry in ^DD("_FILE_",0,""NM"", does not match field name "_UNAME_" in file "_UFILE_". This will be rejected by UPDATE^DIE."
Q
;
ERR ; On an error mark status as error, and save the error message
;
K X S RESULT="^"
S $ECODE=""
S ^TMP("DDB",$J,2)=$ZE
Q
;
OPEN ;
S DDBRZIS=1,DDBDMSG=""
I '$D(XDRDVALF) U IO(0) W !,"...ONE MOMENT..." U IO
Q
;
CLOSE ;
S DDBRZIS=$G(DDBRZIS,1)
N C,CHAR,DDBROS,EOF,X
K ^TMP("DDB",$J)
S DDBROS=^%ZOSF("OS"),EOF="EOF-End Of File"
S CHAR="" F I=1:1:31 S CHAR=CHAR_$C(I)
U IO W !,EOF,!
S DDBRZIS("REWIND")=$$REWIND^%ZIS(IO,IOT,IOPAR)
I 'DDBRZIS("REWIND") S DDBRZIS=0 U IO(0) W $C(7),!!?5,"<< UNABLE TO REWIND FILE>>",! H 3 Q
U IO
S C=0
F R X:1 Q:X="EOF-End Of File" D
.S X=$TR(X,CHAR)
.S:X']"" X=" "
.S C=C+1,^TMP("DDB",$J,C)=$E(X,1,255) Q
.Q
Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDVAL 5485 printed Oct 16, 2024@18:39:55 Page 2
XDRDVAL ;CIOFO-SF.SEA/JLI - Check validity of data elements ;10/02/2000 08:00
+1 ;;7.3;TOOLKIT;**23,32,51**;Apr 25, 1995
+2 ;;
+3 QUIT
+4 ;
DOENTRY(FILE,IEN,OUTROOT,HELP) ; ENTRY POINT TO PROCESS A SINGLE ENTRY
+1 ;N DATAROOT,MESGROOT,TEMPROOT,IENS,FIELD,X
+2 ;S ZTQUEUED=1
NEW ZTQUEUED
+3 SET DATAROOT=$NAME(^TMP($JOB,"XDRDVAL","DATA"))
+4 SET MESGROOT=$NAME(^TMP($JOB,"XDRDVAL","MESG"))
+5 SET TEMPROOT=$NAME(^TMP($JOB,"XDRDVAL","TEMP"))
+6 KILL @DATAROOT,@MESGROOT,@TEMPROOT
+7 DO DOGETS
+8 IF $DATA(@TEMPROOT)
DO VALIDATE(TEMPROOT,$NAME(@MESGROOT@(IEN,"VAL")))
+9 MERGE @OUTROOT@(IEN)=@MESGROOT@(IEN)
+10 QUIT
DOGETS ;
+1 DO GETS^DIQ(FILE,IEN,"**","EIN",DATAROOT,MESGROOT)
+2 ;I $D(@MESGROOT@("DIERR"))>1 M @OUTROOT@(FILE,IEN,"GET","DIERR")=@MESGROOT@("DIERR")
+3 KILL @MESGROOT
+4 FOR FILE=0:0
SET FILE=$ORDER(@DATAROOT@(FILE))
if FILE'>0
QUIT
Begin DoDot:1
+5 SET IENS=""
FOR
SET IENS=$ORDER(@DATAROOT@(FILE,IENS))
if IENS=""
QUIT
Begin DoDot:2
+6 FOR FIELD=0:0
SET FIELD=$ORDER(@DATAROOT@(FILE,IENS,FIELD))
if FIELD'>0
QUIT
Begin DoDot:3
+7 ; RADIOLOGY LOGIC REQUIRES USER INPUT
IF FILE=70.03
IF FIELD=.01
QUIT
+8 ; WORD PROCESSING FIELDS - SKIP
IF $ORDER(@DATAROOT@(FILE,IENS,FIELD,""))>0
KILL @DATAROOT@(FILE,IENS,FIELD)
QUIT
+9 ; SKIP COMPUTED FIELDS
SET Y=$GET(@DATAROOT@(FILE,IENS,FIELD,"I"))
IF Y=""
QUIT
+10 SET X=$GET(@DATAROOT@(FILE,IENS,FIELD,"E"))
+11 SET @TEMPROOT@(FILE,IENS,FIELD)=$SELECT(X=Y:X,1:X_U_Y)
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
VALIDATE(DATA,MESG) ; VALIDATE DATA IN 'DATA' RETURN ERRORS IN 'MESG'
+1 ;N FILE,FIELD,RESULT,VAL,IENS,I,XDRDVALF,TOPFILE,FIRSTLVL
+2 SET XDRDVALF=1
+3 FOR FILE=0:0
SET FILE=$ORDER(@DATA@(FILE))
if FILE'>0
QUIT
Begin DoDot:1
+4 SET TOPFILE=($GET(^DD(FILE,0,"UP"))'>0)
SET FIRSTLVL=0
+5 IF 'TOPFILE
SET I=$GET(^DD(FILE,0,"UP"))
IF $GET(^DD(I,0,"UP"))'>0
SET FIRSTLVL=1
+6 SET IENS=""
FOR
SET IENS=$ORDER(@DATA@(FILE,IENS))
if IENS=""
QUIT
Begin DoDot:2
+7 FOR FIELD=0:0
SET FIELD=$ORDER(@DATA@(FILE,IENS,FIELD))
if FIELD'>0
QUIT
Begin DoDot:3
+8 SET (X,VAL)=$PIECE(@DATA@(FILE,IENS,FIELD),U)
+9 SET YVAL=$SELECT(@DATA@(FILE,IENS,FIELD)[U:$PIECE(@DATA@(FILE,IENS,FIELD),U,2),1:X)
+10 IF 'TOPFILE
IF (FIRSTLVL&(FIELD'=.01))!'FIRSTLVL
QUIT
+11 ; DISPOSITON DATE/TIME HAS SPCL PROCESSING
IF FILE=2.101
IF FIELD=.01
QUIT
+12 ; LAB POINTER HAS SPCL PROCESSING
IF FILE=2
IF FIELD=63
QUIT
+13 ; SSN WILL BE ENTERED AS INTERNAL VALUE
IF FILE=2
IF FIELD=.09
QUIT
+14 ;no NOK
IF FILE=2
IF $PIECE(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2"
QUIT
+15 ; COPAY EXEMPT STATUS DATE -- BAD
IF FILE=354
IF FIELD=.03
QUIT
+16 DO CHKVALID(MESG,FILE,IENS,FIELD,VAL,YVAL)
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
CHKVALID(MESG,FILE,IENS,FIELD,EXTVAL,INTVAL,HELP) ;
+1 ;
+2 if FIELD=.001
QUIT
+3 IF $$NEWERR^%ZTER()
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^XDRDVAL"
+4 IF '$TEST
SET X="ERR^XDRDVAL"
SET @^%ZOSF("TRAP")
+5 SET IOP="XDRBROWSER1"
DO ^%ZIS
if POP
QUIT
USE IO
+6 SET XMESG=$NAME(^TMP("XDRDVAL-M"))
KILL @XMESG
+7 SET ^TMP($JOB,"LAST","FILE")=FILE
SET ^("IENS")=IENS
SET ^("FIELD")=FIELD
SET ^("X")=EXTVAL
SET ^("Y")=INTVAL
+8 SET Y1=EXTVAL
Begin DoDot:1
+9 SET RESULT="^"
+10 IF $PIECE(^DD(FILE,FIELD,0),U,2)["S"
SET Y1=INTVAL
+11 IF $PIECE(^DD(FILE,FIELD,0),U,2)["V"
Begin DoDot:2
+12 NEW Z
SET Z=$PIECE(INTVAL,";",2)
if Z=""
QUIT
+13 SET Z=$PIECE($GET(@("^"_Z_"0)")),U,1)
+14 SET Y1=Z_".`"_$PIECE(INTVAL,";")
+15 QUIT
End DoDot:2
+16 NEW DA,D0,DIC,DIE
+17 DO MAKEGLO(FILE,IENS,.DIC,.DA)
if DA'>0
QUIT
+18 SET D0=$PIECE(IENS,",",$LENGTH(IENS,",")-1)
SET DIE=DIC
SET DIC(0)=""
+19 SET EXCODE=$PIECE(^DD(FILE,FIELD,0),U,5,999)
+20 IF $PIECE(^DD(FILE,FIELD,0),U,2)["P"
SET Y1=$SELECT(FILE=2.001:"",1:"`")_INTVAL
SET Y=INTVAL
SET Z=U_$PIECE(^(0),U,3)
SET DIC=Z
IF $DATA(@(Z_INTVAL_",0)"))
SET RESULT=""
QUIT
+21 SET X=Y1
SET FILEA=FILE
XECUTE EXCODE
IF $DATA(X)
SET RESULT=""
+22 QUIT
End DoDot:1
+23 IF $GET(RESULT)="^"
IF $GET(HELP)["E"
MERGE @MESG@(FILE,IENS,FIELD)=^TMP("XDRDVAL-M")
+24 KILL @XMESG
+25 ; CHECK FOR ,0,"NM", PROBLEM
IF RESULT=""
IF FIELD=.01
DO CHKNM
+26 IF $GET(RESULT)="^"
SET @MESG@(FILE,IENS,FIELD,"INVALID")=INTVAL_$SELECT(INTVAL'=EXTVAL:U_EXTVAL,1:"")
+27 USE IO
DO ^%ZISC
KILL ^TMP("DDB",$JOB,1)
+28 FOR I=2:1
if '$DATA(^TMP("DDB",$JOB,I))
QUIT
SET ^(I-1)=^TMP("DDB",$JOB,I)
KILL ^(I)
+29 IF $DATA(^TMP("DDB",$JOB))
MERGE @MESG@(FILE,IENS,FIELD,"NOTE")=^TMP("DDB",$JOB)
+30 QUIT
+31 ;
MAKEGLO(FILENUM,IENS,GLOB,DASTR) ;
+1 NEW I,ERRFLG,DAVAL,J,FILE,FLD,NODE
+2 SET GLOB=""
SET ERRFLG=0
KILL DASTR
+3 FOR I=1:1
SET FILE=FILENUM
SET DAVAL(I)=+IENS
if $DATA(^DIC(FILE,0,"GL"))
QUIT
Begin DoDot:1
+4 SET FILENUM=$GET(^DD(FILE,0,"UP"))
IF FILENUM=""
SET ERRFLG=1
QUIT
+5 SET FLD=$ORDER(^DD(FILENUM,"SB",FILE,0))
IF FLD'>0
SET ERRFLG=1
QUIT
+6 SET NODE=$PIECE($PIECE($GET(^DD(FILENUM,FLD,0)),U,4),";")
IF NODE=""
SET ERRFLG=1
QUIT
+7 SET GLOB=""""_NODE_""","_$SELECT(GLOB="":"",1:DAVAL(I)_",")_GLOB
+8 SET IENS=$PIECE(IENS,",",2,99)
+9 QUIT
End DoDot:1
if ERRFLG
QUIT
+10 IF ERRFLG
SET DASTR=-1
SET GLOB=""
QUIT
+11 SET GLOB=^DIC(FILE,0,"GL")_$SELECT(GLOB="":"",1:DAVAL(I)_",")_GLOB
+12 FOR J=2:1:I
SET DASTR(J-1)=DAVAL(J)
+13 SET DASTR=DAVAL(1)
+14 QUIT
+15 ;
CHKNM ; CHECK FOR PROBLEM WITH NM NODE OF SUBFILE NOT BEING CORRECT
+1 NEW UFILE,UNAME,UFLD
+2 SET UFILE=$GET(^DD(FILE,0,"UP"))
IF UFILE'>0
QUIT
+3 SET UFLD=$ORDER(^DD(UFILE,"SB",FILE,""))
if UFLD'>0
QUIT
+4 SET UNAME=$PIECE(^DD(UFILE,UFLD,0),U)
+5 IF $ORDER(^DD(FILE,0,"NM",""))'=UNAME
Begin DoDot:1
+6 SET RESULT="^"
+7 WRITE !,"First entry in ^DD("_FILE_",0,""NM"", does not match field name "_UNAME_" in file "_UFILE_". This will be rejected by UPDATE^DIE."
End DoDot:1
+8 QUIT
+9 ;
ERR ; On an error mark status as error, and save the error message
+1 ;
+2 KILL X
SET RESULT="^"
+3 SET $ECODE=""
+4 SET ^TMP("DDB",$JOB,2)=$ZE
+5 QUIT
+6 ;
OPEN ;
+1 SET DDBRZIS=1
SET DDBDMSG=""
+2 IF '$DATA(XDRDVALF)
USE IO(0)
WRITE !,"...ONE MOMENT..."
USE IO
+3 QUIT
+4 ;
CLOSE ;
+1 SET DDBRZIS=$GET(DDBRZIS,1)
+2 NEW C,CHAR,DDBROS,EOF,X
+3 KILL ^TMP("DDB",$JOB)
+4 SET DDBROS=^%ZOSF("OS")
SET EOF="EOF-End Of File"
+5 SET CHAR=""
FOR I=1:1:31
SET CHAR=CHAR_$CHAR(I)
+6 USE IO
WRITE !,EOF,!
+7 SET DDBRZIS("REWIND")=$$REWIND^%ZIS(IO,IOT,IOPAR)
+8 IF 'DDBRZIS("REWIND")
SET DDBRZIS=0
USE IO(0)
WRITE $CHAR(7),!!?5,"<< UNABLE TO REWIND FILE>>",!
HANG 3
QUIT
+9 USE IO
+10 SET C=0
+11 FOR
READ X:1
if X="EOF-End Of File"
QUIT
Begin DoDot:1
+12 SET X=$TRANSLATE(X,CHAR)
+13 if X']""
SET X=" "
+14 SET C=C+1
SET ^TMP("DDB",$JOB,C)=$EXTRACT(X,1,255)
QUIT
+15 QUIT
End DoDot:1
+16 QUIT
+17 QUIT
