DICN ;SFISC/GFT,XAK,TKW,SEA/TOAD-ADD NEW ENTRY ;16NOV2012
;;22.0;VA FileMan;**4,31,169**;Mar 30, 1999;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
;
N DIENTRY,DIFILE,DIAC D:'$D(DO(2)) GETFA^DIC1(.DIC,.DO) S DO(1)=1
I '$D(DINDEX) N DINDEX S DINDEX("#")=1,DINDEX("START")="B"
N DISUBVAL,V
I DINDEX("#")>1 M V=X N X D I X="",DIC(0)'["E"!('$D(DISUBVAL)) D BAD^DIC1 Q
. D VALIX(+DO(2),.DINDEX,.V,.DISUBVAL,.X,.DS) K V Q
I $S($D(DLAYGO):DO(2)\1-(DLAYGO\1),1:1) S %=1 D B1 I '% D BAD^DIC1 Q
USR D DS S DIX=X
I X'?16.N,X?.NP,X,DIC(0)["E",'$G(DICR),DS'["DINUM",$P(DS,U,2)'["N",DIC(0)["N"!$D(^DD(+DO(2),.001,0)) D N^DICN1 I $D(X) S DIENTRY=X G I
S X=DIX D:DINDEX("#")'>1 VAL G I:$D(X)
S X=DIX
B D BAD^DIC1 S Y=-1 Q
;
B1 Q:'DO(2) Q:$D(^DD(+DO(2),0,"UP"))!(DO(2)=".12P")
S DIFILE=+DO(2),DIAC="LAYGO" D ^DIAC K DIAC,DIFILE
Q
;
1 I '$D(DIC("S")) S DST=$G(DST)_$$EZBLD^DIALOG(8058,$$OUT^DIALOGU(Y,"ORD")) S:$D(^DD(+DO(2),0,"UP")) DST=DST_$$EZBLD^DIALOG(8059,$O(^DD(^("UP"),0,"NM",0))) S DST=DST_")"
Y I $D(DDS) S A1="Q",DST=%_U_DST D H^DDSU Q
W !,DST K DST
YN ;
N %1 S %1=$$EZBLD^DIALOG(7001) S:'$D(%) %=0 W "? " W:(%>0) $P(%1,U,%),"// "
RX R %Y:$S($D(DTIME):DTIME,1:300) E S DTOUT=1,%Y=U W $C(7)
I %Y]""!'% S %=+$$PRS^DIALOGU(7001,%Y) S:(%<0&($A(%Y)'=94)) %=0
I '%,%Y'?."?" W $C(7),"??",!?4,$$EZBLD^DIALOG(8040),": " G RX
W:$X>73 ! W:% $S(%>0:" ("_$P(%1,U,%)_")",1:"") Q
;
DS S DS=^DD(+DO(2),.01,0) Q
;
VAL I X'?.ANP K X Q
I X[""""!(X["^") K X Q
I $P(DS,U,2)'["N",$A(X)=45 K X Q
I $P(DS,U,2)["*" S:DS["DINUM" DINUM=X Q
N %T,%DT,C,DIG,DIH,DIU,DIV,DICR ;PRESERVE VARIABLES WHILE WE XECUTE INPUT TRANSFORM ON THE .01 FIELD
S %=$F(DS,"%DT=""E"),DS=$E(DS,1,%-2)_$E(DS,%,999) N DICTST S DICTST=DS["+X=X"&(X?16.N) K:DICTST X X:'DICTST $P(DS,U,5,99) Q
;
I1 S DST=$C(7)_$$EZBLD^DIALOG(8060)
I '$D(DIENTRY),Y]"" S DST=DST_$$EZBLD^DIALOG(8061,Y)
S %=$P(DO,U,1) I $L(DST)+$L(%)'>55 S DST=DST_$$EZBLD^DIALOG(8062,%) Q
W:'$D(DDS) !,DST K A1 D:$D(DDS) H^DIC2 S DST=" "_$$EZBLD^DIALOG(8062,%) Q
;
I I DIC(0)["E",DO(2)'["A",DIC(0)'["W" K DTOUT,DUOUT D G OUT^DICN0:$G(DTOUT)!($G(DUOUT)) I %'=1 S Y=-1 D BAD^DIC1 Q
. S (Y,DIX)=X I Y]"" N C S C=$P(^DD(+DO(2),.01,0),U,2) D Y^DIQ
. D I1 S %=2,Y=$P(DO,U,4)+1,X=DIX D 1
I2 . Q:%>0!($G(DTOUT)) I %=-1 S DUOUT=1 Q
. W:'$D(DDS) $C(7)_"??",!?4,$$EZBLD^DIALOG(8040) D YN G I2
G NEW:'$D(DIENTRY)
R D DS S DST=" "_$P(DS,U,1)_": "
I '$D(DDS) W !,DST K DST R X:DTIME S:$E(X)=U DUOUT=1,Y=-1 S:'$T X=U,DTOUT=1,Y=-1
I $D(DDS) S A1="Q",DST="3^"_DST D H^DDSU S X=% I $D(DTOUT) S X=U,Y=-1
I X[U D BAD^DIC1 Q
I X="" G R
D VAL
I '$D(X) W $C(7) W:'$D(DDS) "??" G:'$D(^DD(+DO(2),.01,3)) R S DST=" "_^(3) W:'$D(DDS) !,DST D:$D(DDS) H^DDSU G R
;
NEW ; try to add a new record to the file
G NEW^DICN0
;
FILE ; DOCUMENTED ENTRY POINT: add a new record to a file
;
N DIENTRY,DS,DIAC,DIFILE D NEW^DICN0,Q^DIC2 Q
;
FIRE ; fire the SET logic of a bulletin or trigger xref (in DZ)
; STORLIST^%RCR (called by NEW^DICN0)
;
X DZ
Q
;
VALIX(DIFILEI,DINDEX,V,DISUBVAL,X,DS) ;
; Save lookup values in array by field no. so we can update the fields on the new record.
N VI,DISUB,DIERR,DIFILE,DIFIELD,DO,DIOK
S X="" I $G(V)]"",$G(V(1))="" S V(1)=V
F DISUB=1:1:DINDEX("#") I $G(V(DISUB))]"" D
. S DIFILE=$G(DINDEX(DISUB,"FILE")),DIFIELD=$G(DINDEX(DISUB,"FIELD"))
. S DIOK=0 I 'DIFILE!('DIFIELD) Q
. S V=V(DISUB)
. I DISUB=1 D I DIOK S:DIOK'=2 DISUBVAL(DIFILE,DIFIELD)=V Q
. . I $A(V)=34,V?.E1"""" S V=$E(V,2,($L(V))-1)
. . I $G(DS("INT"))="",'$G(DICRS) S:"VP"[$G(DINDEX(1,"TYPE")) DIOK=2 Q
. . S DIOK=1
. . I DIFILE=DIFILEI,DIFIELD=.01 S X=$S($G(DICRS):V,1:DS("INT")) Q
. . S DISUBVAL(DIFILE,DIFIELD,"INT")=$S($G(DICRS):V,1:DS("INT"))
. . Q
. S DISUBVAL(DIFILE,DIFIELD)=V
. D CHK^DIE(DIFILE,DIFIELD,"",V,.VI,"DIERR") Q:VI="^"
. I DIFILE=DIFILEI,DIFIELD=.01 S X=VI K DISUBVAL(DIFILE,.01) Q
. S DISUBVAL(DIFILE,DIFIELD,"INT")=VI
. Q
Q
;
;#7001 Yes/No question
;#8040 Answer with 'Yes' or 'No'
;#8058 (the |entry number|
;#8059 for this |filename|
;#8060 Are you adding
;#8061 '|.01 field value|' as
;#8062 a new |filename|
DICN ;SFISC/GFT,XAK,TKW,SEA/TOAD-ADD NEW ENTRY ;16NOV2012
+1 ;;22.0;VA FileMan;**4,31,169**;Mar 30, 1999;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 NEW DIENTRY,DIFILE,DIAC
IF '$DATA(DO(2))
DO GETFA^DIC1(.DIC,.DO)
SET DO(1)=1
+5 IF '$DATA(DINDEX)
NEW DINDEX
SET DINDEX("#")=1
SET DINDEX("START")="B"
+6 NEW DISUBVAL,V
+7 IF DINDEX("#")>1
MERGE V=X
NEW X
Begin DoDot:1
+8 DO VALIX(+DO(2),.DINDEX,.V,.DISUBVAL,.X,.DS)
KILL V
QUIT
End DoDot:1
IF X=""
IF DIC(0)'["E"!('$DATA(DISUBVAL))
DO BAD^DIC1
QUIT
+9 IF $SELECT($DATA(DLAYGO):DO(2)\1-(DLAYGO\1),1:1)
SET %=1
DO B1
IF '%
DO BAD^DIC1
QUIT
USR DO DS
SET DIX=X
+1 IF X'?16.N
IF X?.NP
IF X
IF DIC(0)["E"
IF '$GET(DICR)
IF DS'["DINUM"
IF $PIECE(DS,U,2)'["N"
IF DIC(0)["N"!$DATA(^DD(+DO(2),.001,0))
DO N^DICN1
IF $DATA(X)
SET DIENTRY=X
GOTO I
+2 SET X=DIX
IF DINDEX("#")'>1
DO VAL
IF $DATA(X)
GOTO I
+3 SET X=DIX
B DO BAD^DIC1
SET Y=-1
QUIT
+1 ;
B1 IF 'DO(2)
QUIT
IF $DATA(^DD(+DO(2),0,"UP"))!(DO(2)=".12P")
QUIT
+1 SET DIFILE=+DO(2)
SET DIAC="LAYGO"
DO ^DIAC
KILL DIAC,DIFILE
+2 QUIT
+3 ;
1 IF '$DATA(DIC("S"))
SET DST=$GET(DST)_$$EZBLD^DIALOG(8058,$$OUT^DIALOGU(Y,"ORD"))
IF $DATA(^DD(+DO(2),0,"UP"))
SET DST=DST_$$EZBLD^DIALOG(8059,$ORDER(^DD(^("UP"),0,"NM",0)))
SET DST=DST_")"
Y IF $DATA(DDS)
SET A1="Q"
SET DST=%_U_DST
DO H^DDSU
QUIT
+1 WRITE !,DST
KILL DST
YN ;
+1 NEW %1
SET %1=$$EZBLD^DIALOG(7001)
IF '$DATA(%)
SET %=0
WRITE "? "
IF (%>0)
WRITE $PIECE(%1,U,%),"// "
RX READ %Y:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
SET DTOUT=1
SET %Y=U
WRITE $CHAR(7)
+1 IF %Y]""!'%
SET %=+$$PRS^DIALOGU(7001,%Y)
IF (%<0&($ASCII(%Y)'=94))
SET %=0
+2 IF '%
IF %Y'?."?"
WRITE $CHAR(7),"??",!?4,$$EZBLD^DIALOG(8040),": "
GOTO RX
+3 IF $X>73
WRITE !
IF %
WRITE $SELECT(%>0:" ("_$PIECE(%1,U,%)_")",1:"")
QUIT
+4 ;
DS SET DS=^DD(+DO(2),.01,0)
QUIT
+1 ;
VAL IF X'?.ANP
KILL X
QUIT
+1 IF X[""""!(X["^")
KILL X
QUIT
+2 IF $PIECE(DS,U,2)'["N"
IF $ASCII(X)=45
KILL X
QUIT
+3 IF $PIECE(DS,U,2)["*"
IF DS["DINUM"
SET DINUM=X
QUIT
+4 ;PRESERVE VARIABLES WHILE WE XECUTE INPUT TRANSFORM ON THE .01 FIELD
NEW %T,%DT,C,DIG,DIH,DIU,DIV,DICR
+5 SET %=$FIND(DS,"%DT=""E")
SET DS=$EXTRACT(DS,1,%-2)_$EXTRACT(DS,%,999)
NEW DICTST
SET DICTST=DS["+X=X"&(X?16.N)
IF DICTST
KILL X
IF 'DICTST
XECUTE $PIECE(DS,U,5,99)
QUIT
+6 ;
I1 SET DST=$CHAR(7)_$$EZBLD^DIALOG(8060)
+1 IF '$DATA(DIENTRY)
IF Y]""
SET DST=DST_$$EZBLD^DIALOG(8061,Y)
+2 SET %=$PIECE(DO,U,1)
IF $LENGTH(DST)+$LENGTH(%)'>55
SET DST=DST_$$EZBLD^DIALOG(8062,%)
QUIT
+3 IF '$DATA(DDS)
WRITE !,DST
KILL A1
IF $DATA(DDS)
DO H^DIC2
SET DST=" "_$$EZBLD^DIALOG(8062,%)
QUIT
+4 ;
I IF DIC(0)["E"
IF DO(2)'["A"
IF DIC(0)'["W"
KILL DTOUT,DUOUT
Begin DoDot:1
+1 SET (Y,DIX)=X
IF Y]""
NEW C
SET C=$PIECE(^DD(+DO(2),.01,0),U,2)
DO Y^DIQ
+2 DO I1
SET %=2
SET Y=$PIECE(DO,U,4)+1
SET X=DIX
DO 1
I2 IF %>0!($GET(DTOUT))
QUIT
IF %=-1
SET DUOUT=1
QUIT
+1 IF '$DATA(DDS)
WRITE $CHAR(7)_"??",!?4,$$EZBLD^DIALOG(8040)
DO YN
GOTO I2
End DoDot:1
IF $GET(DTOUT)!($GET(DUOUT))
GOTO OUT^DICN0
IF %'=1
SET Y=-1
DO BAD^DIC1
QUIT
+2 IF '$DATA(DIENTRY)
GOTO NEW
R DO DS
SET DST=" "_$PIECE(DS,U,1)_": "
+1 IF '$DATA(DDS)
WRITE !,DST
KILL DST
READ X:DTIME
IF $EXTRACT(X)=U
SET DUOUT=1
SET Y=-1
IF '$TEST
SET X=U
SET DTOUT=1
SET Y=-1
+2 IF $DATA(DDS)
SET A1="Q"
SET DST="3^"_DST
DO H^DDSU
SET X=%
IF $DATA(DTOUT)
SET X=U
SET Y=-1
+3 IF X[U
DO BAD^DIC1
QUIT
+4 IF X=""
GOTO R
+5 DO VAL
+6 IF '$DATA(X)
WRITE $CHAR(7)
IF '$DATA(DDS)
WRITE "??"
IF '$DATA(^DD(+DO(2),.01,3))
GOTO R
SET DST=" "_^(3)
IF '$DATA(DDS)
WRITE !,DST
IF $DATA(DDS)
DO H^DDSU
GOTO R
+7 ;
NEW ; try to add a new record to the file
+1 GOTO NEW^DICN0
+2 ;
FILE ; DOCUMENTED ENTRY POINT: add a new record to a file
+1 ;
+2 NEW DIENTRY,DS,DIAC,DIFILE
DO NEW^DICN0
DO Q^DIC2
QUIT
+3 ;
FIRE ; fire the SET logic of a bulletin or trigger xref (in DZ)
+1 ; STORLIST^%RCR (called by NEW^DICN0)
+2 ;
+3 XECUTE DZ
+4 QUIT
+5 ;
VALIX(DIFILEI,DINDEX,V,DISUBVAL,X,DS) ;
+1 ; Save lookup values in array by field no. so we can update the fields on the new record.
+2 NEW VI,DISUB,DIERR,DIFILE,DIFIELD,DO,DIOK
+3 SET X=""
IF $GET(V)]""
IF $GET(V(1))=""
SET V(1)=V
+4 FOR DISUB=1:1:DINDEX("#")
IF $GET(V(DISUB))]""
Begin DoDot:1
+5 SET DIFILE=$GET(DINDEX(DISUB,"FILE"))
SET DIFIELD=$GET(DINDEX(DISUB,"FIELD"))
+6 SET DIOK=0
IF 'DIFILE!('DIFIELD)
QUIT
+7 SET V=V(DISUB)
+8 IF DISUB=1
Begin DoDot:2
+9 IF $ASCII(V)=34
IF V?.E1""""
SET V=$EXTRACT(V,2,($LENGTH(V))-1)
+10 IF $GET(DS("INT"))=""
IF '$GET(DICRS)
IF "VP"[$GET(DINDEX(1,"TYPE"))
SET DIOK=2
QUIT
+11 SET DIOK=1
+12 IF DIFILE=DIFILEI
IF DIFIELD=.01
SET X=$SELECT($GET(DICRS):V,1:DS("INT"))
QUIT
+13 SET DISUBVAL(DIFILE,DIFIELD,"INT")=$SELECT($GET(DICRS):V,1:DS("INT"))
+14 QUIT
End DoDot:2
IF DIOK
IF DIOK'=2
SET DISUBVAL(DIFILE,DIFIELD)=V
QUIT
+15 SET DISUBVAL(DIFILE,DIFIELD)=V
+16 DO CHK^DIE(DIFILE,DIFIELD,"",V,.VI,"DIERR")
IF VI="^"
QUIT
+17 IF DIFILE=DIFILEI
IF DIFIELD=.01
SET X=VI
KILL DISUBVAL(DIFILE,.01)
QUIT
+18 SET DISUBVAL(DIFILE,DIFIELD,"INT")=VI
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
+22 ;#7001 Yes/No question
+23 ;#8040 Answer with 'Yes' or 'No'
+24 ;#8058 (the |entry number|
+25 ;#8059 for this |filename|
+26 ;#8060 Are you adding
+27 ;#8061 '|.01 field value|' as
+28 ;#8062 a new |filename|
