DIDU1 ;SEA/TOAD-VA FileMan: DD Tools, IENS Check ;10:39 AM 8 Jul 1998
;;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.
;
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDU1 2446 printed Nov 22, 2024@17:56:51 Page 2
DIDU1 ;SEA/TOAD-VA FileMan: DD Tools, IENS Check ;10:39 AM 8 Jul 1998
+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 ;
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 ;
