DICA1 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor ;13MAR2014
;;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.
;
CHECK(DIFLAGS,DIFDA,DINUMS,DIRULE,DIOK) ;
; ENTRY POINT--check out the FDA
; subroutine, DIFLAGS passed by value
N DIC,DIEN,DIFILE,DIFLD,DIN,DINODE,DINT,DINUM,DIOP
N DIOUT1,DIOUT2,DIOUT3,DIRID,DIRIGHT,DISEQ,DITYPE,DIVAL
N DIKEYEX
FILES ;
S DIFILE=0,DIOUT1=0 F D Q:DIOUT1!$G(DIERR)
. S DIFILE=$O(@DIFDA@(DIFILE))
. I 'DIFILE S DIOUT1=1 Q
. S DINODE=$G(^DD(DIFILE,.01,0))
. I DINODE="" D Q
. . D ERR^DICA3($S('$D(^DD(DIFILE)):401,1:406),DIFILE)
. I $P(DINODE,U,2)["W" D Q
. . D ERR^DICA3(407,DIFILE)
. S DIRID=$$RID^DICU(DIFILE)
. ;
. ;If we're using primary keys for lookup, get key info
. S DIKEYEX=$D(^DD("KEY","F",DIFILE))
. I $G(DIFLAGS)["K",DIKEYEX D GETPKEY^DIEVK1(DIFILE)
. ;
IENS . ;
. S DIEN="",DIOUT2=0 F D Q:DIOUT2!$G(DIERR)
. . S DIEN=$O(@DIFDA@(DIFILE,DIEN))
. . I DIEN="" S DIOUT2=1 Q
. . N DIDA D IEN^DICA2(.DIFILE,DIEN,.DIDA,DIRULE,.DIOK) Q:$G(DIERR)
. . I 'DIOK S DIOUT1=1,DIOUT2=1 D Q
. . . I $E(DIEN,$L(DIEN))'="," D ERR^DICA3(304,"",DIEN) Q
. . . D ERR^DICA3(202,"","","","IENS")
. . Q:'$$RID(DIFILE,DIEN,DIFDA,DIRID,DIFLAGS,DIKEYEX)
. . I $D(@DIFDA@(DIFILE,DIEN,.001))#2 D
. . . N DIENS S DIENS=@DIFDA@(DIFILE,DIEN,.001)
. . . I $D(@DINUMS@(@DIRULE@("NUM")))[0 D
. . . . S @DINUMS@(@DIRULE@("NUM"))=DIENS
. . . S @DIRULE@("SAVE",$J,DIFILE,DIEN,.001)=DIENS
. . . K @DIFDA@(DIFILE,DIEN,.001)
VALUES . . ;
. . I DIFLAGS'["E",$G(DIFLAGS)["U"!'DIKEYEX Q
. . S DIFLD="",DIOUT3=0 F D Q:DIOUT3!$G(DIERR)
. . . S DIFLD=$O(@DIFDA@(DIFILE,DIEN,DIFLD))
. . . I DIFLD="" S DIOUT3=1 Q
. . . I $G(DIFLAGS)'["U",DIKEYEX D BLDFLD^DIEVK1(DIFILE,DIEN,DIFLD) Q:DIFLAGS'["E"
. . . I $E(DIEN)="?",$E(DIEN,2)'="+" Q:DIFLD=.01&(DIFLAGS'["K") I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD))#2 Q
. . . S DIVAL=$G(@DIFDA@(DIFILE,DIEN,DIFLD))
. . . D DTYP^DIOU(DIFILE,DIFLD,.DITYPE)
. . . I DITYPE=5 S DINT=DIVAL
CONVERT . . . ;
. . . I DITYPE'=5 D Q:$G(DIERR)
. . . . I DIEN["?"!(DIEN["+") D Q:$G(DIERR)
. . . . . I "@"[DIVAL D Q
. . . . . . I DIEN["?",$P($G(^DD(DIFILE,DIFLD,0)),U,2)["R" D Q
. . . . . . . D ERR712(DIFILE,DIFLD)
. . . . . . S DINT=DIVAL
. . . . . I DIFLAGS["K",$E(DIEN)'="+",$P($G(^DD(DIFILE,DIFLD,0)),U,5,999)["DINUM",$D(^TMP("DIKK",$J,"P",DIFILE)),$D(^(DIFILE,DIFLD))[0 D Q
. . . . . . D ERR^DICA3(520,DIFILE,"",DIFLD,"DINUMed")
. . . . . N DA M DA=DIDA
. . . . . N DIARG S DIARG="D0"
. . . . . N DIMAX S DIMAX=$O(DA(""),-1)
. . . . . N DIVAR F DIVAR=1:1:DIMAX S DIARG=DIARG_",D"_DIVAR
. . . . . N @DIARG F DIVAR=0:1:DIMAX-1 S @("D"_DIVAR)=DA(DIMAX-DIVAR)
. . . . . S:DIMAX @("D"_DIMAX)=DA
. . . . . N DIDA D CHK^DIE(DIFILE,DIFLD,"N",DIVAL,.DINT)
. . . . E D Q:$G(DIERR)
. . . . . N DIVALFLG S DIVALFLG="RU"_$E("Y",DIFLAGS["Y")
. . . . . D VAL^DIE(DIFILE,DIEN,DIFLD,DIVALFLG,DIVAL,.DINT)
. . . . Q:$D(DINUM)[0
. . . . S @DINUMS@(@DIRULE@("NUM"))=DINUM K DINUM
. . . S @DIRULE@("FDA",DIFILE,DIEN,DIFLD)=DINT
CLEANUP ;
I $G(DIERR)!'DIOK K @DIRULE Q
K @DIRULE@("L"),@DIRULE@("NUM"),@DIRULE@("OP"),@DIRULE@("ROOT")
K @DIRULE@("SEQ"),@DIRULE@("TEMP"),@DIRULE@("UP")
S DIN=$NA(@DIRULE@("ORDER")),DIC=0,@DIRULE@("THE END")=""
F S DIN=$Q(@DIN) Q:DIN=""!($P(DIN,",",3)'="""ORDER""") D
. S DIC=DIC+1,@DIRULE@("NEXT",DIC)=@DIN
K @DIRULE@("ORDER"),@DIRULE@("THE END")
I DIFLAGS["E" S DIFDA=$NA(@DIRULE@("FDA"))
Q
;
RID(DIFILE,DIEN,DIFDA,DIRID,DIFLAGS,DIKEYEX) ;
N DIC,DIK,DIOK,DIP,DIR
;
;Check required ids
S DIP=$P(DIEN,","),DIOK=1
F DIC=1:1 S DIR=$P(DIRID,U,DIC) Q:DIR="" D
. I DIR=.01 D
. . I DIP'?1P.E
. . E I DIP["+" D:"@"[$G(@DIFDA@(DIFILE,DIEN,.01))
. . . S DIOK=0 D ERR^DICA3(352,DIFILE,DIEN)
. . E I DIFLAGS'["K" D:"@"[$G(@DIFDA@(DIFILE,DIEN,.01))
. . . S DIOK=0 D ERR^DICA3(351,DIFILE,DIEN)
. E I DIP["+" D:"@"[$G(@DIFDA@(DIFILE,DIEN,DIR))
. . S DIOK=0 D ERR^DICA3(312,DIFILE) ;"The list of fields is missing a required identifier for FILE #---"
. E D:"@"[$G(@DIFDA@(DIFILE,DIEN,DIR),0)
. . S DIOK=0 D ERR712(DIFILE,DIR)
;
;Check that the FDA contains the appropriate key fields
Q:'$G(DIKEYEX,1) DIOK
;
;If appropriate, ensure all primary and secondary keys are provided
I DIFLAGS'["U",DIP["+" D
. S DIR=0 F S DIR=$O(^DD("KEY","F",DIFILE,DIR)) Q:'DIR D
. . D:"@"[$G(@DIFDA@(DIFILE,DIEN,DIR))
. . . S DIK=0 F S DIK=$O(^DD("KEY","F",DIFILE,DIR,DIK)) Q:'DIK D
. . . . S DIOK=0 D ERR744^DIEVK1(DIFILE,DIR,DIK,DIEN)
;
;If appropriate, ensure at least one key field is provided
E I $G(DIFLAGS)["K",$E(DIEN)="?",$E(DIEN,2)'="+"!($G(DIFLAGS)["U") D
. S:'$$KFLD^DIEVK1(DIFILE,DIEN,DIFDA) DIOK=0
Q DIOK
;
ERR712(DIFILE,DIFIELD) ;
N DIFILNAM S DIFILNAM=$$FILENAME^DIALOGZ(DIFILE) S:DIFILNAM?." " DIFILNAM="#"_DIFILE ;**CCO/NI
N DIFLDNAM S DIFLDNAM=$$FLDNM^DIEFU(DIFILE,DIFIELD)
D ERR^DICA3(712,DIFILE,"",DIFIELD,DIFLDNAM,DIFILNAM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICA1 5269 printed Sep 23, 2025@20:21:31 Page 2
DICA1 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor ;13MAR2014
+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 ;
CHECK(DIFLAGS,DIFDA,DINUMS,DIRULE,DIOK) ;
+1 ; ENTRY POINT--check out the FDA
+2 ; subroutine, DIFLAGS passed by value
+3 NEW DIC,DIEN,DIFILE,DIFLD,DIN,DINODE,DINT,DINUM,DIOP
+4 NEW DIOUT1,DIOUT2,DIOUT3,DIRID,DIRIGHT,DISEQ,DITYPE,DIVAL
+5 NEW DIKEYEX
FILES ;
+1 SET DIFILE=0
SET DIOUT1=0
FOR
Begin DoDot:1
+2 SET DIFILE=$ORDER(@DIFDA@(DIFILE))
+3 IF 'DIFILE
SET DIOUT1=1
QUIT
+4 SET DINODE=$GET(^DD(DIFILE,.01,0))
+5 IF DINODE=""
Begin DoDot:2
+6 DO ERR^DICA3($SELECT('$DATA(^DD(DIFILE)):401,1:406),DIFILE)
End DoDot:2
QUIT
+7 IF $PIECE(DINODE,U,2)["W"
Begin DoDot:2
+8 DO ERR^DICA3(407,DIFILE)
End DoDot:2
QUIT
+9 SET DIRID=$$RID^DICU(DIFILE)
+10 ;
+11 ;If we're using primary keys for lookup, get key info
+12 SET DIKEYEX=$DATA(^DD("KEY","F",DIFILE))
+13 IF $GET(DIFLAGS)["K"
IF DIKEYEX
DO GETPKEY^DIEVK1(DIFILE)
+14 ;
IENS ;
+1 SET DIEN=""
SET DIOUT2=0
FOR
Begin DoDot:2
+2 SET DIEN=$ORDER(@DIFDA@(DIFILE,DIEN))
+3 IF DIEN=""
SET DIOUT2=1
QUIT
+4 NEW DIDA
DO IEN^DICA2(.DIFILE,DIEN,.DIDA,DIRULE,.DIOK)
if $GET(DIERR)
QUIT
+5 IF 'DIOK
SET DIOUT1=1
SET DIOUT2=1
Begin DoDot:3
+6 IF $EXTRACT(DIEN,$LENGTH(DIEN))'=","
DO ERR^DICA3(304,"",DIEN)
QUIT
+7 DO ERR^DICA3(202,"","","","IENS")
End DoDot:3
QUIT
+8 if '$$RID(DIFILE,DIEN,DIFDA,DIRID,DIFLAGS,DIKEYEX)
QUIT
+9 IF $DATA(@DIFDA@(DIFILE,DIEN,.001))#2
Begin DoDot:3
+10 NEW DIENS
SET DIENS=@DIFDA@(DIFILE,DIEN,.001)
+11 IF $DATA(@DINUMS@(@DIRULE@("NUM")))[0
Begin DoDot:4
+12 SET @DINUMS@(@DIRULE@("NUM"))=DIENS
End DoDot:4
+13 SET @DIRULE@("SAVE",$JOB,DIFILE,DIEN,.001)=DIENS
+14 KILL @DIFDA@(DIFILE,DIEN,.001)
End DoDot:3
VALUES ;
+1 IF DIFLAGS'["E"
IF $GET(DIFLAGS)["U"!'DIKEYEX
QUIT
+2 SET DIFLD=""
SET DIOUT3=0
FOR
Begin DoDot:3
+3 SET DIFLD=$ORDER(@DIFDA@(DIFILE,DIEN,DIFLD))
+4 IF DIFLD=""
SET DIOUT3=1
QUIT
+5 IF $GET(DIFLAGS)'["U"
IF DIKEYEX
DO BLDFLD^DIEVK1(DIFILE,DIEN,DIFLD)
if DIFLAGS'["E"
QUIT
+6 IF $EXTRACT(DIEN)="?"
IF $EXTRACT(DIEN,2)'="+"
if DIFLD=.01&(DIFLAGS'["K")
QUIT
IF DIFLAGS["K"
IF $DATA(^TMP("DIKK",$JOB,"P",DIFILE,DIFILE,DIFLD))#2
QUIT
+7 SET DIVAL=$GET(@DIFDA@(DIFILE,DIEN,DIFLD))
+8 DO DTYP^DIOU(DIFILE,DIFLD,.DITYPE)
+9 IF DITYPE=5
SET DINT=DIVAL
CONVERT ;
+1 IF DITYPE'=5
Begin DoDot:4
+2 IF DIEN["?"!(DIEN["+")
Begin DoDot:5
+3 IF "@"[DIVAL
Begin DoDot:6
+4 IF DIEN["?"
IF $PIECE($GET(^DD(DIFILE,DIFLD,0)),U,2)["R"
Begin DoDot:7
+5 DO ERR712(DIFILE,DIFLD)
End DoDot:7
QUIT
+6 SET DINT=DIVAL
End DoDot:6
QUIT
+7 IF DIFLAGS["K"
IF $EXTRACT(DIEN)'="+"
IF $PIECE($GET(^DD(DIFILE,DIFLD,0)),U,5,999)["DINUM"
IF $DATA(^TMP("DIKK",$JOB,"P",DIFILE))
IF $DATA(^(DIFILE,DIFLD))[0
Begin DoDot:6
+8 DO ERR^DICA3(520,DIFILE,"",DIFLD,"DINUMed")
End DoDot:6
QUIT
+9 NEW DA
MERGE DA=DIDA
+10 NEW DIARG
SET DIARG="D0"
+11 NEW DIMAX
SET DIMAX=$ORDER(DA(""),-1)
+12 NEW DIVAR
FOR DIVAR=1:1:DIMAX
SET DIARG=DIARG_",D"_DIVAR
+13 NEW @DIARG
FOR DIVAR=0:1:DIMAX-1
SET @("D"_DIVAR)=DA(DIMAX-DIVAR)
+14 if DIMAX
SET @("D"_DIMAX)=DA
+15 NEW DIDA
DO CHK^DIE(DIFILE,DIFLD,"N",DIVAL,.DINT)
End DoDot:5
if $GET(DIERR)
QUIT
+16 IF '$TEST
Begin DoDot:5
+17 NEW DIVALFLG
SET DIVALFLG="RU"_$EXTRACT("Y",DIFLAGS["Y")
+18 DO VAL^DIE(DIFILE,DIEN,DIFLD,DIVALFLG,DIVAL,.DINT)
End DoDot:5
if $GET(DIERR)
QUIT
+19 if $DATA(DINUM)[0
QUIT
+20 SET @DINUMS@(@DIRULE@("NUM"))=DINUM
KILL DINUM
End DoDot:4
if $GET(DIERR)
QUIT
+21 SET @DIRULE@("FDA",DIFILE,DIEN,DIFLD)=DINT
End DoDot:3
if DIOUT3!$GET(DIERR)
QUIT
End DoDot:2
if DIOUT2!$GET(DIERR)
QUIT
End DoDot:1
if DIOUT1!$GET(DIERR)
QUIT
CLEANUP ;
+1 IF $GET(DIERR)!'DIOK
KILL @DIRULE
QUIT
+2 KILL @DIRULE@("L"),@DIRULE@("NUM"),@DIRULE@("OP"),@DIRULE@("ROOT")
+3 KILL @DIRULE@("SEQ"),@DIRULE@("TEMP"),@DIRULE@("UP")
+4 SET DIN=$NAME(@DIRULE@("ORDER"))
SET DIC=0
SET @DIRULE@("THE END")=""
+5 FOR
SET DIN=$QUERY(@DIN)
if DIN=""!($PIECE(DIN,",",3)'="""ORDER""")
QUIT
Begin DoDot:1
+6 SET DIC=DIC+1
SET @DIRULE@("NEXT",DIC)=@DIN
End DoDot:1
+7 KILL @DIRULE@("ORDER"),@DIRULE@("THE END")
+8 IF DIFLAGS["E"
SET DIFDA=$NAME(@DIRULE@("FDA"))
+9 QUIT
+10 ;
RID(DIFILE,DIEN,DIFDA,DIRID,DIFLAGS,DIKEYEX) ;
+1 NEW DIC,DIK,DIOK,DIP,DIR
+2 ;
+3 ;Check required ids
+4 SET DIP=$PIECE(DIEN,",")
SET DIOK=1
+5 FOR DIC=1:1
SET DIR=$PIECE(DIRID,U,DIC)
if DIR=""
QUIT
Begin DoDot:1
+6 IF DIR=.01
Begin DoDot:2
+7 IF DIP'?1P.E
+8 IF '$TEST
IF DIP["+"
if "@"[$GET(@DIFDA@(DIFILE,DIEN,.01))
Begin DoDot:3
+9 SET DIOK=0
DO ERR^DICA3(352,DIFILE,DIEN)
End DoDot:3
+10 IF '$TEST
IF DIFLAGS'["K"
if "@"[$GET(@DIFDA@(DIFILE,DIEN,.01))
Begin DoDot:3
+11 SET DIOK=0
DO ERR^DICA3(351,DIFILE,DIEN)
End DoDot:3
End DoDot:2
+12 IF '$TEST
IF DIP["+"
if "@"[$GET(@DIFDA@(DIFILE,DIEN,DIR))
Begin DoDot:2
+13 ;"The list of fields is missing a required identifier for FILE #---"
SET DIOK=0
DO ERR^DICA3(312,DIFILE)
End DoDot:2
+14 IF '$TEST
if "@"[$GET(@DIFDA@(DIFILE,DIEN,DIR),0)
Begin DoDot:2
+15 SET DIOK=0
DO ERR712(DIFILE,DIR)
End DoDot:2
End DoDot:1
+16 ;
+17 ;Check that the FDA contains the appropriate key fields
+18 if '$GET(DIKEYEX,1)
QUIT DIOK
+19 ;
+20 ;If appropriate, ensure all primary and secondary keys are provided
+21 IF DIFLAGS'["U"
IF DIP["+"
Begin DoDot:1
+22 SET DIR=0
FOR
SET DIR=$ORDER(^DD("KEY","F",DIFILE,DIR))
if 'DIR
QUIT
Begin DoDot:2
+23 if "@"[$GET(@DIFDA@(DIFILE,DIEN,DIR))
Begin DoDot:3
+24 SET DIK=0
FOR
SET DIK=$ORDER(^DD("KEY","F",DIFILE,DIR,DIK))
if 'DIK
QUIT
Begin DoDot:4
+25 SET DIOK=0
DO ERR744^DIEVK1(DIFILE,DIR,DIK,DIEN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 ;If appropriate, ensure at least one key field is provided
+28 IF '$TEST
IF $GET(DIFLAGS)["K"
IF $EXTRACT(DIEN)="?"
IF $EXTRACT(DIEN,2)'="+"!($GET(DIFLAGS)["U")
Begin DoDot:1
+29 if '$$KFLD^DIEVK1(DIFILE,DIEN,DIFDA)
SET DIOK=0
End DoDot:1
+30 QUIT DIOK
+31 ;
ERR712(DIFILE,DIFIELD) ;
+1 ;**CCO/NI
NEW DIFILNAM
SET DIFILNAM=$$FILENAME^DIALOGZ(DIFILE)
if DIFILNAM?." "
SET DIFILNAM="#"_DIFILE
+2 NEW DIFLDNAM
SET DIFLDNAM=$$FLDNM^DIEFU(DIFILE,DIFIELD)
+3 DO ERR^DICA3(712,DIFILE,"",DIFIELD,DIFLDNAM,DIFILNAM)
+4 QUIT
