DICA ;SEA/TOAD-VA FileMan, Updater, Engine ;18APR2009
;;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.
;
ADD(DIFLAGS,DIFDA,DIEN,DIMSGA) ;
;
ADDX ; Branch in from UPDATE^DIE
; ENTRY POINT--add a new entry to a file
; subroutine, DIEN passed by reference
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
N DICLERR S DICLERR=$G(DIERR) K DIERR
INPUT ;
; initialize input parameters & check
N DIRULE S DIRULE=$$GETTMP^DIKC1("DICA")
N DIFDAO
S DIFLAGS=$G(DIFLAGS)
I $TR(DIFLAGS,"EKSUY")'="" D Q
. D ERR^DICA3(301,"","","",DIFLAGS),CLOSE
S DIFDA=$G(DIFDA) I $D(@DIFDA)<10 D Q
. D ERR^DICA3(202,"","","","FDA"),CLOSE
S DIFDAO=DIFDA
S DIEN=$G(DIEN) I DIEN="" S DIEN="DIDUMMY" N DIDUMMY
PRE ;
N DIOK S DIOK=1 D CHECK^DICA1(DIFLAGS,.DIFDA,DIEN,DIRULE,.DIOK)
I $G(DIERR) D CLOSE Q
I 'DIOK D ERR^DICA3(202,"","","","FDA"),CLOSE Q
SEQ ;
N DICHECK,DIENTRY,DIFILE,DIOUT1,DINEXT
S (DIOUT1,DINEXT)="" F D Q:DIOUT1
. S DINEXT=$O(@DIRULE@("NEXT",DINEXT)) I DINEXT="" S DIOUT1=1 Q
. X @DIRULE@("NEXT",DINEXT)
FILES . ;
. I $P($G(^DD($$FNO^DILIBF(DIFILE),0,"DI")),U,2)["Y" D Q:DIOUT1 ;Entries in file cannot be edited.
. . S DIOUT1=DIFLAGS'["Y"&'$D(DIOVRD)
. . I DIOUT1 D ERR^DICA3(405,DIFILE,"","",DIFILE)
ENTRIES . ;
. N DIDA,DIENP,DIOP,DIROOT,DISEQ
. S DIDA=$P(DIENTRY,",") I +DIDA=DIDA Q
. S DIENP=$$IEN(DIENTRY,"",DIRULE)
. S DIOP=$E(DIDA,1,2) I DIOP'="?+" S DIOP=$E(DIOP)
. S DISEQ=$P(DIDA,DIOP,2)
FINDING . ;
. ; Finding (?) or LAYGO/FInding (?+) nodes
. I DIOP["?" D Q
. . I DIOP="?+",DIENP[",," S @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT) Q
. . N DIFIND,DIFORMAT,DIGET,DIINDEX,DIVALUE
. . S DIFORMAT="B"_$S(DIFLAGS["E":"",1:"Q")_$S(DIOP="?+":"X",1:"")
. . S DIGET=DIFDA
. . I DIFLAGS["E",DIOP["?" S DIGET=DIFDAO
. . I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE))#2 D
. . . D GETKVALS(.DIVALUE,.DIINDEX)
. . E S DIVALUE=$G(@DIGET@(DIFILE,DIENTRY,.01))
. . S DIFIND=$$FIND1^DIC(DIFILE,DIENP,DIFORMAT,.DIVALUE,$G(DIINDEX))
. . I $G(DIERR) S DIOUT1=1 Q
. . I DIOP="?+",'DIFIND S @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT) Q
. . I 'DIFIND S DIOUT1=1 D Q
. . . I $D(DIVALUE)=10 N I,Q S DIVALUE="",(I,Q)=0 F S I=$O(DIVALUE(I)) Q:'I D Q:Q
. . . . Q:DIVALUE(I)=""
. . . . S:DIVALUE]"" DIVALUE=DIVALUE_";"
. . . . I $L(DIVALUE)+$L(DIVALUE(I))>252 D
. . . . . S DIVALUE=$E(DIVALUE,1,252)_$E(DIVALUE(I),1,252-$L(DIVALUE))_"..."
. . . . . S Q=1
. . . . E S DIVALUE=$G(DIVALUE)_$E(DIVALUE(I),1,251)
. . . D ERR^DICA3(703,DIFILE,DIENTRY,"",DIVALUE)
. . S @DIEN@(DISEQ)=DIFIND
. . I DIOP="?+" S @DIEN@(DISEQ,0)="?"
. . S @DIRULE@("IEN",DISEQ)=DIFIND
. . I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE)) D SAVEK Q
. . D SAVE
. ; Adding (+) nodes
. I '$G(DICHECK) S DICHECK=1 D ADDLF S:DIENP[",," DIENP=$$IEN(DIENTRY,"",DIRULE) I $G(DIERR) S DIOUT1=1 Q
. D ADDING
;
FILER ; file the data for the new records
I '$G(DIERR),$D(@DIFDA) D
. I '$G(DICHECK) D ADDLF Q:$G(DIERR)!'$D(@DIFDA) ;QUITS HERE WHEN KEY IS BAD!
.K ^TMP("DIKK",$J,"L") D FILE^DIEF($E("S",DIFLAGS["S")_"U",DIFDA,"",DIEN) ;GFT Artf8720:recursive UPDATE^DIE call would look at KEY
I '$G(DIERR),DIFLAGS'["S" K @DIFDAO
I $G(DIERR)!(DIFLAGS["S"),DIFLAGS'["E" D
. M @DIFDA=@DIRULE@("SAVE")
D CLOSE
Q
;
ADDING ;
N DIENEW,DIKEY
I $L(DIENP,",")>2 S DIOK=$$VMINUS9^DIEFU(DIFILE,DIENP) I 'DIOK D Q
. S DIOUT1=1
. D ERR^DICA3(602,DIFILE,$P(DIENP,",",$L(DIENP,",")-1))
S DIROOT=$$ROOT^DIQGU(DIFILE,DIENP)
D DA^DILF(DIENTRY,.DIENEW)
A1 S DIENEW=$$IEN(DIENTRY,$G(@DIEN@(DISEQ)),DIRULE)
S DIKEY=$G(@DIFDA@(DIFILE,DIENTRY,.01)) I DIKEY="" D Q
. S DIOUT1=1 D ERR^DICA3(202,"","","","FDA")
S DIOK=$$LAYGO(DIFILE,.DIENEW,DIKEY)
I 'DIOK S DIOUT1=1 D Q
. I '$G(DIERR) D ERR^DICA3(405,DIFILE,"","",DIFILE) Q
. N DIENS S DIENS="New entry"
. I $L(DIENEW,",")>2 S DIENS=DIENS_" under record: "_DIENEW
. N DI1 S DI1="LAYGO Node on the new value '"_DIKEY_"'"
. D ERR^DICA3(120,DIFILE,DIENS,.01,DI1)
D CREATE^DICA3(DIFILE,.DIENEW,DIROOT,DIKEY) ;THIS SHOULD SET DIERR
S DIENEW=+DIENEW
I 'DIENEW S DIOUT1=1 Q
L -@(DIROOT_"DIENEW)")
S @DIEN@(DISEQ)=DIENEW ;SET RETURN VALUE
I DIOP="?+" S @DIEN@(DISEQ,0)="+" ;SET ZERO NODE IN IEN ARRAY
S @DIRULE@("IEN",DISEQ)=DIENEW
D SAVE
Q
;
LAYGO(DIFILE,DIEN,DIKEY) ;
; ADDING--return if LAYGO permitted
; function, all by value
N DA,DIOK,DINODE,DIOUTS,X,Y,Y1
S DIOK=1,DINODE="",DIOUTS=0 F D I DIOUTS!'DIOK Q
. S DINODE=$O(^DD(DIFILE,.01,"LAYGO",DINODE))
. I DINODE'>0 S DIOUTS=1 Q
. I $D(^DD(DIFILE,.01,"LAYGO",DINODE,0))[0 Q
. S X=DIKEY M DA=DIEN S Y=$P(DA,","),Y1=DA,DA=$P(DA,",")
. I 1 X ^DD(DIFILE,.01,"LAYGO",DINODE,0) S DIOK=$T&'$G(DIERR)
Q DIOK
;
SAVE I DIFLAGS'["E" D
. S @DIRULE@("SAVE",DIFILE,DIENTRY,.01)=@DIFDA@(DIFILE,DIENTRY,.01)
K @DIFDA@(DIFILE,DIENTRY,.01)
Q
;
SAVEK ; Remove primary key field from FDA; save in ^TMP first if necessary
N DIFLD
S DIFLD=0
F S DIFLD=$O(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)) Q:'DIFLD D
. Q:'^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)
. Q:$D(@DIGET@(DIFILE,DIENTRY,DIFLD))[0
. S:DIFLAGS'["E" @DIRULE@("SAVE",DIFILE,DIENTRY,DIFLD)=@DIFDA@(DIFILE,DIENTRY,DIFLD)
. K @DIFDA@(DIFILE,DIENTRY,DIFLD)
Q
;
IEN(DIENTRY,DIENF,DIRULE) ;
; ADDING/FINDING--return translated IEN String
; function, DIENTRY passed by value
N DIC,DIENEW,DIOP,DIP,DIPNEW,DISEQ
S DIENEW=""
S DIENF=$G(DIENF)
S DIP="" F DIC=1:1 D I DIP="" Q
. S DIP=$P(DIENTRY,",",DIC) I DIP="" Q
. D
. . I +DIP=DIP S DIPNEW=DIP Q
IEN1 . . I DIC=1 S DIPNEW=DIENF Q
. . S DIOP=$E(DIP,1,2) I DIOP'="?+" S DIOP=$E(DIOP)
. . S DISEQ=$P(DIP,DIOP,2,9999)
. . S DIPNEW=$G(@DIRULE@("IEN",DISEQ))
. S $P(DIENEW,",",DIC)=DIPNEW
I DIENEW'="" S DIENEW=DIENEW_","
Q DIENEW
;
CLOSE I DICLERR'=""!$G(DIERR) D
. S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
K @DIRULE,^TMP("DIKK",$J)
Q
;
GETKVALS(DIVALUE,DIINDEX) ; Get primary key values and uniq index
N DIFLD,DIKEY,DISQ
K DIVALUE
S DIKEY=$P(^TMP("DIKK",$J,"P",DIFILE),U),DIINDEX=$P(^(DIFILE),U,4)
Q:DIINDEX=""!'DIKEY
;
S DIFLD=0
F S DIFLD=$O(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)) Q:'DIFLD D
. S DISQ=^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD) Q:'DISQ
. Q:$D(@DIGET@(DIFILE,DIENTRY,DIFLD))[0
. S DIVALUE(DISQ)=@DIGET@(DIFILE,DIENTRY,DIFLD)
Q
;
ADDLF ; Check key integrity
I $D(^TMP("DIKK",$J,"L")),'$$CHECK^DIEVK(DIFDA,DIFLAGS,DIEN) Q
;
; Add records for LAYGO/Finding nodes which were not found
N DINEXT
S (DINEXT,DIOUT1)=""
F S DINEXT=$O(@DIRULE@("NEXTADD",DINEXT)) Q:DINEXT="" D Q:DIOUT1
. N DIENP,DIFILE,DIENTRY,DIOP,DIROOT,DISEQ
. X @DIRULE@("NEXTADD",DINEXT)
. S DIENP=$$IEN(DIENTRY,"",DIRULE)
. S DIOP="?+"
. S DISEQ=$P($P(DIENTRY,","),DIOP,2)
. D ADDING
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICA 7173 printed Apr 09, 2024@21:53:20 Page 2
DICA ;SEA/TOAD-VA FileMan, Updater, Engine ;18APR2009
+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 ;
ADD(DIFLAGS,DIFDA,DIEN,DIMSGA) ;
+1 ;
ADDX ; Branch in from UPDATE^DIE
+1 ; ENTRY POINT--add a new entry to a file
+2 ; subroutine, DIEN 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 DICLERR
SET DICLERR=$GET(DIERR)
KILL DIERR
INPUT ;
+1 ; initialize input parameters & check
+2 NEW DIRULE
SET DIRULE=$$GETTMP^DIKC1("DICA")
+3 NEW DIFDAO
+4 SET DIFLAGS=$GET(DIFLAGS)
+5 IF $TRANSLATE(DIFLAGS,"EKSUY")'=""
Begin DoDot:1
+6 DO ERR^DICA3(301,"","","",DIFLAGS)
DO CLOSE
End DoDot:1
QUIT
+7 SET DIFDA=$GET(DIFDA)
IF $DATA(@DIFDA)<10
Begin DoDot:1
+8 DO ERR^DICA3(202,"","","","FDA")
DO CLOSE
End DoDot:1
QUIT
+9 SET DIFDAO=DIFDA
+10 SET DIEN=$GET(DIEN)
IF DIEN=""
SET DIEN="DIDUMMY"
NEW DIDUMMY
PRE ;
+1 NEW DIOK
SET DIOK=1
DO CHECK^DICA1(DIFLAGS,.DIFDA,DIEN,DIRULE,.DIOK)
+2 IF $GET(DIERR)
DO CLOSE
QUIT
+3 IF 'DIOK
DO ERR^DICA3(202,"","","","FDA")
DO CLOSE
QUIT
SEQ ;
+1 NEW DICHECK,DIENTRY,DIFILE,DIOUT1,DINEXT
+2 SET (DIOUT1,DINEXT)=""
FOR
Begin DoDot:1
+3 SET DINEXT=$ORDER(@DIRULE@("NEXT",DINEXT))
IF DINEXT=""
SET DIOUT1=1
QUIT
+4 XECUTE @DIRULE@("NEXT",DINEXT)
FILES ;
+1 ;Entries in file cannot be edited.
IF $PIECE($GET(^DD($$FNO^DILIBF(DIFILE),0,"DI")),U,2)["Y"
Begin DoDot:2
+2 SET DIOUT1=DIFLAGS'["Y"&'$DATA(DIOVRD)
+3 IF DIOUT1
DO ERR^DICA3(405,DIFILE,"","",DIFILE)
End DoDot:2
if DIOUT1
QUIT
ENTRIES ;
+1 NEW DIDA,DIENP,DIOP,DIROOT,DISEQ
+2 SET DIDA=$PIECE(DIENTRY,",")
IF +DIDA=DIDA
QUIT
+3 SET DIENP=$$IEN(DIENTRY,"",DIRULE)
+4 SET DIOP=$EXTRACT(DIDA,1,2)
IF DIOP'="?+"
SET DIOP=$EXTRACT(DIOP)
+5 SET DISEQ=$PIECE(DIDA,DIOP,2)
FINDING ;
+1 ; Finding (?) or LAYGO/FInding (?+) nodes
+2 IF DIOP["?"
Begin DoDot:2
+3 IF DIOP="?+"
IF DIENP[",,"
SET @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT)
QUIT
+4 NEW DIFIND,DIFORMAT,DIGET,DIINDEX,DIVALUE
+5 SET DIFORMAT="B"_$SELECT(DIFLAGS["E":"",1:"Q")_$SELECT(DIOP="?+":"X",1:"")
+6 SET DIGET=DIFDA
+7 IF DIFLAGS["E"
IF DIOP["?"
SET DIGET=DIFDAO
+8 IF DIFLAGS["K"
IF $DATA(^TMP("DIKK",$JOB,"P",DIFILE))#2
Begin DoDot:3
+9 DO GETKVALS(.DIVALUE,.DIINDEX)
End DoDot:3
+10 IF '$TEST
SET DIVALUE=$GET(@DIGET@(DIFILE,DIENTRY,.01))
+11 SET DIFIND=$$FIND1^DIC(DIFILE,DIENP,DIFORMAT,.DIVALUE,$GET(DIINDEX))
+12 IF $GET(DIERR)
SET DIOUT1=1
QUIT
+13 IF DIOP="?+"
IF 'DIFIND
SET @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT)
QUIT
+14 IF 'DIFIND
SET DIOUT1=1
Begin DoDot:3
+15 IF $DATA(DIVALUE)=10
NEW I,Q
SET DIVALUE=""
SET (I,Q)=0
FOR
SET I=$ORDER(DIVALUE(I))
if 'I
QUIT
Begin DoDot:4
+16 if DIVALUE(I)=""
QUIT
+17 if DIVALUE]""
SET DIVALUE=DIVALUE_";"
+18 IF $LENGTH(DIVALUE)+$LENGTH(DIVALUE(I))>252
Begin DoDot:5
+19 SET DIVALUE=$EXTRACT(DIVALUE,1,252)_$EXTRACT(DIVALUE(I),1,252-$LENGTH(DIVALUE))_"..."
+20 SET Q=1
End DoDot:5
+21 IF '$TEST
SET DIVALUE=$GET(DIVALUE)_$EXTRACT(DIVALUE(I),1,251)
End DoDot:4
if Q
QUIT
+22 DO ERR^DICA3(703,DIFILE,DIENTRY,"",DIVALUE)
End DoDot:3
QUIT
+23 SET @DIEN@(DISEQ)=DIFIND
+24 IF DIOP="?+"
SET @DIEN@(DISEQ,0)="?"
+25 SET @DIRULE@("IEN",DISEQ)=DIFIND
+26 IF DIFLAGS["K"
IF $DATA(^TMP("DIKK",$JOB,"P",DIFILE))
DO SAVEK
QUIT
+27 DO SAVE
End DoDot:2
QUIT
+28 ; Adding (+) nodes
+29 IF '$GET(DICHECK)
SET DICHECK=1
DO ADDLF
if DIENP[",,"
SET DIENP=$$IEN(DIENTRY,"",DIRULE)
IF $GET(DIERR)
SET DIOUT1=1
QUIT
+30 DO ADDING
End DoDot:1
if DIOUT1
QUIT
+31 ;
FILER ; file the data for the new records
+1 IF '$GET(DIERR)
IF $DATA(@DIFDA)
Begin DoDot:1
+2 ;QUITS HERE WHEN KEY IS BAD!
IF '$GET(DICHECK)
DO ADDLF
if $GET(DIERR)!'$DATA(@DIFDA)
QUIT
+3 ;GFT Artf8720:recursive UPDATE^DIE call would look at KEY
KILL ^TMP("DIKK",$JOB,"L")
DO FILE^DIEF($EXTRACT("S",DIFLAGS["S")_"U",DIFDA,"",DIEN)
End DoDot:1
+4 IF '$GET(DIERR)
IF DIFLAGS'["S"
KILL @DIFDAO
+5 IF $GET(DIERR)!(DIFLAGS["S")
IF DIFLAGS'["E"
Begin DoDot:1
+6 MERGE @DIFDA=@DIRULE@("SAVE")
End DoDot:1
+7 DO CLOSE
+8 QUIT
+9 ;
ADDING ;
+1 NEW DIENEW,DIKEY
+2 IF $LENGTH(DIENP,",")>2
SET DIOK=$$VMINUS9^DIEFU(DIFILE,DIENP)
IF 'DIOK
Begin DoDot:1
+3 SET DIOUT1=1
+4 DO ERR^DICA3(602,DIFILE,$PIECE(DIENP,",",$LENGTH(DIENP,",")-1))
End DoDot:1
QUIT
+5 SET DIROOT=$$ROOT^DIQGU(DIFILE,DIENP)
+6 DO DA^DILF(DIENTRY,.DIENEW)
A1 SET DIENEW=$$IEN(DIENTRY,$GET(@DIEN@(DISEQ)),DIRULE)
+1 SET DIKEY=$GET(@DIFDA@(DIFILE,DIENTRY,.01))
IF DIKEY=""
Begin DoDot:1
+2 SET DIOUT1=1
DO ERR^DICA3(202,"","","","FDA")
End DoDot:1
QUIT
+3 SET DIOK=$$LAYGO(DIFILE,.DIENEW,DIKEY)
+4 IF 'DIOK
SET DIOUT1=1
Begin DoDot:1
+5 IF '$GET(DIERR)
DO ERR^DICA3(405,DIFILE,"","",DIFILE)
QUIT
+6 NEW DIENS
SET DIENS="New entry"
+7 IF $LENGTH(DIENEW,",")>2
SET DIENS=DIENS_" under record: "_DIENEW
+8 NEW DI1
SET DI1="LAYGO Node on the new value '"_DIKEY_"'"
+9 DO ERR^DICA3(120,DIFILE,DIENS,.01,DI1)
End DoDot:1
QUIT
+10 ;THIS SHOULD SET DIERR
DO CREATE^DICA3(DIFILE,.DIENEW,DIROOT,DIKEY)
+11 SET DIENEW=+DIENEW
+12 IF 'DIENEW
SET DIOUT1=1
QUIT
+13 LOCK -@(DIROOT_"DIENEW)")
+14 ;SET RETURN VALUE
SET @DIEN@(DISEQ)=DIENEW
+15 ;SET ZERO NODE IN IEN ARRAY
IF DIOP="?+"
SET @DIEN@(DISEQ,0)="+"
+16 SET @DIRULE@("IEN",DISEQ)=DIENEW
+17 DO SAVE
+18 QUIT
+19 ;
LAYGO(DIFILE,DIEN,DIKEY) ;
+1 ; ADDING--return if LAYGO permitted
+2 ; function, all by value
+3 NEW DA,DIOK,DINODE,DIOUTS,X,Y,Y1
+4 SET DIOK=1
SET DINODE=""
SET DIOUTS=0
FOR
Begin DoDot:1
+5 SET DINODE=$ORDER(^DD(DIFILE,.01,"LAYGO",DINODE))
+6 IF DINODE'>0
SET DIOUTS=1
QUIT
+7 IF $DATA(^DD(DIFILE,.01,"LAYGO",DINODE,0))[0
QUIT
+8 SET X=DIKEY
MERGE DA=DIEN
SET Y=$PIECE(DA,",")
SET Y1=DA
SET DA=$PIECE(DA,",")
+9 IF 1
XECUTE ^DD(DIFILE,.01,"LAYGO",DINODE,0)
SET DIOK=$TEST&'$GET(DIERR)
End DoDot:1
IF DIOUTS!'DIOK
QUIT
+10 QUIT DIOK
+11 ;
SAVE IF DIFLAGS'["E"
Begin DoDot:1
+1 SET @DIRULE@("SAVE",DIFILE,DIENTRY,.01)=@DIFDA@(DIFILE,DIENTRY,.01)
End DoDot:1
+2 KILL @DIFDA@(DIFILE,DIENTRY,.01)
+3 QUIT
+4 ;
SAVEK ; Remove primary key field from FDA; save in ^TMP first if necessary
+1 NEW DIFLD
+2 SET DIFLD=0
+3 FOR
SET DIFLD=$ORDER(^TMP("DIKK",$JOB,"P",DIFILE,DIFILE,DIFLD))
if 'DIFLD
QUIT
Begin DoDot:1
+4 if '^TMP("DIKK",$JOB,"P",DIFILE,DIFILE,DIFLD)
QUIT
+5 if $DATA(@DIGET@(DIFILE,DIENTRY,DIFLD))[0
QUIT
+6 if DIFLAGS'["E"
SET @DIRULE@("SAVE",DIFILE,DIENTRY,DIFLD)=@DIFDA@(DIFILE,DIENTRY,DIFLD)
+7 KILL @DIFDA@(DIFILE,DIENTRY,DIFLD)
End DoDot:1
+8 QUIT
+9 ;
IEN(DIENTRY,DIENF,DIRULE) ;
+1 ; ADDING/FINDING--return translated IEN String
+2 ; function, DIENTRY passed by value
+3 NEW DIC,DIENEW,DIOP,DIP,DIPNEW,DISEQ
+4 SET DIENEW=""
+5 SET DIENF=$GET(DIENF)
+6 SET DIP=""
FOR DIC=1:1
Begin DoDot:1
+7 SET DIP=$PIECE(DIENTRY,",",DIC)
IF DIP=""
QUIT
+8 Begin DoDot:2
+9 IF +DIP=DIP
SET DIPNEW=DIP
QUIT
IEN1 IF DIC=1
SET DIPNEW=DIENF
QUIT
+1 SET DIOP=$EXTRACT(DIP,1,2)
IF DIOP'="?+"
SET DIOP=$EXTRACT(DIOP)
+2 SET DISEQ=$PIECE(DIP,DIOP,2,9999)
+3 SET DIPNEW=$GET(@DIRULE@("IEN",DISEQ))
End DoDot:2
+4 SET $PIECE(DIENEW,",",DIC)=DIPNEW
End DoDot:1
IF DIP=""
QUIT
+5 IF DIENEW'=""
SET DIENEW=DIENEW_","
+6 QUIT DIENEW
+7 ;
CLOSE IF DICLERR'=""!$GET(DIERR)
Begin DoDot:1
+1 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
End DoDot:1
+2 IF $GET(DIMSGA)'=""
DO CALLOUT^DIEFU(DIMSGA)
+3 KILL @DIRULE,^TMP("DIKK",$JOB)
+4 QUIT
+5 ;
GETKVALS(DIVALUE,DIINDEX) ; Get primary key values and uniq index
+1 NEW DIFLD,DIKEY,DISQ
+2 KILL DIVALUE
+3 SET DIKEY=$PIECE(^TMP("DIKK",$JOB,"P",DIFILE),U)
SET DIINDEX=$PIECE(^(DIFILE),U,4)
+4 if DIINDEX=""!'DIKEY
QUIT
+5 ;
+6 SET DIFLD=0
+7 FOR
SET DIFLD=$ORDER(^TMP("DIKK",$JOB,"P",DIFILE,DIFILE,DIFLD))
if 'DIFLD
QUIT
Begin DoDot:1
+8 SET DISQ=^TMP("DIKK",$JOB,"P",DIFILE,DIFILE,DIFLD)
if 'DISQ
QUIT
+9 if $DATA(@DIGET@(DIFILE,DIENTRY,DIFLD))[0
QUIT
+10 SET DIVALUE(DISQ)=@DIGET@(DIFILE,DIENTRY,DIFLD)
End DoDot:1
+11 QUIT
+12 ;
ADDLF ; Check key integrity
+1 IF $DATA(^TMP("DIKK",$JOB,"L"))
IF '$$CHECK^DIEVK(DIFDA,DIFLAGS,DIEN)
QUIT
+2 ;
+3 ; Add records for LAYGO/Finding nodes which were not found
+4 NEW DINEXT
+5 SET (DINEXT,DIOUT1)=""
+6 FOR
SET DINEXT=$ORDER(@DIRULE@("NEXTADD",DINEXT))
if DINEXT=""
QUIT
Begin DoDot:1
+7 NEW DIENP,DIFILE,DIENTRY,DIOP,DIROOT,DISEQ
+8 XECUTE @DIRULE@("NEXTADD",DINEXT)
+9 SET DIENP=$$IEN(DIENTRY,"",DIRULE)
+10 SET DIOP="?+"
+11 SET DISEQ=$PIECE($PIECE(DIENTRY,","),DIOP,2)
+12 DO ADDING
End DoDot:1
if DIOUT1
QUIT
+13 QUIT
