- 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|
