- DIDU ;SEA/TOAD - VA FileMan: DD Tools, External Format ;5NOV2012
- ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ;
- ;DIFLAGS Flags (to control output transforms on pointers)
- ; ("F"=execute first output transform, "L"=execute last output transform, "i"=return internal value of field at end of pointer chain,
- ; "h"=return external value but don't execute output transform).
- ;
- ; convert a value from internal to external format
- ; used all over lookup routines
- ;
- XTRNLX ;
- ;
- ; support for documented entry point $$EXTERNAL^DILFD
- ; branch from DILFD or DIQGU
- ;
- E1 ; set up DBS environment variables
- ;
- I '$D(DIQUIET) N DIQUIET S DIQUIET=1
- I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
- N DICLERR S DICLERR=$G(DIERR) K DIERR
- ;
- E2 ; handle bad input variables
- ;
- I $G(DINTERNL)="" Q ""
- S DIMSGA=$G(DIMSGA)
- S DIFLAGS=$G(DIFLAGS)
- I DIFLAGS'?.1(1"F",1"L",1"U",1"i",1"h",1"A") D ERR(DIMSGA,301,"","","",DIFLAGS) Q ""
- I $G(DIFIELD)'>0 D ERR(DIMSGA,202,"","","","FIELD") Q ""
- ;
- E3 ; get field definition and type, handle bad file or field
- ;
- I $G(DIFILE)<0 D ERR(DIMSGA,202,"","","","FILE") Q ""
- N DINODE S DINODE=$G(^DD(DIFILE,DIFIELD,0))
- I DINODE="" D Q ""
- . I '$D(^DD(DIFILE)) D ERR(DIMSGA,401,DIFILE)
- . E D ERR(DIMSGA,501,DIFILE,"",DIFIELD,DIFIELD)
- N DITYPE S DITYPE=$P(DINODE,U,2)
- ;
- E4 ; initialize loop control, transform code, pointer chain window,
- ; pointer file info, and resolved value variables
- ;
- N DICHAIN,DIDONE,DIOUT S (DICHAIN,DIDONE,DIOUT)=0
- N DIXFORM S DIXFORM=""
- N DINEXT,DIPREV,DIPREVF S (DINEXT,DIPREV,DIPREVF)=""
- N DIEN,DIHEAD,DIROOT S DIEN=""
- N DIEXTRNL S DIEXTRNL=""
- ;
- E5 ; handle output transforms (see docs for effects of flags)
- ; under right conditions, execute output transform on value & quit
- ;
- F D I DIDONE!$G(DIERR)!DIOUT Q
- . I DIFLAGS["U",DIXFORM'="",DITYPE'["P",DITYPE'["V" S DITYPE=DITYPE_"O"
- TYPE . I DITYPE["O"!(DITYPE["t"),DIFLAGS'["i",DIFLAGS'["h" D I DIDONE!$G(DIERR) Q
- . . I DIFLAGS["F",DICHAIN Q
- . . I DIFLAGS["L",DITYPE["P"!(DITYPE["V") Q
- . . I DIXFORM=""!(DIFLAGS'["U") S DIXFORM=$G(^DD(DIFILE,DIFIELD,2)) I DITYPE["t" S DIXFORM=$$OUTPUT^DIETLIBF
- . . I DIXFORM="" Q
- . . I DIFLAGS["U",DITYPE["P"!(DITYPE["V") Q
- . . N Y S Y=DINTERNL X DIXFORM
- . . I $G(DIERR) D ERR^DICF4(120,DIFILE,DIEN,"","Output Transform") Q
- . . S DIEXTRNL=Y,DIDONE=1
- .
- E6 . ; continue with loop only for pointers or variable pointers
- .
- . I DITYPE S DIOUT=1 Q
- . I DITYPE'["P",DITYPE'["V" S DIOUT=1 Q
- .
- E7 . ; if the value's not numeric, it's not valid; note that throughout
- . ; module we return two different errors depending on whether the
- . ; value passed in is bad, or one found in the pointer chain is
- .
- . I 'DINTERNL D Q
- . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"pointer") Q
- . . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"pointer")
- .
- E8 . ; get pointed to file's root and #
- .
- . I DITYPE["P" S DIROOT=$P(DINODE,U,3),DINEXT=+$P($P(DINODE,U,2),"P",2) D Q:$G(DIERR)
- . . I DIROOT="DIC(.2," S DINEXT=.2
- . . I 'DINEXT!(DIROOT="") D ERR(DIMSGA,537,DIFILE,,DIFIELD)
- . . Q
- . I DITYPE["V" S DIROOT=$P(DINTERNL,";",2),DINEXT="" D Q:$G(DIERR)
- . . I DIROOT="" D ERR(DIMSGA,348,,,,DINTERNL) Q
- . . S DIHEAD=$G(@(U_DIROOT_"0)"))
- . . I DIHEAD="" D Q
- . . . D HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT)
- . . S DINEXT=+$P(DIHEAD,U,2) I 'DINEXT D Q
- . . . D ERR(DIMSGA,404,"","","",$$CREF^DILF(U_DIROOT))
- .
- E9 . ; ensure pointed to data file exists, and advance file #s
- .
- . I '$D(@(U_DIROOT_"+DINTERNL)")) D Q
- . . N DI S DI="pointer to File #"
- . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,DI_DINEXT) Q
- . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,DI_DINEXT)
- . S DIPREV=DIFILE,DIFILE=DINEXT
- .
- E10 . ; advance pointer value, file characteristics, & pointer window
- . ; ensure pointed to record exists, & its .01 has a DD
- . ; set flag that we are now in the pointer chain
- .
- . S DIEN=+DINTERNL
- . S DINTERNL=$P($G(^(DIEN,0)),U) ;***** Naked *****
- . I DINTERNL="" D ERR(DIMSGA,603,DIFILE,"",.01,DIEN) Q
- . S DINODE=$G(^DD(DIFILE,.01,0))
- . S DITYPE=$P(DINODE,U,2)
- . I DITYPE="" D ERR(DIMSGA,510,DIFILE,"",.01) Q
- . S DIPREVF=DIFIELD,DIFIELD=.01
- . S DICHAIN=1
- . S:DIFILE=.2 DIDONE=1 Q
- ;
- E11 ; exit if we executed an output transform or ran into an error
- ;
- ; Special "i" flag returns internal value at end of pointer chain
- I DIFLAGS["i" Q DINTERNL
- I DIFILE=.2 Q DINTERNL
- I DIDONE Q DIEXTRNL
- I $G(DIERR) Q ""
- ;
- E12 ; handle illegal data types (pointers, word processings, and multiples)
- ;
- I DITYPE["C" D ERRPTR("Computed") Q ""
- I DITYPE["W" D ERRPTR("Word Processing") Q ""
- I DITYPE S DITYPE=$P($G(^DD(+DITYPE,.01,0)),U,2) D Q ""
- . I DITYPE["W" D ERRPTR("Word Processing") Q
- . D ERRPTR("Multiple") Q
- ;
- E13 ; handle sets of codes
- ;
- I DITYPE["S" D Q DIEXTRNL
- . N DICODES S DICODES=$P(DINODE,U,3)
- . N DISTART S DISTART=$F(";"_DICODES,";"_DINTERNL_":")
- . I 'DISTART S DIEXTRNL="" D Q
- . . I 'DICHAIN D ERR(DIMSGA,730,DIFILE,"",DIFIELD,DINTERNL,"code") Q
- . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,"code")
- SET . S DISTART=DINTERNL D PARSET^DIQ(DICODES,.DISTART) S DIEXTRNL=DISTART
- ;
- E14 ; handle dates, and return all others as they are
- ;
- I DITYPE["D",DINTERNL D Q DIEXTRNL
- . S DIEXTRNL=$$DATE^DIUTL(DINTERNL) ;**CCO/NI
- . I DIEXTRNL'="" Q
- . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"date") Q
- . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"date")
- I DICLERR'=""!$G(DIERR) D
- . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
- Q DINTERNL
- ;
- ;
- ; pick a header error and log it
- ; EXTERNAL
- ;
- I DITYPE["P" D ; pointer
- . I 'DINEXT!'$D(^DD(DINEXT)) D ERR(DIMSGA,537,DIFILE,"",DIFIELD) Q
- . D ERR(DIMSGA,403,DINEXT)
- ;
- E D ; variable pointer
- . I DICHAIN D ERR(DIMSGA,648,DIFILE,"",DIFIELD,DIEN,DINTERNL) Q
- . D ERR(DIMSGA,348,"","","",DINTERNL)
- Q
- ;
- ERR(DIMSGA,DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
- ;
- ; error logging procedure
- ; EXTERNAL
- ;
- I $G(DIFLAGS)["A",$$ALLOW(DIERN) S DIDONE=1 Q
- N DIPE,DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
- D BLD^DIALOG(DIERN,.DIPE,.DIPE,DIMSGA,"F")
- S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
- Q
- ;
- ERRPTR(DITYPE) ;
- ;
- ; error logging shell for errors 520 & 537
- ; EXTERNAL
- ;
- I DICHAIN D ERR(DIMSGA,537,DIPREV,"",DIPREVF) Q
- D ERR(DIMSGA,520,DIFILE,"",DIFIELD,DITYPE)
- Q
- ;
- ALLOW(X) ;If ALLOW appears, do not call erroneous data an error
- N I,T F I=3:1 S T=$T(ALLOW+I) Q:T?.P I T[X Q:T'["ALLOW" K T Q
- Q '$D(T)
- ; 202 The input parameter that identifies the |1
- ; 301 The passed flag(s) '|1|' are unknown or in
- ; 330 The value '|1|' is not a valid |2|. ALLOW
- ; 348 The passed value '|1|' points to a file th
- ; 401 File #|FILE| does not exist.
- ; 403 File #|FILE| lacks a Header Node.
- ; 404 The File Header node of the file stored at
- ; 501 File #|FILE| does not contain a field |1|.
- ; 510 The data type for Field #|FIELD| in File #
- ; 520 A |1| field cannot be processed by this ut
- ; 537 Field #|FIELD| in File #|FILE| has a corru
- ; 603 Entry #|1| in File #|FILE| lacks the requi
- ; 630 In Entry #|1| of File #|FILE|, the value ' ALLOW
- ; 648 In Entry #|1| of File #|FILE|, the value '
- ; 730 The value '|1|' is not a valid |2| accordi ALLOW
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDU 7898 printed Jan 18, 2025@03:47:54 Page 2
- DIDU ;SEA/TOAD - VA FileMan: DD Tools, External Format ;5NOV2012
- +1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ;
- +1 ;DIFLAGS Flags (to control output transforms on pointers)
- +2 ; ("F"=execute first output transform, "L"=execute last output transform, "i"=return internal value of field at end of pointer chain,
- +3 ; "h"=return external value but don't execute output transform).
- +4 ;
- +5 ; convert a value from internal to external format
- +6 ; used all over lookup routines
- +7 ;
- XTRNLX ;
- +1 ;
- +2 ; support for documented entry point $$EXTERNAL^DILFD
- +3 ; branch from DILFD or DIQGU
- +4 ;
- E1 ; set up DBS environment variables
- +1 ;
- +2 IF '$DATA(DIQUIET)
- NEW DIQUIET
- SET DIQUIET=1
- +3 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- DO INIZE^DIEFU
- +4 NEW DICLERR
- SET DICLERR=$GET(DIERR)
- KILL DIERR
- +5 ;
- E2 ; handle bad input variables
- +1 ;
- +2 IF $GET(DINTERNL)=""
- QUIT ""
- +3 SET DIMSGA=$GET(DIMSGA)
- +4 SET DIFLAGS=$GET(DIFLAGS)
- +5 IF DIFLAGS'?.1(1"F",1"L",1"U",1"i",1"h",1"A")
- DO ERR(DIMSGA,301,"","","",DIFLAGS)
- QUIT ""
- +6 IF $GET(DIFIELD)'>0
- DO ERR(DIMSGA,202,"","","","FIELD")
- QUIT ""
- +7 ;
- E3 ; get field definition and type, handle bad file or field
- +1 ;
- +2 IF $GET(DIFILE)<0
- DO ERR(DIMSGA,202,"","","","FILE")
- QUIT ""
- +3 NEW DINODE
- SET DINODE=$GET(^DD(DIFILE,DIFIELD,0))
- +4 IF DINODE=""
- Begin DoDot:1
- +5 IF '$DATA(^DD(DIFILE))
- DO ERR(DIMSGA,401,DIFILE)
- +6 IF '$TEST
- DO ERR(DIMSGA,501,DIFILE,"",DIFIELD,DIFIELD)
- End DoDot:1
- QUIT ""
- +7 NEW DITYPE
- SET DITYPE=$PIECE(DINODE,U,2)
- +8 ;
- E4 ; initialize loop control, transform code, pointer chain window,
- +1 ; pointer file info, and resolved value variables
- +2 ;
- +3 NEW DICHAIN,DIDONE,DIOUT
- SET (DICHAIN,DIDONE,DIOUT)=0
- +4 NEW DIXFORM
- SET DIXFORM=""
- +5 NEW DINEXT,DIPREV,DIPREVF
- SET (DINEXT,DIPREV,DIPREVF)=""
- +6 NEW DIEN,DIHEAD,DIROOT
- SET DIEN=""
- +7 NEW DIEXTRNL
- SET DIEXTRNL=""
- +8 ;
- E5 ; handle output transforms (see docs for effects of flags)
- +1 ; under right conditions, execute output transform on value & quit
- +2 ;
- +3 FOR
- Begin DoDot:1
- +4 IF DIFLAGS["U"
- IF DIXFORM'=""
- IF DITYPE'["P"
- IF DITYPE'["V"
- SET DITYPE=DITYPE_"O"
- TYPE IF DITYPE["O"!(DITYPE["t")
- IF DIFLAGS'["i"
- IF DIFLAGS'["h"
- Begin DoDot:2
- +1 IF DIFLAGS["F"
- IF DICHAIN
- QUIT
- +2 IF DIFLAGS["L"
- IF DITYPE["P"!(DITYPE["V")
- QUIT
- +3 IF DIXFORM=""!(DIFLAGS'["U")
- SET DIXFORM=$GET(^DD(DIFILE,DIFIELD,2))
- IF DITYPE["t"
- SET DIXFORM=$$OUTPUT^DIETLIBF
- +4 IF DIXFORM=""
- QUIT
- +5 IF DIFLAGS["U"
- IF DITYPE["P"!(DITYPE["V")
- QUIT
- +6 NEW Y
- SET Y=DINTERNL
- XECUTE DIXFORM
- +7 IF $GET(DIERR)
- DO ERR^DICF4(120,DIFILE,DIEN,"","Output Transform")
- QUIT
- +8 SET DIEXTRNL=Y
- SET DIDONE=1
- End DoDot:2
- IF DIDONE!$GET(DIERR)
- QUIT
- +9 E6 ; continue with loop only for pointers or variable pointers
- +1 +2 IF DITYPE
- SET DIOUT=1
- QUIT
- +3 IF DITYPE'["P"
- IF DITYPE'["V"
- SET DIOUT=1
- QUIT
- +4 E7 ; if the value's not numeric, it's not valid; note that throughout
- +1 ; module we return two different errors depending on whether the
- +2 ; value passed in is bad, or one found in the pointer chain is
- +3 +4 IF 'DINTERNL
- Begin DoDot:2
- +5 IF 'DICHAIN
- DO ERR(DIMSGA,330,"","","",DINTERNL,"pointer")
- QUIT
- +6 DO ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"pointer")
- End DoDot:2
- QUIT
- +7 E8 ; get pointed to file's root and #
- +1 +2 IF DITYPE["P"
- SET DIROOT=$PIECE(DINODE,U,3)
- SET DINEXT=+$PIECE($PIECE(DINODE,U,2),"P",2)
- Begin DoDot:2
- +3 IF DIROOT="DIC(.2,"
- SET DINEXT=.2
- +4 IF 'DINEXT!(DIROOT="")
- DO ERR(DIMSGA,537,DIFILE,,DIFIELD)
- +5 QUIT
- End DoDot:2
- if $GET(DIERR)
- QUIT
- +6 IF DITYPE["V"
- SET DIROOT=$PIECE(DINTERNL,";",2)
- SET DINEXT=""
- Begin DoDot:2
- +7 IF DIROOT=""
- DO ERR(DIMSGA,348,,,,DINTERNL)
- QUIT
- +8 SET DIHEAD=$GET(@(U_DIROOT_"0)"))
- +9 IF DIHEAD=""
- Begin DoDot:3
- +10 DO HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT)
- End DoDot:3
- QUIT
- +11 SET DINEXT=+$PIECE(DIHEAD,U,2)
- IF 'DINEXT
- Begin DoDot:3
- +12 DO ERR(DIMSGA,404,"","","",$$CREF^DILF(U_DIROOT))
- End DoDot:3
- QUIT
- End DoDot:2
- if $GET(DIERR)
- QUIT
- +13 E9 ; ensure pointed to data file exists, and advance file #s
- +1 +2 IF '$DATA(@(U_DIROOT_"+DINTERNL)"))
- Begin DoDot:2
- +3 NEW DI
- SET DI="pointer to File #"
- +4 IF 'DICHAIN
- DO ERR(DIMSGA,330,"","","",DINTERNL,DI_DINEXT)
- QUIT
- +5 DO ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,DI_DINEXT)
- End DoDot:2
- QUIT
- +6 SET DIPREV=DIFILE
- SET DIFILE=DINEXT
- +7 E10 ; advance pointer value, file characteristics, & pointer window
- +1 ; ensure pointed to record exists, & its .01 has a DD
- +2 ; set flag that we are now in the pointer chain
- +3 +4 SET DIEN=+DINTERNL
- +5 ;***** Naked *****
- SET DINTERNL=$PIECE($GET(^(DIEN,0)),U)
- +6 IF DINTERNL=""
- DO ERR(DIMSGA,603,DIFILE,"",.01,DIEN)
- QUIT
- +7 SET DINODE=$GET(^DD(DIFILE,.01,0))
- +8 SET DITYPE=$PIECE(DINODE,U,2)
- +9 IF DITYPE=""
- DO ERR(DIMSGA,510,DIFILE,"",.01)
- QUIT
- +10 SET DIPREVF=DIFIELD
- SET DIFIELD=.01
- +11 SET DICHAIN=1
- +12 if DIFILE=.2
- SET DIDONE=1
- QUIT
- End DoDot:1
- IF DIDONE!$GET(DIERR)!DIOUT
- QUIT
- +13 ;
- E11 ; exit if we executed an output transform or ran into an error
- +1 ;
- +2 ; Special "i" flag returns internal value at end of pointer chain
- +3 IF DIFLAGS["i"
- QUIT DINTERNL
- +4 IF DIFILE=.2
- QUIT DINTERNL
- +5 IF DIDONE
- QUIT DIEXTRNL
- +6 IF $GET(DIERR)
- QUIT ""
- +7 ;
- E12 ; handle illegal data types (pointers, word processings, and multiples)
- +1 ;
- +2 IF DITYPE["C"
- DO ERRPTR("Computed")
- QUIT ""
- +3 IF DITYPE["W"
- DO ERRPTR("Word Processing")
- QUIT ""
- +4 IF DITYPE
- SET DITYPE=$PIECE($GET(^DD(+DITYPE,.01,0)),U,2)
- Begin DoDot:1
- +5 IF DITYPE["W"
- DO ERRPTR("Word Processing")
- QUIT
- +6 DO ERRPTR("Multiple")
- QUIT
- End DoDot:1
- QUIT ""
- +7 ;
- E13 ; handle sets of codes
- +1 ;
- +2 IF DITYPE["S"
- Begin DoDot:1
- +3 NEW DICODES
- SET DICODES=$PIECE(DINODE,U,3)
- +4 NEW DISTART
- SET DISTART=$FIND(";"_DICODES,";"_DINTERNL_":")
- +5 IF 'DISTART
- SET DIEXTRNL=""
- Begin DoDot:2
- +6 IF 'DICHAIN
- DO ERR(DIMSGA,730,DIFILE,"",DIFIELD,DINTERNL,"code")
- QUIT
- +7 DO ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,"code")
- End DoDot:2
- QUIT
- SET SET DISTART=DINTERNL
- DO PARSET^DIQ(DICODES,.DISTART)
- SET DIEXTRNL=DISTART
- End DoDot:1
- QUIT DIEXTRNL
- +1 ;
- E14 ; handle dates, and return all others as they are
- +1 ;
- +2 IF DITYPE["D"
- IF DINTERNL
- Begin DoDot:1
- +3 ;**CCO/NI
- SET DIEXTRNL=$$DATE^DIUTL(DINTERNL)
- +4 IF DIEXTRNL'=""
- QUIT
- +5 IF 'DICHAIN
- DO ERR(DIMSGA,330,"","","",DINTERNL,"date")
- QUIT
- +6 DO ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"date")
- End DoDot:1
- QUIT DIEXTRNL
- +7 IF DICLERR'=""!$GET(DIERR)
- Begin DoDot:1
- +8 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
- End DoDot:1
- +9 QUIT DINTERNL
- +10 ;
- +1 ;
- +2 ; pick a header error and log it
- +3 ; EXTERNAL
- +4 ;
- +5 ; pointer
- IF DITYPE["P"
- Begin DoDot:1
- +6 IF 'DINEXT!'$DATA(^DD(DINEXT))
- DO ERR(DIMSGA,537,DIFILE,"",DIFIELD)
- QUIT
- +7 DO ERR(DIMSGA,403,DINEXT)
- End DoDot:1
- +8 ;
- +9 ; variable pointer
- IF '$TEST
- Begin DoDot:1
- +10 IF DICHAIN
- DO ERR(DIMSGA,648,DIFILE,"",DIFIELD,DIEN,DINTERNL)
- QUIT
- +11 DO ERR(DIMSGA,348,"","","",DINTERNL)
- End DoDot:1
- +12 QUIT
- +13 ;
- ERR(DIMSGA,DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
- +1 ;
- +2 ; error logging procedure
- +3 ; EXTERNAL
- +4 ;
- +5 IF $GET(DIFLAGS)["A"
- IF $$ALLOW(DIERN)
- SET DIDONE=1
- QUIT
- +6 NEW DIPE,DI
- FOR DI="FILE","IENS","FIELD",1:1:3
- SET DIPE(DI)=$GET(@("DI"_DI))
- +7 DO BLD^DIALOG(DIERN,.DIPE,.DIPE,DIMSGA,"F")
- +8 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
- +9 QUIT
- +10 ;
- ERRPTR(DITYPE) ;
- +1 ;
- +2 ; error logging shell for errors 520 & 537
- +3 ; EXTERNAL
- +4 ;
- +5 IF DICHAIN
- DO ERR(DIMSGA,537,DIPREV,"",DIPREVF)
- QUIT
- +6 DO ERR(DIMSGA,520,DIFILE,"",DIFIELD,DITYPE)
- +7 QUIT
- +8 ;
- ALLOW(X) ;If ALLOW appears, do not call erroneous data an error
- +1 NEW I,T
- FOR I=3:1
- SET T=$TEXT(ALLOW+I)
- if T?.P
- QUIT
- IF T[X
- if T'["ALLOW"
- QUIT
- KILL T
- QUIT
- +2 QUIT '$DATA(T)
- +3 ; 202 The input parameter that identifies the |1
- +4 ; 301 The passed flag(s) '|1|' are unknown or in
- +5 ; 330 The value '|1|' is not a valid |2|. ALLOW
- +6 ; 348 The passed value '|1|' points to a file th
- +7 ; 401 File #|FILE| does not exist.
- +8 ; 403 File #|FILE| lacks a Header Node.
- +9 ; 404 The File Header node of the file stored at
- +10 ; 501 File #|FILE| does not contain a field |1|.
- +11 ; 510 The data type for Field #|FIELD| in File #
- +12 ; 520 A |1| field cannot be processed by this ut
- +13 ; 537 Field #|FIELD| in File #|FILE| has a corru
- +14 ; 603 Entry #|1| in File #|FILE| lacks the requi
- +15 ; 630 In Entry #|1| of File #|FILE|, the value ' ALLOW
- +16 ; 648 In Entry #|1| of File #|FILE|, the value '
- +17 ; 730 The value '|1|' is not a valid |2| accordi ALLOW
- +18 ;