- 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 Feb 19, 2025@00:05:46 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