- DICN0 ;SFISC/GFT,XAK,SEA/TOAD/TKW-ADD NEW ENTRY ;10:39 AM 3 Apr 2006
- ;;22.0;VA FileMan;**31,48,56,147**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- 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
- ;M %=DA N DA M DA=%
- 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) 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
- ;
- DICN0 ;SFISC/GFT,XAK,SEA/TOAD/TKW-ADD NEW ENTRY ;10:39 AM 3 Apr 2006
- +1 ;;22.0;VA FileMan;**31,48,56,147**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- 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 ;M %=DA N DA M DA=%
- +5 KILL %
- MERGE %=X
- NEW X
- MERGE X=%
- SET %=+$GET(D0)
- NEW D0
- IF %
- SET D0=%
- KILL %
- +6 IF '$GET(DIFILEI)!($GET(DINDEX("#"))="")
- NEW DINDEX,DIFILEI,DIENS
- Begin DoDot:1
- +7 SET DINDEX("#")=1
- SET (DINDEX,DINDEX("START"))="B"
- +8 DO GETFILE^DIC0(.DIC,.DIFILEI,.DIENS)
- QUIT
- End DoDot:1
- +9 IF DIFILEI=""
- GOTO OUT
- +10 IF '$DATA(@(DIC_"0)"))
- IF '$DATA(DIC("P"))
- IF $EXTRACT(DIC,1,6)'="^DOPT("
- SET DIC("P")=$$GETP^DIC0(DIFILEI)
- +11 IF '$DATA(DO)
- DO GETFA^DIC1(.DIC,.DO)
- IF DO="0^-1"
- GOTO OUT
- +12 SET X=$GET(X)
- IF X=""
- IF DINDEX("#")>1
- SET X=$GET(X(1))
- +13 IF X=""
- IF (DIC(0)'["E"!(DINDEX("#")'>1))
- GOTO OUT
- +14 NEW DINO01
- SET DINO01=$SELECT(X="":1,1:0)
- NEW DIX,DIY
- +15 ;
- 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 ;
