- 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 Dec 13, 2024@02:43:36 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