DDSUTL ;SFISC/MKO-PROGRAMMER UTILITIES ;11:37 AM 25 Jul 1995
;;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.
;
MSG(TXT) ;
;Data validation messages
D PROC(.TXT,$NA(@DDSREFT@("MSG")))
Q
;
HLP(TXT) ;
;Help box messages
D PROC(.TXT,$NA(@DDSREFT@("HLP")))
Q
PROC(TXT,GLB) ;
;Put text into global
N CNT,I
S CNT=$G(@GLB)
I $D(TXT)<9 S CNT=CNT+1,@GLB@(CNT)=TXT
E S I="" F CNT=CNT:1 S I=$O(TXT(I)) Q:I="" S @GLB@(CNT+1)=TXT(I)
S @GLB=CNT
Q
;
REFRESH ;Refresh the screen
G R^DDSR
;
MLOAD(DDSIEN) ;Load subrecords for current multiple
G MLOAD^DDSM1
;
MDEL(DDSIEN) ;Delete subrecords for current multiple
G MDEL^DDSM1
;
UNED(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change DISABLE EDITING attribute
S:$D(DDSVAL)[0 DDSVAL=""
D SETATT(4)
Q
;
REQ(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change REQUIRED attribute
S:$D(DDSVAL)[0 DDSVAL=""
D SETATT(1)
Q
;
;
SETATT(DDSUPC) ;Set attribute node, piece DDSUPC
N DDSOVAL,DDSUDDP,DDSUFLD,DDSUTP
I $D(DDSPG)[0 N DDSPG S DDSPG=""
I $D(DDSBK)[0 N DDSBK S DDSBK=""
S DDSP=$$GETFLD^DDSLIB(DDSF,$G(DDSB),$G(DDSP),+DDS,DDSPG,DDSBK)
I $G(DIERR) D ERR^DDSMSG Q
;
S DDSF=$P(DDSP,","),DDSB=$P(DDSP,",",2),DDSP=$P(DDSP,",",3)
;
S DDSUDDP=+$P($G(^DIST(.404,DDSB,0)),U,2)
I DDSUDDP,$G(DDSUDA)]"" N DDSDA S DDSDA=DDSUDA
E I DDSUDDP,DDSB'=DDSBK N DDSDA D GL^DDS10(DDSUDDP,.DDSDAORG,"","",.DDSDA)
;
S DDSUTP=$P($G(^DIST(.404,DDSB,40,DDSF,0)),U,3) S:'DDSUTP DDSUTP=3
I DDSUTP=2 D
. S DDSUFLD=DDSF_","_DDSB
. S DDSUDDP=0
E I DDSUTP=3 D Q:'DDSUFLD
. S DDSUFLD=$P($G(^DIST(.404,DDSB,40,DDSF,1)),U)
E Q
;
S DDSOVAL=$P($G(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A")),U,DDSUPC)
Q:DDSVAL=DDSOVAL
S $P(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A"),U,DDSUPC)=DDSVAL
Q
;
ADD(DDSFIL,X,DA,DINUM,DDSDIC0,DDSDR,DDSL) ;
;Add an entry as part of a transaction
;DDSL=1 means don't lock
;
N %,%W,%Y,C,D0,DD,DO,DI,DIC,DIE,DQ,DR
N DDSDA,DDSDIC,DDSFD,DDSREQ,DDSUP,I
K DIERR,^TMP("DIERR",$J)
K:'$G(DINUM) DINUM
S:$G(DDSDIC0)="" DDSDIC0="L"
S DIC(0)=DDSDIC0,Y=-1
S:$G(DDSDR)]"" DIC("DR")=DDSDR
S DIC=$$ROOT^DILFD(DDSFIL,.DA),DDSDIC=$$CREF^DIQGU(DIC)
;
I $D(@DDSDIC@(0))[0 D Q:$G(DIC("P"))=""
. S DDSUP=$G(^DD(DDSFIL,0,"UP")) Q:'DDSUP
. S DDSFD=$O(^DD(DDSUP,"SB",DDSFIL,"")) Q:'DDSFD
. S DIC("P")=$P($G(^DD(DDSUP,DDSFD,0)),U,2)
;
I DDSDIC0'["E",$$REQID(DDSFIL,.DDSREQ) D Q:$G(DIERR)
. N F
. S F=""
. F S F=$O(DDSREQ(F)) Q:'F I $G(DIC("DR"))'[(F_"///") D BLD^DIALOG(3031,"ADD^DDSUTL") Q
;
D FILE^DICN K DTOUT,DUOUT Q:Y=-1!'$D(DDS)
;
I '$G(DDSL) D
. N I,L,R
. S L=1,R=DIC_DA_","
. F I=$L(R,",")-1:-1:1 I $D(^TMP("DDS",$J,"LOCK",$P(R,",",1,I)_")"))#2 S L=0 Q
. I L,$D(^TMP("DDS",$J,"LOCK",$P(R,"(")))#2 S L=0
. I L L +@(DIC_+Y_")"):0 S ^TMP("DDS",$J,"LOCK",DIC_+Y_")")=""
;
S DDSDA=+Y_","
F I=1:1 Q:$D(DA(I))[0 S DDSDA=DDSDA_DA(I)_","
S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIC
Q
;
REQID(FIL,REQ) ;
;Get list of required identifiers into DDSREQ
N F
K REQ
S F="" F S F=$O(^DD(FIL,0,"ID",F)) Q:F'=+$P(F,"E") D
. S:$P($G(^DD(FIL,F,0)),U,2)["R" REQ(F)=""
Q $D(REQ)>0
;
DESTROY(PG) ;Destroy all data for page PG
N P,B,F,IENS,TP,FIL,FLD
S P=$O(^DIST(.403,+DDS,40,"B",PG,"")) Q:'P
S B=0 F S B=$O(^DIST(.403,+DDS,40,P,40,B)) Q:'B D
. Q:'$D(^DIST(.403,+DDS,40,P,40,B,0))
. Q:'$D(^DIST(.404,B,0)) S FIL=$P(^(0),U,2)
. S F=0 F S F=$O(^DIST(.404,B,40,F)) Q:'F D
.. Q:'$D(^DIST(.404,B,40,F,0)) S TP=$P(^(0),U,3)
.. S:'TP TP=3
.. ;
.. I TP=3 S FF="F"_FIL,FLD=$G(^DIST(.404,B,40,F,1)) Q:FLD?."^"
.. E I TP=2 S FF="F0",FLD=F_","_B
.. E Q
.. ;
.. S IENS=" "
.. F S IENS=$O(@DDSREFT@(FF,IENS)) Q:IENS="" K ^(IENS,FLD)
;
K @DDSREFT@(P),@DDSREFT@("XCAP",P)
Q
;
;
DDSDA(DA,DL,DDSDA) ;Determine DDSDA
;
N I
I DA="" S DDSDA="" Q
S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_","
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSUTL 4178 printed Apr 09, 2024@21:45:08 Page 2
DDSUTL ;SFISC/MKO-PROGRAMMER UTILITIES ;11:37 AM 25 Jul 1995
+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 ;
MSG(TXT) ;
+1 ;Data validation messages
+2 DO PROC(.TXT,$NAME(@DDSREFT@("MSG")))
+3 QUIT
+4 ;
HLP(TXT) ;
+1 ;Help box messages
+2 DO PROC(.TXT,$NAME(@DDSREFT@("HLP")))
+3 QUIT
PROC(TXT,GLB) ;
+1 ;Put text into global
+2 NEW CNT,I
+3 SET CNT=$GET(@GLB)
+4 IF $DATA(TXT)<9
SET CNT=CNT+1
SET @GLB@(CNT)=TXT
+5 IF '$TEST
SET I=""
FOR CNT=CNT:1
SET I=$ORDER(TXT(I))
if I=""
QUIT
SET @GLB@(CNT+1)=TXT(I)
+6 SET @GLB=CNT
+7 QUIT
+8 ;
REFRESH ;Refresh the screen
+1 GOTO R^DDSR
+2 ;
MLOAD(DDSIEN) ;Load subrecords for current multiple
+1 GOTO MLOAD^DDSM1
+2 ;
MDEL(DDSIEN) ;Delete subrecords for current multiple
+1 GOTO MDEL^DDSM1
+2 ;
UNED(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change DISABLE EDITING attribute
+1 if $DATA(DDSVAL)[0
SET DDSVAL=""
+2 DO SETATT(4)
+3 QUIT
+4 ;
REQ(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change REQUIRED attribute
+1 if $DATA(DDSVAL)[0
SET DDSVAL=""
+2 DO SETATT(1)
+3 QUIT
+4 ;
+5 ;
SETATT(DDSUPC) ;Set attribute node, piece DDSUPC
+1 NEW DDSOVAL,DDSUDDP,DDSUFLD,DDSUTP
+2 IF $DATA(DDSPG)[0
NEW DDSPG
SET DDSPG=""
+3 IF $DATA(DDSBK)[0
NEW DDSBK
SET DDSBK=""
+4 SET DDSP=$$GETFLD^DDSLIB(DDSF,$GET(DDSB),$GET(DDSP),+DDS,DDSPG,DDSBK)
+5 IF $GET(DIERR)
DO ERR^DDSMSG
QUIT
+6 ;
+7 SET DDSF=$PIECE(DDSP,",")
SET DDSB=$PIECE(DDSP,",",2)
SET DDSP=$PIECE(DDSP,",",3)
+8 ;
+9 SET DDSUDDP=+$PIECE($GET(^DIST(.404,DDSB,0)),U,2)
+10 IF DDSUDDP
IF $GET(DDSUDA)]""
NEW DDSDA
SET DDSDA=DDSUDA
+11 IF '$TEST
IF DDSUDDP
IF DDSB'=DDSBK
NEW DDSDA
DO GL^DDS10(DDSUDDP,.DDSDAORG,"","",.DDSDA)
+12 ;
+13 SET DDSUTP=$PIECE($GET(^DIST(.404,DDSB,40,DDSF,0)),U,3)
if 'DDSUTP
SET DDSUTP=3
+14 IF DDSUTP=2
Begin DoDot:1
+15 SET DDSUFLD=DDSF_","_DDSB
+16 SET DDSUDDP=0
End DoDot:1
+17 IF '$TEST
IF DDSUTP=3
Begin DoDot:1
+18 SET DDSUFLD=$PIECE($GET(^DIST(.404,DDSB,40,DDSF,1)),U)
End DoDot:1
if 'DDSUFLD
QUIT
+19 IF '$TEST
QUIT
+20 ;
+21 SET DDSOVAL=$PIECE($GET(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A")),U,DDSUPC)
+22 if DDSVAL=DDSOVAL
QUIT
+23 SET $PIECE(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A"),U,DDSUPC)=DDSVAL
+24 QUIT
+25 ;
ADD(DDSFIL,X,DA,DINUM,DDSDIC0,DDSDR,DDSL) ;
+1 ;Add an entry as part of a transaction
+2 ;DDSL=1 means don't lock
+3 ;
+4 NEW %,%W,%Y,C,D0,DD,DO,DI,DIC,DIE,DQ,DR
+5 NEW DDSDA,DDSDIC,DDSFD,DDSREQ,DDSUP,I
+6 KILL DIERR,^TMP("DIERR",$JOB)
+7 if '$GET(DINUM)
KILL DINUM
+8 if $GET(DDSDIC0)=""
SET DDSDIC0="L"
+9 SET DIC(0)=DDSDIC0
SET Y=-1
+10 if $GET(DDSDR)]""
SET DIC("DR")=DDSDR
+11 SET DIC=$$ROOT^DILFD(DDSFIL,.DA)
SET DDSDIC=$$CREF^DIQGU(DIC)
+12 ;
+13 IF $DATA(@DDSDIC@(0))[0
Begin DoDot:1
+14 SET DDSUP=$GET(^DD(DDSFIL,0,"UP"))
if 'DDSUP
QUIT
+15 SET DDSFD=$ORDER(^DD(DDSUP,"SB",DDSFIL,""))
if 'DDSFD
QUIT
+16 SET DIC("P")=$PIECE($GET(^DD(DDSUP,DDSFD,0)),U,2)
End DoDot:1
if $GET(DIC("P"))=""
QUIT
+17 ;
+18 IF DDSDIC0'["E"
IF $$REQID(DDSFIL,.DDSREQ)
Begin DoDot:1
+19 NEW F
+20 SET F=""
+21 FOR
SET F=$ORDER(DDSREQ(F))
if 'F
QUIT
IF $GET(DIC("DR"))'[(F_"///")
DO BLD^DIALOG(3031,"ADD^DDSUTL")
QUIT
End DoDot:1
if $GET(DIERR)
QUIT
+22 ;
+23 DO FILE^DICN
KILL DTOUT,DUOUT
if Y=-1!'$DATA(DDS)
QUIT
+24 ;
+25 IF '$GET(DDSL)
Begin DoDot:1
+26 NEW I,L,R
+27 SET L=1
SET R=DIC_DA_","
+28 FOR I=$LENGTH(R,",")-1:-1:1
IF $DATA(^TMP("DDS",$JOB,"LOCK",$PIECE(R,",",1,I)_")"))#2
SET L=0
QUIT
+29 IF L
IF $DATA(^TMP("DDS",$JOB,"LOCK",$PIECE(R,"(")))#2
SET L=0
+30 IF L
LOCK +@(DIC_+Y_")"):0
SET ^TMP("DDS",$JOB,"LOCK",DIC_+Y_")")=""
End DoDot:1
+31 ;
+32 SET DDSDA=+Y_","
+33 FOR I=1:1
if $DATA(DA(I))[0
QUIT
SET DDSDA=DDSDA_DA(I)_","
+34 SET ^("ADD")=$GET(@DDSREFT@("ADD"))+1
SET ^("ADD",^("ADD"))=DDSDA_DIC
+35 QUIT
+36 ;
REQID(FIL,REQ) ;
+1 ;Get list of required identifiers into DDSREQ
+2 NEW F
+3 KILL REQ
+4 SET F=""
FOR
SET F=$ORDER(^DD(FIL,0,"ID",F))
if F'=+$PIECE(F,"E")
QUIT
Begin DoDot:1
+5 if $PIECE($GET(^DD(FIL,F,0)),U,2)["R"
SET REQ(F)=""
End DoDot:1
+6 QUIT $DATA(REQ)>0
+7 ;
DESTROY(PG) ;Destroy all data for page PG
+1 NEW P,B,F,IENS,TP,FIL,FLD
+2 SET P=$ORDER(^DIST(.403,+DDS,40,"B",PG,""))
if 'P
QUIT
+3 SET B=0
FOR
SET B=$ORDER(^DIST(.403,+DDS,40,P,40,B))
if 'B
QUIT
Begin DoDot:1
+4 if '$DATA(^DIST(.403,+DDS,40,P,40,B,0))
QUIT
+5 if '$DATA(^DIST(.404,B,0))
QUIT
SET FIL=$PIECE(^(0),U,2)
+6 SET F=0
FOR
SET F=$ORDER(^DIST(.404,B,40,F))
if 'F
QUIT
Begin DoDot:2
+7 if '$DATA(^DIST(.404,B,40,F,0))
QUIT
SET TP=$PIECE(^(0),U,3)
+8 if 'TP
SET TP=3
+9 ;
+10 IF TP=3
SET FF="F"_FIL
SET FLD=$GET(^DIST(.404,B,40,F,1))
if FLD?."^"
QUIT
+11 IF '$TEST
IF TP=2
SET FF="F0"
SET FLD=F_","_B
+12 IF '$TEST
QUIT
+13 ;
+14 SET IENS=" "
+15 FOR
SET IENS=$ORDER(@DDSREFT@(FF,IENS))
if IENS=""
QUIT
KILL ^(IENS,FLD)
End DoDot:2
End DoDot:1
+16 ;
+17 KILL @DDSREFT@(P),@DDSREFT@("XCAP",P)
+18 QUIT
+19 ;
+20 ;
DDSDA(DA,DL,DDSDA) ;Determine DDSDA
+1 ;
+2 NEW I
+3 IF DA=""
SET DDSDA=""
QUIT
+4 SET DDSDA=DA_","
FOR I=1:1:DL
SET DDSDA=DDSDA_DA(I)_","
+5 QUIT
