DICA3 ;SEA/TOAD-VA FileMan: Updater, Adder ;16FEB2011
;;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.
;
CREATE(DIFILE,DIEN,DIROOT,DIVALUE) ;If DIEN comes in with a leading number, use it as IEN
N DIENP S DIENP=","_$P(DIEN,",",2,999)
S DIEN=$P(DIEN,",")
N DINEXT S DINEXT=$P($G(@(DIROOT_"0)")),U,3)
I DINEXT="" D I $G(DIERR) S DIEN="" Q
. N DIHEADER S DIHEADER=$$HEADER^DIDU2(.DIFILE,DIENP)
. I '$G(DIERR) S @(DIROOT_"0)")=DIHEADER
GETNUM ;
N DINUM,DIFAUD S DINUM=DIEN'="",DIFAUD=0 I 'DINUM S DIEN=DINEXT\1 I $D(^DIA(DIFILE,"B")) S DIFAUD=DIFILE
N DIFAIL,DIOUT S DIFAIL=0,DIOUT=0 F D I DIOUT!DIFAIL Q
. I 'DINUM S DIEN=DIEN+1 I $D(@(DIROOT_"DIEN)")) Q ;**GFT LOOK BEFORE LOCKING
. I DIFAUD,+$O(^DIA(DIFAUD,"B",DIEN_","))=DIEN!$D(^(DIEN)) Q ;**GFT DON'T PICK AN ALREADY-AUDITED NUMBER
. I DIEN'>0 D ERR(202,DIFILE,DIEN,.01,"ASSIGNED IEN") S DIFAIL=1 Q ;ARTF10963 -- "The input parameter that identifies the ASSIGNED IEN is missing or invalid."
. D LOCK^DILF(DIROOT_"DIEN)") ;**147
. I '$T S DIFAIL=DINUM Q:'DIFAIL D ERR(110,DIFILE,DIEN_DIENP) Q ;RECORD IS LOCKED
ZERO . I $D(@(DIROOT_"DIEN,0)")) L -@(DIROOT_"DIEN)") D Q
. . S DIFAIL=DINUM I 'DIFAIL Q ;COULDN'T DO DINUM!
. . D ERR(302,DIFILE,DIEN_DIENP) ;ENTRY ALREADY EXISTS
. S DIOUT=1
I DIFAIL S DIEN="" Q
SETREC ;
N DICAFILE M DICAFILE=DIFILE N DIFILE
S @(DIROOT_"DIEN,0)")=DIVALUE
D LOCK^DILF(DIROOT_"0)") ;**147
S $P(^(0),U,3,4)=DIEN_U_($P(@(DIROOT_"0)"),U,4)+1)
I L -@(DIROOT_"0)")
S DIEN=DIEN_DIENP
D XA^DIEFU(DICAFILE,DIEN,.01,DIVALUE,"")
D INDEX^DIKC(DICAFILE,DIEN,.01,"","SC")
Q
;
PROOT(DIFILE,DIEN) ;
; ENTRY POINT--return the global root of a subfile's parent
; extrinsic function, all passed by value
N DIENP S DIENP=$P(DIEN,",",2,999)
Q $NA(@$$ROOT^DILFD($$PARENT(DIFILE),DIENP,1)@(+DIENP))
;
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"))
;
SUBFILE(DIFILE) ;
; ENTRY POINT--return whether the file is a subfile
; extrinsic function, passed by value
Q $D(^DD(DIFILE,0,"UP"))#2
;
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
; error logging procedure
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[HDICA3 2590 printed Apr 09, 2024@21:51:46 Page 2
DICA3 ;SEA/TOAD-VA FileMan: Updater, Adder ;16FEB2011
+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 ;
CREATE(DIFILE,DIEN,DIROOT,DIVALUE) ;If DIEN comes in with a leading number, use it as IEN
+1 NEW DIENP
SET DIENP=","_$PIECE(DIEN,",",2,999)
+2 SET DIEN=$PIECE(DIEN,",")
+3 NEW DINEXT
SET DINEXT=$PIECE($GET(@(DIROOT_"0)")),U,3)
+4 IF DINEXT=""
Begin DoDot:1
+5 NEW DIHEADER
SET DIHEADER=$$HEADER^DIDU2(.DIFILE,DIENP)
+6 IF '$GET(DIERR)
SET @(DIROOT_"0)")=DIHEADER
End DoDot:1
IF $GET(DIERR)
SET DIEN=""
QUIT
GETNUM ;
+1 NEW DINUM,DIFAUD
SET DINUM=DIEN'=""
SET DIFAUD=0
IF 'DINUM
SET DIEN=DINEXT\1
IF $DATA(^DIA(DIFILE,"B"))
SET DIFAUD=DIFILE
+2 NEW DIFAIL,DIOUT
SET DIFAIL=0
SET DIOUT=0
FOR
Begin DoDot:1
+3 ;**GFT LOOK BEFORE LOCKING
IF 'DINUM
SET DIEN=DIEN+1
IF $DATA(@(DIROOT_"DIEN)"))
QUIT
+4 ;**GFT DON'T PICK AN ALREADY-AUDITED NUMBER
IF DIFAUD
IF +$ORDER(^DIA(DIFAUD,"B",DIEN_","))=DIEN!$DATA(^(DIEN))
QUIT
+5 ;ARTF10963 -- "The input parameter that identifies the ASSIGNED IEN is missing or invalid."
IF DIEN'>0
DO ERR(202,DIFILE,DIEN,.01,"ASSIGNED IEN")
SET DIFAIL=1
QUIT
+6 ;**147
DO LOCK^DILF(DIROOT_"DIEN)")
+7 ;RECORD IS LOCKED
IF '$TEST
SET DIFAIL=DINUM
if 'DIFAIL
QUIT
DO ERR(110,DIFILE,DIEN_DIENP)
QUIT
ZERO IF $DATA(@(DIROOT_"DIEN,0)"))
LOCK -@(DIROOT_"DIEN)")
Begin DoDot:2
+1 ;COULDN'T DO DINUM!
SET DIFAIL=DINUM
IF 'DIFAIL
QUIT
+2 ;ENTRY ALREADY EXISTS
DO ERR(302,DIFILE,DIEN_DIENP)
End DoDot:2
QUIT
+3 SET DIOUT=1
End DoDot:1
IF DIOUT!DIFAIL
QUIT
+4 IF DIFAIL
SET DIEN=""
QUIT
SETREC ;
+1 NEW DICAFILE
MERGE DICAFILE=DIFILE
NEW DIFILE
+2 SET @(DIROOT_"DIEN,0)")=DIVALUE
+3 ;**147
DO LOCK^DILF(DIROOT_"0)")
+4 SET $PIECE(^(0),U,3,4)=DIEN_U_($PIECE(@(DIROOT_"0)"),U,4)+1)
+5 IF $TEST
LOCK -@(DIROOT_"0)")
+6 SET DIEN=DIEN_DIENP
+7 DO XA^DIEFU(DICAFILE,DIEN,.01,DIVALUE,"")
+8 DO INDEX^DIKC(DICAFILE,DIEN,.01,"","SC")
+9 QUIT
+10 ;
PROOT(DIFILE,DIEN) ;
+1 ; ENTRY POINT--return the global root of a subfile's parent
+2 ; extrinsic function, all passed by value
+3 NEW DIENP
SET DIENP=$PIECE(DIEN,",",2,999)
+4 QUIT $NAME(@$$ROOT^DILFD($$PARENT(DIFILE),DIENP,1)@(+DIENP))
+5 ;
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 ;
SUBFILE(DIFILE) ;
+1 ; ENTRY POINT--return whether the file is a subfile
+2 ; extrinsic function, passed by value
+3 QUIT $DATA(^DD(DIFILE,0,"UP"))#2
+4 ;
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
+1 ; error logging procedure
+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
