- DIDU1 ;SEA/TOAD-VA FileMan: DD Tools, IENS Check ;10:39 AM 8 Jul 1998
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- IEN(DIENS,DIFLAGS) ;
- ;ENTRY POINT--return whether the IEN String is valid
- ;extrinsic function, all passed by value
- I $G(DIENS)="" Q 0
- I $G(DIFLAGS,"N")'="N" Q 0
- S DIFLAGS=$G(DIFLAGS)
- N DICHAR,DICRSR,DIPIECE,DISEQ,DIOUT,DIVALID
- S DIPIECE="",DISEQ="",DIOUT=0,DIVALID=1
- F DICRSR=1:1 D I DIOUT Q
- .S DIPIECE=$P(DIENS,",",DICRSR)
- .I DIPIECE="" D Q
- ..I $P(DIENS,",",DICRSR,999)="" S DIOUT=1 Q
- I1 ..I DICRSR=1 Q
- ..S DIOUT=1,DIVALID=0
- ..Q
- .I +DIPIECE=DIPIECE S DIVALID=DIPIECE>0,DIOUT='DIVALID Q
- .I DIFLAGS["N" S DIVALID=0,DIOUT=1 Q
- .S DICHAR=$E(DIPIECE,1,2) I DICHAR'="?+" S DICHAR=$E(DICHAR)
- .I DICHAR'="+",DICHAR'="?",DICHAR'="?+" S DIOUT=1,DIVALID=0 Q
- .I $P(DIPIECE,DICHAR,2,9999)?1N.N D Q
- ..S DISEQ=$P(DIPIECE,DICHAR,2,999)
- ..S DIOUT=+DISEQ'=DISEQ!$D(DISEQ(DISEQ)),DIVALID='DIOUT Q
- I2 .S DIOUT=1,DIVALID=0
- .Q
- Q $E(DIENS,$L(DIENS))=","&DIVALID
- ;
- PROOT(DIFILE,DIENS) ;
- ;ENTRY POINT--return the global root of a subfile's parent
- ;extrinsic function, all passed by value
- Q $$ROOT^DILFD($$PARENT(DIFILE),$P(DIENS,",",2,999),1)
- ;
- PARENT(DIFILE) ;
- ;ENTRY POINT--return the file number of a subfile's parent
- ;extrinsic function, all passed by value
- Q $G(^DD(DIFILE,0,"UP"))
- ;
- PARENTS(DIFILE,DIRULE) ;
- ;IEN--return the file's parents
- ;procedure, passed by ref
- N DIBACK,DIOUT,DIMOM,DITEMP
- S DIOUT=0,DIMOM=DIFILE
- S DITEMP=DIFILE K DIFILE S (DIFILE,DIFILE("C"))=DITEMP
- S DIFILE("L")=$$LEVEL(DIFILE)
- S DIFILE(1)=DIFILE
- I '$D(DIRULE("L",DIFILE)) S DIRULE("L",DIFILE)=DIFILE("L")
- F DIBACK=2:1 D I DIOUT Q
- .S DITEMP=DIMOM
- .S DIMOM=$G(DIRULE("UP",DITEMP))
- PA1 .I DIMOM="" D I DIOUT Q
- ..S DIMOM=$G(^DD(DITEMP,0,"UP"))
- ..I DIMOM="" S DIOUT=1 Q
- ..S DIRULE("UP",DITEMP)=DIMOM
- ..I '$D(DIRULE("L",DIMOM)) S DIRULE("L",DIMOM)=DIFILE("L")-DIBACK+1
- ..Q
- .S DIFILE(DIBACK)=DIMOM
- .Q
- Q
- ;
- LEVEL(DIFILE) ;
- ;IEN--return the file's level (# parents +1)
- ;function, pass by value
- N DIMOM
- I '$G(DIFILE) Q 0
- S DIMOM=$G(^DD(DIFILE,0,"UP"))
- I DIMOM="" Q 1
- Q $$LEVEL(DIMOM)+1
- ;
- DIDU1 ;SEA/TOAD-VA FileMan: DD Tools, IENS Check ;10:39 AM 8 Jul 1998
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- IEN(DIENS,DIFLAGS) ;
- +1 ;ENTRY POINT--return whether the IEN String is valid
- +2 ;extrinsic function, all passed by value
- +3 IF $GET(DIENS)=""
- QUIT 0
- +4 IF $GET(DIFLAGS,"N")'="N"
- QUIT 0
- +5 SET DIFLAGS=$GET(DIFLAGS)
- +6 NEW DICHAR,DICRSR,DIPIECE,DISEQ,DIOUT,DIVALID
- +7 SET DIPIECE=""
- SET DISEQ=""
- SET DIOUT=0
- SET DIVALID=1
- +8 FOR DICRSR=1:1
- Begin DoDot:1
- +9 SET DIPIECE=$PIECE(DIENS,",",DICRSR)
- +10 IF DIPIECE=""
- Begin DoDot:2
- +11 IF $PIECE(DIENS,",",DICRSR,999)=""
- SET DIOUT=1
- QUIT
- I1 IF DICRSR=1
- QUIT
- +1 SET DIOUT=1
- SET DIVALID=0
- +2 QUIT
- End DoDot:2
- QUIT
- +3 IF +DIPIECE=DIPIECE
- SET DIVALID=DIPIECE>0
- SET DIOUT='DIVALID
- QUIT
- +4 IF DIFLAGS["N"
- SET DIVALID=0
- SET DIOUT=1
- QUIT
- +5 SET DICHAR=$EXTRACT(DIPIECE,1,2)
- IF DICHAR'="?+"
- SET DICHAR=$EXTRACT(DICHAR)
- +6 IF DICHAR'="+"
- IF DICHAR'="?"
- IF DICHAR'="?+"
- SET DIOUT=1
- SET DIVALID=0
- QUIT
- +7 IF $PIECE(DIPIECE,DICHAR,2,9999)?1N.N
- Begin DoDot:2
- +8 SET DISEQ=$PIECE(DIPIECE,DICHAR,2,999)
- +9 SET DIOUT=+DISEQ'=DISEQ!$DATA(DISEQ(DISEQ))
- SET DIVALID='DIOUT
- QUIT
- End DoDot:2
- QUIT
- I2 SET DIOUT=1
- SET DIVALID=0
- +1 QUIT
- End DoDot:1
- IF DIOUT
- QUIT
- +2 QUIT $EXTRACT(DIENS,$LENGTH(DIENS))=","&DIVALID
- +3 ;
- PROOT(DIFILE,DIENS) ;
- +1 ;ENTRY POINT--return the global root of a subfile's parent
- +2 ;extrinsic function, all passed by value
- +3 QUIT $$ROOT^DILFD($$PARENT(DIFILE),$PIECE(DIENS,",",2,999),1)
- +4 ;
- PARENT(DIFILE) ;
- +1 ;ENTRY POINT--return the file number of a subfile's parent
- +2 ;extrinsic function, all passed by value
- +3 QUIT $GET(^DD(DIFILE,0,"UP"))
- +4 ;
- PARENTS(DIFILE,DIRULE) ;
- +1 ;IEN--return the file's parents
- +2 ;procedure, passed by ref
- +3 NEW DIBACK,DIOUT,DIMOM,DITEMP
- +4 SET DIOUT=0
- SET DIMOM=DIFILE
- +5 SET DITEMP=DIFILE
- KILL DIFILE
- SET (DIFILE,DIFILE("C"))=DITEMP
- +6 SET DIFILE("L")=$$LEVEL(DIFILE)
- +7 SET DIFILE(1)=DIFILE
- +8 IF '$DATA(DIRULE("L",DIFILE))
- SET DIRULE("L",DIFILE)=DIFILE("L")
- +9 FOR DIBACK=2:1
- Begin DoDot:1
- +10 SET DITEMP=DIMOM
- +11 SET DIMOM=$GET(DIRULE("UP",DITEMP))
- PA1 IF DIMOM=""
- Begin DoDot:2
- +1 SET DIMOM=$GET(^DD(DITEMP,0,"UP"))
- +2 IF DIMOM=""
- SET DIOUT=1
- QUIT
- +3 SET DIRULE("UP",DITEMP)=DIMOM
- +4 IF '$DATA(DIRULE("L",DIMOM))
- SET DIRULE("L",DIMOM)=DIFILE("L")-DIBACK+1
- +5 QUIT
- End DoDot:2
- IF DIOUT
- QUIT
- +6 SET DIFILE(DIBACK)=DIMOM
- +7 QUIT
- End DoDot:1
- IF DIOUT
- QUIT
- +8 QUIT
- +9 ;
- LEVEL(DIFILE) ;
- +1 ;IEN--return the file's level (# parents +1)
- +2 ;function, pass by value
- +3 NEW DIMOM
- +4 IF '$GET(DIFILE)
- QUIT 0
- +5 SET DIMOM=$GET(^DD(DIFILE,0,"UP"))
- +6 IF DIMOM=""
- QUIT 1
- +7 QUIT $$LEVEL(DIMOM)+1
- +8 ;
