DICN ;SFISC/GFT,XAK,TKW,SEA/TOAD - ADD NEW ENTRY ;23JUN2017
;;22.2;VA FileMan;**2,5,13,14**;Jan 05, 2016;Build 8
;;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.
;;GFT;**4,31,169,999,1022,1044**
;
;COME HERE FROM L^DICM
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")) D ;CALLED FROM I+2. 'ARE YOU ADDING'? THRU NEXT 4 LINES
.N M
.S M=$$EZBLD^DIALOG(8058,$$OUT^DIALOGU(Y,"ORD")) ;" (the 14th" or whatever
.S:$D(^DD(+DO(2),0,"UP")) M=M_$$EZBLD^DIALOG(8059,$$FILENAME^DIALOGZ(^("UP"))) S M=M_")"
.I $L(M)+$L(DST)'>$S($G(IOM):IOM,1:80) S DST=DST_M
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
;preserve variables before execution of INPUT TRANSFORM on .01 field
I $P($P(DS,U,2),"t",2) D ;extensible data type
. S %=$$VALEXT^DIETLIBF(+DO(2),.01)
. N %T,%DT,C,DIG,DIH,DIU,DIV,DICR,DS
. X %
E S %=$F(DS,"%DT=""E"),DS=$E(DS,1,%-2)_$E(DS,%,999) D
. I DS["+X=X",(X?16.N) K X Q ;this used to be handled by DICTST variable ;p14
. S %=$P(DS,U,5,99)
. N %T,%DT,C,DIG,DIH,DIU,DIV,DICR,DS ;p14
. X %
UNIQ I $P(DS,U,2)["U",$D(X),$D(@(DIC_"""B"",X)")) K X
Q
;
I1 S DST=$C(7)_$$EZBLD^DIALOG(8060)
I '$D(DIENTRY),Y]"" S DST=DST_$$EZBLD^DIALOG(8061,Y)
S %=$$FILENAME^DIALOGZ(+DO(2)) I $L(DST)+$L(%)'>55 S DST=DST_$$EZBLD^DIALOG(8062,%) Q ;**CCO/NI FILE NAME
W:'$D(DDS) !,DST K A1 D:$D(DDS) H^DIC2 S DST=" "_$$EZBLD^DIALOG(8062,%) Q
;
I ;COME HERE FROM USR+2, ABOVE
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 ;TRANSFORM INTERNAL TO EXTERNAL IN ORDER TO DISPLAY IT
. 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
HELP I '$D(X) D G R ;INPUT NOT VALID. SHOW HELP MESSAGE FOR .01 FIELD, WHEN TELLING USER HOW TO LAYGO A NEW ONE
.W $C(7) W:'$D(DDS) "??" S DST=$$HELP^DIALOGZ(+DO(2),.01) Q:DST=""
.S DST=" "_DST W:'$D(DDS) !,DST D:$D(DDS) H^DDSU
;
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|
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICN 5118 printed Sep 23, 2025@20:22:28 Page 2
DICN ;SFISC/GFT,XAK,TKW,SEA/TOAD - ADD NEW ENTRY ;23JUN2017
+1 ;;22.2;VA FileMan;**2,5,13,14**;Jan 05, 2016;Build 8
+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 ;;GFT;**4,31,169,999,1022,1044**
+7 ;
+8 ;COME HERE FROM L^DICM
+9 NEW DIENTRY,DIFILE,DIAC
if '$DATA(DO(2))
DO GETFA^DIC1(.DIC,.DO)
SET DO(1)=1
+10 IF '$DATA(DINDEX)
NEW DINDEX
SET DINDEX("#")=1
SET DINDEX("START")="B"
+11 NEW DISUBVAL,V
+12 IF DINDEX("#")>1
MERGE V=X
NEW X
Begin DoDot:1
+13 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
+14 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 ;CALLED FROM I+2. 'ARE YOU ADDING'? THRU NEXT 4 LINES
IF '$DATA(DIC("S"))
Begin DoDot:1
+1 NEW M
+2 ;" (the 14th" or whatever
SET M=$$EZBLD^DIALOG(8058,$$OUT^DIALOGU(Y,"ORD"))
+3 if $DATA(^DD(+DO(2),0,"UP"))
SET M=M_$$EZBLD^DIALOG(8059,$$FILENAME^DIALOGZ(^("UP")))
SET M=M_")"
+4 IF $LENGTH(M)+$LENGTH(DST)'>$SELECT($GET(IOM):IOM,1:80)
SET DST=DST_M
End DoDot:1
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 before execution of INPUT TRANSFORM on .01 field
+5 ;extensible data type
IF $PIECE($PIECE(DS,U,2),"t",2)
Begin DoDot:1
+6 SET %=$$VALEXT^DIETLIBF(+DO(2),.01)
+7 NEW %T,%DT,C,DIG,DIH,DIU,DIV,DICR,DS
+8 XECUTE %
End DoDot:1
+9 IF '$TEST
SET %=$FIND(DS,"%DT=""E")
SET DS=$EXTRACT(DS,1,%-2)_$EXTRACT(DS,%,999)
Begin DoDot:1
+10 ;this used to be handled by DICTST variable ;p14
IF DS["+X=X"
IF (X?16.N)
KILL X
QUIT
+11 SET %=$PIECE(DS,U,5,99)
+12 ;p14
NEW %T,%DT,C,DIG,DIH,DIU,DIV,DICR,DS
+13 XECUTE %
End DoDot:1
UNIQ IF $PIECE(DS,U,2)["U"
IF $DATA(X)
IF $DATA(@(DIC_"""B"",X)"))
KILL X
+1 QUIT
+2 ;
I1 SET DST=$CHAR(7)_$$EZBLD^DIALOG(8060)
+1 IF '$DATA(DIENTRY)
IF Y]""
SET DST=DST_$$EZBLD^DIALOG(8061,Y)
+2 ;**CCO/NI FILE NAME
SET %=$$FILENAME^DIALOGZ(+DO(2))
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 ;COME HERE FROM USR+2, ABOVE
+1 IF DIC(0)["E"
IF DO(2)'["A"
IF DIC(0)'["W"
KILL DTOUT,DUOUT
Begin DoDot:1
+2 ;TRANSFORM INTERNAL TO EXTERNAL IN ORDER TO DISPLAY IT
SET (Y,DIX)=X
IF Y]""
NEW C
SET C=$PIECE(^DD(+DO(2),.01,0),U,2)
DO Y^DIQ
+3 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
HELP ;INPUT NOT VALID. SHOW HELP MESSAGE FOR .01 FIELD, WHEN TELLING USER HOW TO LAYGO A NEW ONE
IF '$DATA(X)
Begin DoDot:1
+1 WRITE $CHAR(7)
if '$DATA(DDS)
WRITE "??"
SET DST=$$HELP^DIALOGZ(+DO(2),.01)
if DST=""
QUIT
+2 SET DST=" "_DST
if '$DATA(DDS)
WRITE !,DST
if $DATA(DDS)
DO H^DDSU
End DoDot:1
GOTO R
+3 ;
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|
