Routine: DICA3

DICA3 ;SEA/TOAD-VA FileMan: Updater, Adder ;17SEP2009

 ;;22.0;VA FileMan;**147,162**;Mar 30, 1999;Build 21

 ;Per VHA Directive 2004-038, this routine should not be modified.

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

 . D LOCK^DILF(DIROOT_"DIEN)") ;**147

 . I '$T S DIFAIL=DINUM Q:'DIFAIL  D ERR(110,DIFILE,DIEN_DIENP) Q

ZERO . I $D(@(DIROOT_"DIEN,0)")) L -@(DIROOT_"DIEN)") D  Q

 . . S DIFAIL=DINUM I 'DIFAIL Q

 . . D ERR(302,DIFILE,DIEN_DIENP)

 . 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")

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)

DICA3     ;SEA/TOAD-VA FileMan: Updater, Adder ;17SEP2009

 +1       ;;22.0;VA FileMan;**147,162**;Mar 30, 1999;Build 21

 +2       ;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

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       ;**147

                   DO LOCK^DILF(DIROOT_"DIEN)")

 +6                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                        SET DIFAIL=DINUM

                           IF 'DIFAIL

                               QUIT

 +2                        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

DICA3.m