DIDU ;SEA/TOAD-VA FileMan: DD Tools, External Format ;24AUG2009
;;22.0;VA FileMan;**31,48,162**;Mar 30, 1999;Build 21
;Per VHA Directive 2004-038, this routine should not be modified.
;
EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ;
;
; 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"
. I DITYPE["O",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 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")
. S DIEXTRNL=$P($E(DICODES,DISTART,$L(DICODES)),";")
;
E14 ; handle dates, and return all others as they are
;
I DITYPE["D",DINTERNL D Q DIEXTRNL
. S DIEXTRNL=$$FMTE^DILIBF(DINTERNL,"1U")
. 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
;
DIDU ;SEA/TOAD-VA FileMan: DD Tools, External Format ;24AUG2009
+1 ;;22.0;VA FileMan;**31,48,162**;Mar 30, 1999;Build 21
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ;
+1 ;
+2 ; convert a value from internal to external format
+3 ; used all over lookup routines
+4 ;
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"
+5 IF DITYPE["O"
IF DIFLAGS'["i"
IF DIFLAGS'["h"
Begin DoDot:2
+6 IF DIFLAGS["F"
IF DICHAIN
QUIT
+7 IF DIFLAGS["L"
IF DITYPE["P"!(DITYPE["V")
QUIT
+8 IF DIXFORM=""!(DIFLAGS'["U")
SET DIXFORM=$GET(^DD(DIFILE,DIFIELD,2))
+9 IF DIXFORM=""
QUIT
+10 IF DIFLAGS["U"
IF DITYPE["P"!(DITYPE["V")
QUIT
+11 NEW Y
SET Y=DINTERNL
XECUTE DIXFORM
+12 IF $GET(DIERR)
DO ERR^DICF4(120,DIFILE,DIEN,"","Output Transform")
QUIT
+13 SET DIEXTRNL=Y
SET DIDONE=1
End DoDot:2
IF DIDONE!$GET(DIERR)
QUIT
+14 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
+8 SET DIEXTRNL=$PIECE($EXTRACT(DICODES,DISTART,$LENGTH(DICODES)),";")
End DoDot:1
QUIT DIEXTRNL
+9 ;
E14 ; handle dates, and return all others as they are
+1 ;
+2 IF DITYPE["D"
IF DINTERNL
Begin DoDot:1
+3 SET DIEXTRNL=$$FMTE^DILIBF(DINTERNL,"1U")
+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 ;
