- DIDU2 ;SEA/TOAD-VA FileMan: DD Tools, Header Nodes ;1:17 PM 12 Jan 2001 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**72**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;ENTRY POINT--return the value a file's Header Node should have
- ;extrinsic function, DIENS passed by reference
- I '$D(DIQUIET) N DIQUIET S DIQUIET=1
- I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
- N DIROOT D HINPUT(.DIFILE,.DIENS,.DIMSGA,.DIROOT) I $G(DIERR) D Q ""
- . D CLOSE
- N DIHEADER S DIHEADER=$$PIECES12(DIFILE,DIROOT) I $G(DIERR) D Q ""
- . D CLOSE
- N DIRECENT S DIRECENT=$O(@DIROOT@(" "),-1) I DIRECENT="" S DIRECENT=0
- N DICOUNT,DIRECORD S DIRECORD=0
- F DICOUNT=0:1 S DIRECORD=$O(@DIROOT@(DIRECORD)) Q:'DIRECORD I DICOUNT>10000 S DICOUNT=$P($G(@DIROOT@(0)),U,4) Q
- Q DIHEADER_U_DIRECENT_U_DICOUNT
- ;
- HINPUT(DIFILE,DIENS,DIMSGA,DIROOT) ;
- ;evaluate input variables for HEADER call
- I $G(DIMSGA)'="" D
- . K @DIMSGA@("DIERR"),@DIMSGA@("DIHELP"),@DIMSGA@("DIMSG")
- S DIFILE=$G(DIFILE) I DIFILE="" D ERR(202,"","","","FILE") Q
- I $G(^DD(DIFILE,.01,0))="" D Q
- . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) Q
- . I '$D(^DD(DIFILE,.01)) D ERR(406,DIFILE) Q
- . E D ERR(502,DIFILE,"",.01)
- S DIENS=$G(DIENS) I DIENS="" S DIENS=","
- I '$$IEN^DIDU1(DIENS) D Q
- . I '$$IEN^DIDU1(DIENS_",") D ERR(202,"","","","IENS") Q
- . E D ERR(304,"",DIENS)
- S DIROOT=$G(DIFILE("ROOT")) I DIROOT="" D
- . S DIROOT=$$ROOT^DILFD(DIFILE,DIENS,1,1) Q:DIROOT'=""!$G(DIERR)
- . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) Q
- . E D ERR(402,DIFILE,DIENS)
- Q
- ;
- PIECES12(DIFILE,DIROOT) ;
- ;return pieces 1 & 2 of the Header node
- N DIPIECE1,DIPIECE2
- N DINAME S DINAME=$O(^DD(DIFILE,0,"NM","")) I DINAME="" D Q ""
- . D ERR(408,DIFILE)
- N DIPARENT S DIPARENT=$G(^DD(DIFILE,0,"UP"))
- ;
- P1 I DIPARENT'="" D ;subfile
- . S DIPIECE1=""
- . I $P(^DD(DIFILE,.01,0),U,2)["W" D Q
- . . D ERR(407,DIFILE)
- . N DIFIELD S DIFIELD=$O(^DD(DIPARENT,"B",DINAME,""))
- . I DIFIELD="" D Q
- . . D ERR(501,DIFILE,"","",DINAME)
- . N DINODE S DINODE=$G(^DD(DIPARENT,DIFIELD,0)) I DINODE="" D Q
- . . D ERR(502,DIFILE,"",DIFIELD)
- . S DIPIECE2=$P(DINODE,U,2) I DIPIECE2="" D Q
- . . D ERR(502,DIFILE,"",DIFIELD)
- ;
- P2 E D ;root file
- . S DIPIECE1=DINAME
- . S DIPIECE2=DIFILE_$$CODES(DIFILE,DIROOT) I $G(DIERR) Q
- I $G(DIERR) Q ""
- Q DIPIECE1_U_DIPIECE2
- ;
- CODES(DIFILE,DIROOT) ;
- ;collect the file characteristics codes
- N DIFIELD S DIFIELD=$P($G(^DD(DIFILE,.01,0)),U,2) I DIFIELD="" D Q ""
- . I '$D(^DD(DIFILE,.01)) D ERR(501,DIFILE,"","",.01) Q
- . E D ERR(510,DIFILE,"",DIFIELD)
- N DICODES S DICODES=""
- N DITYPE F DITYPE="D","S","P","V" I DIFIELD[DITYPE S DICODES=DITYPE Q
- I $D(^DD(DIFILE,0,"ID")) S DICODES=DICODES_"I"
- I $D(^DD(DIFILE,0,"SCR"))#2 S DICODES=DICODES_"s"
- N DINODE S DINODE=$G(@DIROOT@(0))
- I $P(DINODE,U,2)["A" S DICODES=DICODES_"A"
- I $P(DINODE,U,2)["O" S DICODES=DICODES_"O"
- Q DICODES
- ;
- CLOSE D CALLOUT^DIEFU($G(DIMSGA)):$G(DIMSGA)'="" Q
- ;
- ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
- ;log an error
- N DIPE
- N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
- D BLD^DIALOG(DIERN,.DIPE,.DIPE)
- Q
- DIDU2 ;SEA/TOAD-VA FileMan: DD Tools, Header Nodes ;1:17 PM 12 Jan 2001 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**72**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 ;
- +1 ;ENTRY POINT--return the value a file's Header Node should have
- +2 ;extrinsic function, DIENS passed by reference
- +3 IF '$DATA(DIQUIET)
- NEW DIQUIET
- SET DIQUIET=1
- +4 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- DO INIZE^DIEFU
- +5 NEW DIROOT
- DO HINPUT(.DIFILE,.DIENS,.DIMSGA,.DIROOT)
- IF $GET(DIERR)
- Begin DoDot:1
- +6 DO CLOSE
- End DoDot:1
- QUIT ""
- +7 NEW DIHEADER
- SET DIHEADER=$$PIECES12(DIFILE,DIROOT)
- IF $GET(DIERR)
- Begin DoDot:1
- +8 DO CLOSE
- End DoDot:1
- QUIT ""
- +9 NEW DIRECENT
- SET DIRECENT=$ORDER(@DIROOT@(" "),-1)
- IF DIRECENT=""
- SET DIRECENT=0
- +10 NEW DICOUNT,DIRECORD
- SET DIRECORD=0
- +11 FOR DICOUNT=0:1
- SET DIRECORD=$ORDER(@DIROOT@(DIRECORD))
- IF 'DIRECORD
- QUIT
- IF DICOUNT>10000
- SET DICOUNT=$PIECE($GET(@DIROOT@(0)),U,4)
- QUIT
- +12 QUIT DIHEADER_U_DIRECENT_U_DICOUNT
- +13 ;
- HINPUT(DIFILE,DIENS,DIMSGA,DIROOT) ;
- +1 ;evaluate input variables for HEADER call
- +2 IF $GET(DIMSGA)'=""
- Begin DoDot:1
- +3 KILL @DIMSGA@("DIERR"),@DIMSGA@("DIHELP"),@DIMSGA@("DIMSG")
- End DoDot:1
- +4 SET DIFILE=$GET(DIFILE)
- IF DIFILE=""
- DO ERR(202,"","","","FILE")
- QUIT
- +5 IF $GET(^DD(DIFILE,.01,0))=""
- Begin DoDot:1
- +6 IF '$DATA(^DD(DIFILE))
- DO ERR(401,DIFILE)
- QUIT
- +7 IF '$DATA(^DD(DIFILE,.01))
- DO ERR(406,DIFILE)
- QUIT
- +8 IF '$TEST
- DO ERR(502,DIFILE,"",.01)
- End DoDot:1
- QUIT
- +9 SET DIENS=$GET(DIENS)
- IF DIENS=""
- SET DIENS=","
- +10 IF '$$IEN^DIDU1(DIENS)
- Begin DoDot:1
- +11 IF '$$IEN^DIDU1(DIENS_",")
- DO ERR(202,"","","","IENS")
- QUIT
- +12 IF '$TEST
- DO ERR(304,"",DIENS)
- End DoDot:1
- QUIT
- +13 SET DIROOT=$GET(DIFILE("ROOT"))
- IF DIROOT=""
- Begin DoDot:1
- +14 SET DIROOT=$$ROOT^DILFD(DIFILE,DIENS,1,1)
- IF DIROOT'=""!$GET(DIERR)
- QUIT
- +15 IF '$DATA(^DD(DIFILE))
- DO ERR(401,DIFILE)
- QUIT
- +16 IF '$TEST
- DO ERR(402,DIFILE,DIENS)
- End DoDot:1
- +17 QUIT
- +18 ;
- PIECES12(DIFILE,DIROOT) ;
- +1 ;return pieces 1 & 2 of the Header node
- +2 NEW DIPIECE1,DIPIECE2
- +3 NEW DINAME
- SET DINAME=$ORDER(^DD(DIFILE,0,"NM",""))
- IF DINAME=""
- Begin DoDot:1
- +4 DO ERR(408,DIFILE)
- End DoDot:1
- QUIT ""
- +5 NEW DIPARENT
- SET DIPARENT=$GET(^DD(DIFILE,0,"UP"))
- +6 ;
- P1 ;subfile
- IF DIPARENT'=""
- Begin DoDot:1
- +1 SET DIPIECE1=""
- +2 IF $PIECE(^DD(DIFILE,.01,0),U,2)["W"
- Begin DoDot:2
- +3 DO ERR(407,DIFILE)
- End DoDot:2
- QUIT
- +4 NEW DIFIELD
- SET DIFIELD=$ORDER(^DD(DIPARENT,"B",DINAME,""))
- +5 IF DIFIELD=""
- Begin DoDot:2
- +6 DO ERR(501,DIFILE,"","",DINAME)
- End DoDot:2
- QUIT
- +7 NEW DINODE
- SET DINODE=$GET(^DD(DIPARENT,DIFIELD,0))
- IF DINODE=""
- Begin DoDot:2
- +8 DO ERR(502,DIFILE,"",DIFIELD)
- End DoDot:2
- QUIT
- +9 SET DIPIECE2=$PIECE(DINODE,U,2)
- IF DIPIECE2=""
- Begin DoDot:2
- +10 DO ERR(502,DIFILE,"",DIFIELD)
- End DoDot:2
- QUIT
- End DoDot:1
- +11 ;
- P2 ;root file
- IF '$TEST
- Begin DoDot:1
- +1 SET DIPIECE1=DINAME
- +2 SET DIPIECE2=DIFILE_$$CODES(DIFILE,DIROOT)
- IF $GET(DIERR)
- QUIT
- End DoDot:1
- +3 IF $GET(DIERR)
- QUIT ""
- +4 QUIT DIPIECE1_U_DIPIECE2
- +5 ;
- CODES(DIFILE,DIROOT) ;
- +1 ;collect the file characteristics codes
- +2 NEW DIFIELD
- SET DIFIELD=$PIECE($GET(^DD(DIFILE,.01,0)),U,2)
- IF DIFIELD=""
- Begin DoDot:1
- +3 IF '$DATA(^DD(DIFILE,.01))
- DO ERR(501,DIFILE,"","",.01)
- QUIT
- +4 IF '$TEST
- DO ERR(510,DIFILE,"",DIFIELD)
- End DoDot:1
- QUIT ""
- +5 NEW DICODES
- SET DICODES=""
- +6 NEW DITYPE
- FOR DITYPE="D","S","P","V"
- IF DIFIELD[DITYPE
- SET DICODES=DITYPE
- QUIT
- +7 IF $DATA(^DD(DIFILE,0,"ID"))
- SET DICODES=DICODES_"I"
- +8 IF $DATA(^DD(DIFILE,0,"SCR"))#2
- SET DICODES=DICODES_"s"
- +9 NEW DINODE
- SET DINODE=$GET(@DIROOT@(0))
- +10 IF $PIECE(DINODE,U,2)["A"
- SET DICODES=DICODES_"A"
- +11 IF $PIECE(DINODE,U,2)["O"
- SET DICODES=DICODES_"O"
- +12 QUIT DICODES
- +13 ;
- CLOSE IF $GET(DIMSGA)'=""
- DO CALLOUT^DIEFU($GET(DIMSGA))
- QUIT
- +1 ;
- ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
- +1 ;log an error
- +2 NEW DIPE
- +3 NEW DI
- FOR DI="FILE","IENS","FIELD",1:1:3
- SET DIPE(DI)=$GET(@("DI"_DI))
- +4 DO BLD^DIALOG(DIERN,.DIPE,.DIPE)
- +5 QUIT
