DICN0 ;SFISC/GFT,XAK,SEA/TOAD/TKW-ADD NEW ENTRY ;22MAR2006
;;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.
;
NEW ; try to add a new record to the file
; called from FILE, ^DICN
;
N %,I,DDH,DI,DIE,DIK,DQ,DR,%H,%T,%DT,C,DIG,DIH,DIU,DIV,DISYS
K % M %=X N X M X=% S %=+$G(D0) N D0 S:% D0=% K %
I '$G(DIFILEI)!($G(DINDEX("#"))="") N DINDEX,DIFILEI,DIENS D
. S DINDEX("#")=1,(DINDEX,DINDEX("START"))="B"
. D GETFILE^DIC0(.DIC,.DIFILEI,.DIENS) Q
G:DIFILEI="" OUT
I '$D(@(DIC_"0)")),'$D(DIC("P")),$E(DIC,1,6)'="^DOPT(" S DIC("P")=$$GETP^DIC0(DIFILEI)
D:'$D(DO(2)) GETFA^DIC1(.DIC,.DO) I DO="0^-1" G OUT
S X=$G(X) I X="",DINDEX("#")>1 S X=$G(X(1))
I X="",(DIC(0)'["E"!(DINDEX("#")'>1)) G OUT
N DINO01 S DINO01=$S(X="":1,1:0) N DIX,DIY
;
N1 ; if LAYGO nodes are present, XECUTE them and verify they don't object
;
S Y=1 F DIX=0:0 D Q:DIX'>0 Q:'Y
. S DIX=$O(^DD(+DO(2),.01,"LAYGO",DIX)) Q:DIX'>0
. I $D(^DD(+DO(2),.01,"LAYGO",DIX,0)) X ^(0) S Y=$T
I 'Y G OUT
;
; if the file is in the middle of archiving, keep out
;
I $P($G(^DD($$FNO^DILIBF(+DO(2)),0,"DI")),U,2)["Y" D I Y G OUT
. S Y='$D(DIOVRD)&'$G(DIFROM)
;
N2 ; process DINUM
;
S DIX=X
I $D(DINUM) D
. S X=DINUM D I '$D(X) S Y=0,X=DIX Q
. . N DIX D N^DICN1 Q
. D LOCK(DIC,X,.Y)
;
; or process DIENTRY (numeric input that might be IEN LAYGO)
;
E I $D(DIENTRY) D
. S X=DIENTRY D I 'Y S X=DIX Q
. . N DIX D ASKP001^DICN1 Q
. D LOCK(DIC,X,.Y)
;
; or get a record number the usual way
;
E S X=$P(DO,U,3) D INCR N DIFAUD S %=+$P(DO,U,2),DIFAUD=$S($D(^DIA(%,"B")):%,1:0) F D Q:Y'="TRY NEXT"
. F S X=X\DIY*DIY+DIY Q:'$D(@(DIC_"X)"))&$S('DIFAUD:1,1:+$O(^DIA(DIFAUD,"B",X_","))-X&'$D(^(X)))
. I $G(DUZ(0))="@"!$P(DO,U,2) N DIX D ASKP001^DICN1 Q:'Y
. D LOCK(DIC,X,.Y) Q:Y S Y="TRY NEXT"
;
I 'Y S Y=-1 D BAD^DIC1 Q
;
N3 ; add the new record at the IEN selected
;
S @(DIC_"X,0)")=DIX
L @("-"_DIC_"X)")
;
; update the file header node
;
K D S:$D(DA)#2 D=DA S DA=X,X=DIX
I $D(@(DIC_"0)")) S ^(0)=$P(^(0),U,1,2)_U_DA_U_($P(^(0),U,4)+1)
N4 ; if compound index and we don't know internal value of .01, we'll prompt for it in ^DIE.
I DINO01 D G:Y>0 D Q
. D ^DICN1 I Y'>0 S:$G(DO(1)) DS(0)="1^" S (X,DIX)="" Q
. S (X,DIX)=$P($G(@(DIC_DA_",0)")),U)
. Q
N5 ; If .01 is marked for auditing, update audit file
D
. I DO(2)'["a" Q:$P(^DD(+DO(2),.01,0),U,2)'["a" Q:^("AUDIT")["e"
. D AUD^DIET
;
; index the .01 field of the new entry
;
N DD S DD=0 D
. N DIFILEI,DINDEX,DIVAL,DIENS,DISUBVAL
. F S DD=$O(^DD(+DO(2),.01,1,DD)) Q:'DD D
. . K % M %=X N X M X=% K %
. . I ^DD(+DO(2),.01,1,DD,0)["TRIGGER"!(^(0)["BULL") D Q
. . . N %RCR,DZ S %RCR="FIRE^DICN",DZ=^DD(+DO(2),.01,1,DD,1)
. . . F %="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X" S %RCR(%)=""
. . . D STORLIST^%RCR Q
. . M %=DIC N DIC M DIC=% K % M %=DA N DA M DA=% K % S %=DD N DD,D
. . X ^DD(+DO(2),.01,1,%,1) Q
. Q
I $O(^DD("IX","F",+DO(2),.01,0)) D
. K % M %=X N X M X=% K % M %=DIC N DIC M DIC=%
. K % M %=DA N DA M DA=% K % M %=DO N DO M DO=% K % N DD,D
. D INDEX^DIKC(+DO(2),DA_DIENS,.01,"","SC") Q
;
N6 ; if we have lookup values to stuff, or DIC("DR"), or if the file has
; IDs or KEYS, go do DIE.
; Code will return at D if successful. We set output and go exit
;
S Y=DA D
. I $D(DIC("DR"))!($O(DISUBVAL(+DO(2),0)))!($O(^DD("KEY","B",+DO(2),0))) D ^DICN1 Q
. Q:DIC(0)'["E"
. I '$O(^DD(+DO(2),0,"ID",0)) Q
. D ^DICN1 Q
I Y'>0 S:$G(DO(1)) DS(0)="1^" Q
;
; Finish adding the new record.
D S Y=DA_U_X_"^1" I $D(D)#2 S DA=D
D R^DIC2 Q
;
INCR S DIY=1 I $P(DO,U,2)>1 F %=1:1:$L($P(X,".",2)) S DIY=DIY/10
Q
;
;
OUT I DIC(0)["Q" W $C(7)_$S('$D(DDS):" ??",1:"")
S Y=-1 I $D(DO(1)),'$D(DTOUT) D A^DIC S DS(0)="1^" Q
D Q^DIC2 Q
;
LOCK(DIROOT,DIEN,DIRESULT) ;
;
; try to lock the record, and see if it's already there
; NEW
;
D LOCK^DILF(DIROOT_"DIEN)") ;L @("+"_DIROOT_"DIEN):1") ;**147
S DIRESULT='$D(@(DIROOT_"DIEN)"))&$T
I 'DIRESULT L @("-"_DIROOT_"DIEN)")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICN0 4347 printed Apr 09, 2024@21:55:28 Page 2
DICN0 ;SFISC/GFT,XAK,SEA/TOAD/TKW-ADD NEW ENTRY ;22MAR2006
+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 ;
NEW ; try to add a new record to the file
+1 ; called from FILE, ^DICN
+2 ;
+3 NEW %,I,DDH,DI,DIE,DIK,DQ,DR,%H,%T,%DT,C,DIG,DIH,DIU,DIV,DISYS
+4 KILL %
MERGE %=X
NEW X
MERGE X=%
SET %=+$GET(D0)
NEW D0
if %
SET D0=%
KILL %
+5 IF '$GET(DIFILEI)!($GET(DINDEX("#"))="")
NEW DINDEX,DIFILEI,DIENS
Begin DoDot:1
+6 SET DINDEX("#")=1
SET (DINDEX,DINDEX("START"))="B"
+7 DO GETFILE^DIC0(.DIC,.DIFILEI,.DIENS)
QUIT
End DoDot:1
+8 if DIFILEI=""
GOTO OUT
+9 IF '$DATA(@(DIC_"0)"))
IF '$DATA(DIC("P"))
IF $EXTRACT(DIC,1,6)'="^DOPT("
SET DIC("P")=$$GETP^DIC0(DIFILEI)
+10 if '$DATA(DO(2))
DO GETFA^DIC1(.DIC,.DO)
IF DO="0^-1"
GOTO OUT
+11 SET X=$GET(X)
IF X=""
IF DINDEX("#")>1
SET X=$GET(X(1))
+12 IF X=""
IF (DIC(0)'["E"!(DINDEX("#")'>1))
GOTO OUT
+13 NEW DINO01
SET DINO01=$SELECT(X="":1,1:0)
NEW DIX,DIY
+14 ;
N1 ; if LAYGO nodes are present, XECUTE them and verify they don't object
+1 ;
+2 SET Y=1
FOR DIX=0:0
Begin DoDot:1
+3 SET DIX=$ORDER(^DD(+DO(2),.01,"LAYGO",DIX))
if DIX'>0
QUIT
+4 IF $DATA(^DD(+DO(2),.01,"LAYGO",DIX,0))
XECUTE ^(0)
SET Y=$TEST
End DoDot:1
if DIX'>0
QUIT
if 'Y
QUIT
+5 IF 'Y
GOTO OUT
+6 ;
+7 ; if the file is in the middle of archiving, keep out
+8 ;
+9 IF $PIECE($GET(^DD($$FNO^DILIBF(+DO(2)),0,"DI")),U,2)["Y"
Begin DoDot:1
+10 SET Y='$DATA(DIOVRD)&'$GET(DIFROM)
End DoDot:1
IF Y
GOTO OUT
+11 ;
N2 ; process DINUM
+1 ;
+2 SET DIX=X
+3 IF $DATA(DINUM)
Begin DoDot:1
+4 SET X=DINUM
Begin DoDot:2
+5 NEW DIX
DO N^DICN1
QUIT
End DoDot:2
IF '$DATA(X)
SET Y=0
SET X=DIX
QUIT
+6 DO LOCK(DIC,X,.Y)
End DoDot:1
+7 ;
+8 ; or process DIENTRY (numeric input that might be IEN LAYGO)
+9 ;
+10 IF '$TEST
IF $DATA(DIENTRY)
Begin DoDot:1
+11 SET X=DIENTRY
Begin DoDot:2
+12 NEW DIX
DO ASKP001^DICN1
QUIT
End DoDot:2
IF 'Y
SET X=DIX
QUIT
+13 DO LOCK(DIC,X,.Y)
End DoDot:1
+14 ;
+15 ; or get a record number the usual way
+16 ;
+17 IF '$TEST
SET X=$PIECE(DO,U,3)
DO INCR
NEW DIFAUD
SET %=+$PIECE(DO,U,2)
SET DIFAUD=$SELECT($DATA(^DIA(%,"B")):%,1:0)
FOR
Begin DoDot:1
+18 FOR
SET X=X\DIY*DIY+DIY
if '$DATA(@(DIC_"X)"))&$SELECT('DIFAUD
QUIT
+19 IF $GET(DUZ(0))="@"!$PIECE(DO,U,2)
NEW DIX
DO ASKP001^DICN1
if 'Y
QUIT
+20 DO LOCK(DIC,X,.Y)
if Y
QUIT
SET Y="TRY NEXT"
End DoDot:1
if Y'="TRY NEXT"
QUIT
+21 ;
+22 IF 'Y
SET Y=-1
DO BAD^DIC1
QUIT
+23 ;
N3 ; add the new record at the IEN selected
+1 ;
+2 SET @(DIC_"X,0)")=DIX
+3 LOCK @("-"_DIC_"X)")
+4 ;
+5 ; update the file header node
+6 ;
+7 KILL D
if $DATA(DA)#2
SET D=DA
SET DA=X
SET X=DIX
+8 IF $DATA(@(DIC_"0)"))
SET ^(0)=$PIECE(^(0),U,1,2)_U_DA_U_($PIECE(^(0),U,4)+1)
N4 ; if compound index and we don't know internal value of .01, we'll prompt for it in ^DIE.
+1 IF DINO01
Begin DoDot:1
+2 DO ^DICN1
IF Y'>0
if $GET(DO(1))
SET DS(0)="1^"
SET (X,DIX)=""
QUIT
+3 SET (X,DIX)=$PIECE($GET(@(DIC_DA_",0)")),U)
+4 QUIT
End DoDot:1
if Y>0
GOTO D
QUIT
N5 ; If .01 is marked for auditing, update audit file
+1 Begin DoDot:1
+2 IF DO(2)'["a"
if $PIECE(^DD(+DO(2),.01,0),U,2)'["a"
QUIT
if ^("AUDIT")["e"
QUIT
+3 DO AUD^DIET
End DoDot:1
+4 ;
+5 ; index the .01 field of the new entry
+6 ;
+7 NEW DD
SET DD=0
Begin DoDot:1
+8 NEW DIFILEI,DINDEX,DIVAL,DIENS,DISUBVAL
+9 FOR
SET DD=$ORDER(^DD(+DO(2),.01,1,DD))
if 'DD
QUIT
Begin DoDot:2
+10 KILL %
MERGE %=X
NEW X
MERGE X=%
KILL %
+11 IF ^DD(+DO(2),.01,1,DD,0)["TRIGGER"!(^(0)["BULL")
Begin DoDot:3
+12 NEW %RCR,DZ
SET %RCR="FIRE^DICN"
SET DZ=^DD(+DO(2),.01,1,DD,1)
+13 FOR %="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X"
SET %RCR(%)=""
+14 DO STORLIST^%RCR
QUIT
End DoDot:3
QUIT
+15 MERGE %=DIC
NEW DIC
MERGE DIC=%
KILL %
MERGE %=DA
NEW DA
MERGE DA=%
KILL %
SET %=DD
NEW DD,D
+16 XECUTE ^DD(+DO(2),.01,1,%,1)
QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF $ORDER(^DD("IX","F",+DO(2),.01,0))
Begin DoDot:1
+19 KILL %
MERGE %=X
NEW X
MERGE X=%
KILL %
MERGE %=DIC
NEW DIC
MERGE DIC=%
+20 KILL %
MERGE %=DA
NEW DA
MERGE DA=%
KILL %
MERGE %=DO
NEW DO
MERGE DO=%
KILL %
NEW DD,D
+21 DO INDEX^DIKC(+DO(2),DA_DIENS,.01,"","SC")
QUIT
End DoDot:1
+22 ;
N6 ; if we have lookup values to stuff, or DIC("DR"), or if the file has
+1 ; IDs or KEYS, go do DIE.
+2 ; Code will return at D if successful. We set output and go exit
+3 ;
+4 SET Y=DA
Begin DoDot:1
+5 IF $DATA(DIC("DR"))!($ORDER(DISUBVAL(+DO(2),0)))!($ORDER(^DD("KEY","B",+DO(2),0)))
DO ^DICN1
QUIT
+6 if DIC(0)'["E"
QUIT
+7 IF '$ORDER(^DD(+DO(2),0,"ID",0))
QUIT
+8 DO ^DICN1
QUIT
End DoDot:1
+9 IF Y'>0
if $GET(DO(1))
SET DS(0)="1^"
QUIT
+10 ;
+11 ; Finish adding the new record.
D SET Y=DA_U_X_"^1"
IF $DATA(D)#2
SET DA=D
+1 DO R^DIC2
QUIT
+2 ;
INCR SET DIY=1
IF $PIECE(DO,U,2)>1
FOR %=1:1:$LENGTH($PIECE(X,".",2))
SET DIY=DIY/10
+1 QUIT
+2 ;
+3 ;
OUT IF DIC(0)["Q"
WRITE $CHAR(7)_$SELECT('$DATA(DDS):" ??",1:"")
+1 SET Y=-1
IF $DATA(DO(1))
IF '$DATA(DTOUT)
DO A^DIC
SET DS(0)="1^"
QUIT
+2 DO Q^DIC2
QUIT
+3 ;
LOCK(DIROOT,DIEN,DIRESULT) ;
+1 ;
+2 ; try to lock the record, and see if it's already there
+3 ; NEW
+4 ;
+5 ;L @("+"_DIROOT_"DIEN):1") ;**147
DO LOCK^DILF(DIROOT_"DIEN)")
+6 SET DIRESULT='$DATA(@(DIROOT_"DIEN)"))&$TEST
+7 IF 'DIRESULT
LOCK @("-"_DIROOT_"DIEN)")
+8 QUIT
+9 ;
