Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDSUTL

DDSUTL.m

Go to the documentation of this file.
  1. DDSUTL ;SFISC/MKO-PROGRAMMER UTILITIES ;11:37 AM 25 Jul 1995
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. MSG(TXT) ;
  1. ;Data validation messages
  1. D PROC(.TXT,$NA(@DDSREFT@("MSG")))
  1. Q
  1. ;
  1. HLP(TXT) ;
  1. ;Help box messages
  1. D PROC(.TXT,$NA(@DDSREFT@("HLP")))
  1. Q
  1. PROC(TXT,GLB) ;
  1. ;Put text into global
  1. N CNT,I
  1. S CNT=$G(@GLB)
  1. I $D(TXT)<9 S CNT=CNT+1,@GLB@(CNT)=TXT
  1. E S I="" F CNT=CNT:1 S I=$O(TXT(I)) Q:I="" S @GLB@(CNT+1)=TXT(I)
  1. S @GLB=CNT
  1. Q
  1. ;
  1. REFRESH ;Refresh the screen
  1. G R^DDSR
  1. ;
  1. MLOAD(DDSIEN) ;Load subrecords for current multiple
  1. G MLOAD^DDSM1
  1. ;
  1. MDEL(DDSIEN) ;Delete subrecords for current multiple
  1. G MDEL^DDSM1
  1. ;
  1. UNED(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change DISABLE EDITING attribute
  1. S:$D(DDSVAL)[0 DDSVAL=""
  1. D SETATT(4)
  1. Q
  1. ;
  1. REQ(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change REQUIRED attribute
  1. S:$D(DDSVAL)[0 DDSVAL=""
  1. D SETATT(1)
  1. Q
  1. ;
  1. ;
  1. SETATT(DDSUPC) ;Set attribute node, piece DDSUPC
  1. N DDSOVAL,DDSUDDP,DDSUFLD,DDSUTP
  1. I $D(DDSPG)[0 N DDSPG S DDSPG=""
  1. I $D(DDSBK)[0 N DDSBK S DDSBK=""
  1. S DDSP=$$GETFLD^DDSLIB(DDSF,$G(DDSB),$G(DDSP),+DDS,DDSPG,DDSBK)
  1. I $G(DIERR) D ERR^DDSMSG Q
  1. ;
  1. S DDSF=$P(DDSP,","),DDSB=$P(DDSP,",",2),DDSP=$P(DDSP,",",3)
  1. ;
  1. S DDSUDDP=+$P($G(^DIST(.404,DDSB,0)),U,2)
  1. I DDSUDDP,$G(DDSUDA)]"" N DDSDA S DDSDA=DDSUDA
  1. E I DDSUDDP,DDSB'=DDSBK N DDSDA D GL^DDS10(DDSUDDP,.DDSDAORG,"","",.DDSDA)
  1. ;
  1. S DDSUTP=$P($G(^DIST(.404,DDSB,40,DDSF,0)),U,3) S:'DDSUTP DDSUTP=3
  1. I DDSUTP=2 D
  1. . S DDSUFLD=DDSF_","_DDSB
  1. . S DDSUDDP=0
  1. E I DDSUTP=3 D Q:'DDSUFLD
  1. . S DDSUFLD=$P($G(^DIST(.404,DDSB,40,DDSF,1)),U)
  1. E Q
  1. ;
  1. S DDSOVAL=$P($G(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A")),U,DDSUPC)
  1. Q:DDSVAL=DDSOVAL
  1. S $P(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A"),U,DDSUPC)=DDSVAL
  1. Q
  1. ;
  1. ADD(DDSFIL,X,DA,DINUM,DDSDIC0,DDSDR,DDSL) ;
  1. ;Add an entry as part of a transaction
  1. ;DDSL=1 means don't lock
  1. ;
  1. N %,%W,%Y,C,D0,DD,DO,DI,DIC,DIE,DQ,DR
  1. N DDSDA,DDSDIC,DDSFD,DDSREQ,DDSUP,I
  1. K DIERR,^TMP("DIERR",$J)
  1. K:'$G(DINUM) DINUM
  1. S:$G(DDSDIC0)="" DDSDIC0="L"
  1. S DIC(0)=DDSDIC0,Y=-1
  1. S:$G(DDSDR)]"" DIC("DR")=DDSDR
  1. S DIC=$$ROOT^DILFD(DDSFIL,.DA),DDSDIC=$$CREF^DIQGU(DIC)
  1. ;
  1. I $D(@DDSDIC@(0))[0 D Q:$G(DIC("P"))=""
  1. . S DDSUP=$G(^DD(DDSFIL,0,"UP")) Q:'DDSUP
  1. . S DDSFD=$O(^DD(DDSUP,"SB",DDSFIL,"")) Q:'DDSFD
  1. . S DIC("P")=$P($G(^DD(DDSUP,DDSFD,0)),U,2)
  1. ;
  1. I DDSDIC0'["E",$$REQID(DDSFIL,.DDSREQ) D Q:$G(DIERR)
  1. . N F
  1. . S F=""
  1. . F S F=$O(DDSREQ(F)) Q:'F I $G(DIC("DR"))'[(F_"///") D BLD^DIALOG(3031,"ADD^DDSUTL") Q
  1. ;
  1. D FILE^DICN K DTOUT,DUOUT Q:Y=-1!'$D(DDS)
  1. ;
  1. I '$G(DDSL) D
  1. . N I,L,R
  1. . S L=1,R=DIC_DA_","
  1. . F I=$L(R,",")-1:-1:1 I $D(^TMP("DDS",$J,"LOCK",$P(R,",",1,I)_")"))#2 S L=0 Q
  1. . I L,$D(^TMP("DDS",$J,"LOCK",$P(R,"(")))#2 S L=0
  1. . I L L +@(DIC_+Y_")"):0 S ^TMP("DDS",$J,"LOCK",DIC_+Y_")")=""
  1. ;
  1. S DDSDA=+Y_","
  1. F I=1:1 Q:$D(DA(I))[0 S DDSDA=DDSDA_DA(I)_","
  1. S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIC
  1. Q
  1. ;
  1. REQID(FIL,REQ) ;
  1. ;Get list of required identifiers into DDSREQ
  1. N F
  1. K REQ
  1. S F="" F S F=$O(^DD(FIL,0,"ID",F)) Q:F'=+$P(F,"E") D
  1. . S:$P($G(^DD(FIL,F,0)),U,2)["R" REQ(F)=""
  1. Q $D(REQ)>0
  1. ;
  1. DESTROY(PG) ;Destroy all data for page PG
  1. N P,B,F,IENS,TP,FIL,FLD
  1. S P=$O(^DIST(.403,+DDS,40,"B",PG,"")) Q:'P
  1. S B=0 F S B=$O(^DIST(.403,+DDS,40,P,40,B)) Q:'B D
  1. . Q:'$D(^DIST(.403,+DDS,40,P,40,B,0))
  1. . Q:'$D(^DIST(.404,B,0)) S FIL=$P(^(0),U,2)
  1. . S F=0 F S F=$O(^DIST(.404,B,40,F)) Q:'F D
  1. .. Q:'$D(^DIST(.404,B,40,F,0)) S TP=$P(^(0),U,3)
  1. .. S:'TP TP=3
  1. .. ;
  1. .. I TP=3 S FF="F"_FIL,FLD=$G(^DIST(.404,B,40,F,1)) Q:FLD?."^"
  1. .. E I TP=2 S FF="F0",FLD=F_","_B
  1. .. E Q
  1. .. ;
  1. .. S IENS=" "
  1. .. F S IENS=$O(@DDSREFT@(FF,IENS)) Q:IENS="" K ^(IENS,FLD)
  1. ;
  1. K @DDSREFT@(P),@DDSREFT@("XCAP",P)
  1. Q
  1. ;
  1. ;
  1. DDSDA(DA,DL,DDSDA) ;Determine DDSDA
  1. ;
  1. N I
  1. I DA="" S DDSDA="" Q
  1. S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_","
  1. Q