DIDU2 ;SEA/TOAD-VA FileMan: DD Tools, Header Nodes ;1:17 PM 12 Jan 2001
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDU2 3375 printed Dec 13, 2024@02:46:57 Page 2
DIDU2 ;SEA/TOAD-VA FileMan: DD Tools, Header Nodes ;1:17 PM 12 Jan 2001
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
+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
