DDS4 ;SFISC/MKO-FILE AND RELOAD ;2015-01-02 5:46 PM
;;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.
;
D ^DDS41 Q:Y'=1
N DA,DDO,DIE,DDP,DDSDA
;
S DX=0,DY=IOSL-1 X IOXY W "Filing form"_$P(DDGLCLR,DDGLDEL)
;
;File data
S DDS4FI="F"
F S DDS4FI=$O(@DDSREFT@(DDS4FI)) Q:DDS4FI'?1"F".E D
. S DDP=$E(DDS4FI,2,999),DDS4DA=" "
. F S DDS4DA=$O(@DDSREFT@(DDS4FI,DDS4DA)) Q:DDS4DA="" D REC
;
;Reload all pages on form
S DDS4P=0
F S DDS4P=$O(@DDSREFT@(DDS4P)) Q:'DDS4P D
. S DDS4B=0
. F S DDS4B=$O(@DDSREFT@(DDS4P,DDS4B)) Q:'DDS4B D
.. S DDP=$P(@DDSREFS@(DDS4P,DDS4B),U,3),DDSDA=" "
.. F S DDSDA=$O(@DDSREFT@(DDS4P,DDS4B,DDSDA)) Q:'DDSDA D
... S $P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U)=1,DIE=^(DDSDA,"GL")
... Q:$P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U,6)>1
... D GDA(DDSDA)
... D EN^DDS11(DDS4B,1)
;
I $G(^DIST(.403,+DDS,14))'?."^" D
. I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D
.. S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_","
.. F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_","
.. S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE=""
. X ^DIST(.403,+DDS,14)
I '$G(DDSSAVE),$G(DDSPARM)["S" S DDSSAVE=1
S (Y,DDSH)=1,(DDSCHG,DX)=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL)
K @DDSREFT@("ADD"),@DDSREFT@("RXR")
K DIC,DDS1B,DDS1DA,DDS4B,DDS4DA,DDS4FI,DDS4FLD,DDS4FO,DDS4P
K DDSEXT,DDSI,DDSINT,DDSLC,DDSLN,DDSND,DDSOND,DDSOLD,DDSP,DDSPC
K DDSW,DDSX,DV
Q
;
;
REC ;
G:DDS4FI="F0" FORMONLY
;
S DIE=$G(@DDSREFT@(DDS4FI,DDS4DA,"GL")) I DIE="" Q ;JUST TO BE SAFE!
D GDA(DDS4DA)
S DDSOND=-1 K DDSLN
S DDS4FLD=""
F S DDS4FLD=$O(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD)) Q:DDS4FLD="" D FLD
S:$D(DDSLN)#2 @(DIE_"DA,DDSND)")=DDSLN
;
I $D(@DDSREFT@("RXR")) D
. D FIRE^DIKC(DDP,.DA,"KS",$NA(@DDSREFT@("RXR")),"O^")
. K @DDSREFT@("RXR")
Q
FLD ;
Q:'$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F")) S ^("F")=""
I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1
S DDSINT=$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D"))
;
;Word processing fields (quit if multiple)
I $D(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"M"))#2 D:'$P(^("M"),U) Q
WP .N FR,TO,DDS4M
.S DDS4M=^("M")
. S FR=$NA(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D"))
. S TO=U_$$CREF^DILF($P(DDS4M,U,2))
.I $P($G(^DD(+$P(DDS4M,U,3),.01,0)),U,2)["a" D WP^DIET($E(DDS4FI,2,99),DDS4FLD,DDS4DA,TO) ;AUDIT Word -Processing
. K @TO
. M @TO=@FR
. K @FR,@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F")
;
Q:$G(^DD(DDP,DDS4FLD,0))?."^" S DDSND=$P(^(0),U,4)
S DDSPC=$P(DDSND,";",2) Q:"0 "[DDSPC
S DDSND=$P(DDSND,";")
;
I DDSOND'=DDSND D
. S:$D(DDSLN)#2 @(DIE_"DA,DDSOND)")=DDSLN
. S DDSLN=$G(@(DIE_"DA,DDSND)"))
. S DDSOND=DDSND
;
I DDSPC D
. S DDSOLD=$P(DDSLN,U,DDSPC)
. S $P(DDSLN,U,DDSPC)=DDSINT
E D
. S DDSW=$E(DDSPC,2,999),DDSP=$P(DDSW,",",2)+1
. S DDSOLD=$E(DDSLN,+DDSW,DDSP-1)
. S DDSX=$E(DDSLN,DDSP,999)
. S DDSLN=$E(DDSLN,1,DDSW-1)_$J("",DDSW-1-$L(DDSLN))_DDSINT
. S:DDSX'?." " DDSLN=DDSLN_$J("",DDSP-DDSW-$L(DDSINT))_DDSX
;
I $D(^DD(DDP,DDS4FLD,1))!($P(^(0),U,2)["a")!$D(^DD("IX","F",DDP,DDS4FLD)) D XR
Q
XR ;
N DICRREC,DG,DP,DDS4AUD1,DDS4AUD2,DIANUM,DIIX,C,Y
S DP=DDP,DDSOND=-1
I $D(DDSLN)#2 S @(DIE_"DA,DDSND)")=DDSLN K DDSLN
S DICRREC="TRIG^DDS4"
;
I $P(^DD(DDP,DDS4FLD,0),U,2)["a" D
. S (DDS4AUD1,DDS4AUD2)=1
. I $G(^DD(DDP,DDS4FLD,"AUDIT"))["e",DDSOLD="" S DDS4AUD1=0
;
I DDSOLD]"" D
. S DG=0 F S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1 D ;YIKES! GOES THRU ALL CROSS-REFERENCES, EVEN IF NO CHANGE IN THE DATA!
.. S DIC=DIE,X=DDSOLD
.. X:$D(^DD(DDP,DDS4FLD,1,DG,2))#2 ^(2)
. I $G(DDS4AUD2) S DG=1,X=DDSOLD,DIIX="2^"_DDS4FLD D AUDIT^DIET
;
I DDSINT]"" D
. S DG=0 F S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1 D
.. S DIC=DIE,X=DDSINT
.. X:$D(^DD(DDP,DDS4FLD,1,DG,1))#2 ^(1)
. I $G(DDS4AUD1) S DG=1,X=DDSINT,DIIX="3^"_DDS4FLD D AUDIT^DIET
Q:'$D(^DD("IX","F",DDP,DDS4FLD))
;
;Process index file xrefs
N DDSFXR,DDSFXREF,DDSRXREF
D LOADFLD^DIKC1(DDP,DDS4FLD,"KS","",$NA(@DDSREFT@("F"))_"_","DDSFXR",$NA(@DDSREFT@("RXR")),.DDSFXREF,.DDSRXREF)
I $G(DDSRXREF)]""!($G(DDSFXREF)]"") D
. S @DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"O")=DDSOLD ;BRX-0404-11337
D:$G(DDSFXREF)]"" FIRE^DIKC(DDP,.DA,"KS","DDSFXR","O^")
Q
GDA(DDSDA) ;
N I
K DA S DA=$P(DDSDA,",")
F I=2:1:$L(DDSDA,",")-1 S DA(I-1)=$P(DDSDA,",",I)
Q
;
FORMONLY ;
N X
D GDA(DDS4DA)
S DDS4FLD=""
F S DDS4FLD=$O(@DDSREFT@("F0",DDS4DA,DDS4FLD)) Q:DDS4FLD="" D
. Q:'$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"F"))
. S DDS4FO=$P(DDS4FLD,","),DDS4B=$P(DDS4FLD,",",2)
. S DDSOLD=$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"O")),X=$G(^("D")),DDSEXT=$G(^("X"),X)
. X:$G(^DIST(.404,DDS4B,40,DDS4FO,23))'?."^" ^(23)
. S ^("O")=@DDSREFT@("F0",DDS4DA,DDS4FLD,"D"),^("F")=""
Q
;
TRIG ;Called from trigger logic (from DICR via DICRREC)
N DDSRXREF
D LOADFLD^DIKC1(DIH,DIG,"KS","",$NA(@DDSREFT@("F"))_"_","",$NA(@DDSREFT@("RXR")),"",.DDSRXREF)
I $G(DDSRXREF)]"",'$D(@DDSREFT@("F"_DIH,DICRIENS,DIG,"O")) S ^("O")=DIU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS4 5271 printed Dec 13, 2024@02:43:06 Page 2
DDS4 ;SFISC/MKO-FILE AND RELOAD ;2015-01-02 5:46 PM
+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 ;
+7 DO ^DDS41
if Y'=1
QUIT
+8 NEW DA,DDO,DIE,DDP,DDSDA
+9 ;
+10 SET DX=0
SET DY=IOSL-1
XECUTE IOXY
WRITE "Filing form"_$PIECE(DDGLCLR,DDGLDEL)
+11 ;
+12 ;File data
+13 SET DDS4FI="F"
+14 FOR
SET DDS4FI=$ORDER(@DDSREFT@(DDS4FI))
if DDS4FI'?1"F".E
QUIT
Begin DoDot:1
+15 SET DDP=$EXTRACT(DDS4FI,2,999)
SET DDS4DA=" "
+16 FOR
SET DDS4DA=$ORDER(@DDSREFT@(DDS4FI,DDS4DA))
if DDS4DA=""
QUIT
DO REC
End DoDot:1
+17 ;
+18 ;Reload all pages on form
+19 SET DDS4P=0
+20 FOR
SET DDS4P=$ORDER(@DDSREFT@(DDS4P))
if 'DDS4P
QUIT
Begin DoDot:1
+21 SET DDS4B=0
+22 FOR
SET DDS4B=$ORDER(@DDSREFT@(DDS4P,DDS4B))
if 'DDS4B
QUIT
Begin DoDot:2
+23 SET DDP=$PIECE(@DDSREFS@(DDS4P,DDS4B),U,3)
SET DDSDA=" "
+24 FOR
SET DDSDA=$ORDER(@DDSREFT@(DDS4P,DDS4B,DDSDA))
if 'DDSDA
QUIT
Begin DoDot:3
+25 SET $PIECE(@DDSREFT@(DDS4P,DDS4B,DDSDA),U)=1
SET DIE=^(DDSDA,"GL")
+26 if $PIECE(@DDSREFT@(DDS4P,DDS4B,DDSDA),U,6)>1
QUIT
+27 DO GDA(DDSDA)
+28 DO EN^DDS11(DDS4B,1)
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 IF $GET(^DIST(.403,+DDS,14))'?."^"
Begin DoDot:1
+31 IF $GET(DDSPTB)_$GET(DDSREP)]""
NEW DIE,DDP,DDSDA,DA,DDSDL
Begin DoDot:2
+32 SET DA=DDSDAORG
SET DDSDL=DDSDLORG
SET DDSDA=DA_","
+33 FOR DDSI=1:1:DDSDL
SET DA(DDSI)=DDSDAORG(DDSI)
SET DDSDA=DDSDA_DA(DDSI)_","
+34 SET DDP=$PIECE($GET(DDSFLORG),U)
SET DIE=U_$PIECE($GET(DDSFLORG),U,2)
if DIE=U
SET DIE=""
End DoDot:2
+35 XECUTE ^DIST(.403,+DDS,14)
End DoDot:1
+36 IF '$GET(DDSSAVE)
IF $GET(DDSPARM)["S"
SET DDSSAVE=1
+37 SET (Y,DDSH)=1
SET (DDSCHG,DX)=0
SET DY=IOSL-1
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
+38 KILL @DDSREFT@("ADD"),@DDSREFT@("RXR")
+39 KILL DIC,DDS1B,DDS1DA,DDS4B,DDS4DA,DDS4FI,DDS4FLD,DDS4FO,DDS4P
+40 KILL DDSEXT,DDSI,DDSINT,DDSLC,DDSLN,DDSND,DDSOND,DDSOLD,DDSP,DDSPC
+41 KILL DDSW,DDSX,DV
+42 QUIT
+43 ;
+44 ;
REC ;
+1 if DDS4FI="F0"
GOTO FORMONLY
+2 ;
+3 ;JUST TO BE SAFE!
SET DIE=$GET(@DDSREFT@(DDS4FI,DDS4DA,"GL"))
IF DIE=""
QUIT
+4 DO GDA(DDS4DA)
+5 SET DDSOND=-1
KILL DDSLN
+6 SET DDS4FLD=""
+7 FOR
SET DDS4FLD=$ORDER(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD))
if DDS4FLD=""
QUIT
DO FLD
+8 if $DATA(DDSLN)#2
SET @(DIE_"DA,DDSND)")=DDSLN
+9 ;
+10 IF $DATA(@DDSREFT@("RXR"))
Begin DoDot:1
+11 DO FIRE^DIKC(DDP,.DA,"KS",$NAME(@DDSREFT@("RXR")),"O^")
+12 KILL @DDSREFT@("RXR")
End DoDot:1
+13 QUIT
FLD ;
+1 if '$GET(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F"))
QUIT
SET ^("F")=""
+2 IF '$GET(DDSCHANG)
IF $GET(DDSPARM)["C"
SET DDSCHANG=1
+3 SET DDSINT=$GET(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D"))
+4 ;
+5 ;Word processing fields (quit if multiple)
+6 IF $DATA(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"M"))#2
if '$PIECE(^("M"),U)
Begin DoDot:1
WP NEW FR,TO,DDS4M
+1 SET DDS4M=^("M")
+2 SET FR=$NAME(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D"))
+3 SET TO=U_$$CREF^DILF($PIECE(DDS4M,U,2))
+4 ;AUDIT Word -Processing
IF $PIECE($GET(^DD(+$PIECE(DDS4M,U,3),.01,0)),U,2)["a"
DO WP^DIET($EXTRACT(DDS4FI,2,99),DDS4FLD,DDS4DA,TO)
+5 KILL @TO
+6 MERGE @TO=@FR
+7 KILL @FR,@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F")
End DoDot:1
QUIT
+8 ;
+9 if $GET(^DD(DDP,DDS4FLD,0))?."^"
QUIT
SET DDSND=$PIECE(^(0),U,4)
+10 SET DDSPC=$PIECE(DDSND,";",2)
if "0 "[DDSPC
QUIT
+11 SET DDSND=$PIECE(DDSND,";")
+12 ;
+13 IF DDSOND'=DDSND
Begin DoDot:1
+14 if $DATA(DDSLN)#2
SET @(DIE_"DA,DDSOND)")=DDSLN
+15 SET DDSLN=$GET(@(DIE_"DA,DDSND)"))
+16 SET DDSOND=DDSND
End DoDot:1
+17 ;
+18 IF DDSPC
Begin DoDot:1
+19 SET DDSOLD=$PIECE(DDSLN,U,DDSPC)
+20 SET $PIECE(DDSLN,U,DDSPC)=DDSINT
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 SET DDSW=$EXTRACT(DDSPC,2,999)
SET DDSP=$PIECE(DDSW,",",2)+1
+23 SET DDSOLD=$EXTRACT(DDSLN,+DDSW,DDSP-1)
+24 SET DDSX=$EXTRACT(DDSLN,DDSP,999)
+25 SET DDSLN=$EXTRACT(DDSLN,1,DDSW-1)_$JUSTIFY("",DDSW-1-$LENGTH(DDSLN))_DDSINT
+26 if DDSX'?." "
SET DDSLN=DDSLN_$JUSTIFY("",DDSP-DDSW-$LENGTH(DDSINT))_DDSX
End DoDot:1
+27 ;
+28 IF $DATA(^DD(DDP,DDS4FLD,1))!($PIECE(^(0),U,2)["a")!$DATA(^DD("IX","F",DDP,DDS4FLD))
DO XR
+29 QUIT
XR ;
+1 NEW DICRREC,DG,DP,DDS4AUD1,DDS4AUD2,DIANUM,DIIX,C,Y
+2 SET DP=DDP
SET DDSOND=-1
+3 IF $DATA(DDSLN)#2
SET @(DIE_"DA,DDSND)")=DDSLN
KILL DDSLN
+4 SET DICRREC="TRIG^DDS4"
+5 ;
+6 IF $PIECE(^DD(DDP,DDS4FLD,0),U,2)["a"
Begin DoDot:1
+7 SET (DDS4AUD1,DDS4AUD2)=1
+8 IF $GET(^DD(DDP,DDS4FLD,"AUDIT"))["e"
IF DDSOLD=""
SET DDS4AUD1=0
End DoDot:1
+9 ;
+10 IF DDSOLD]""
Begin DoDot:1
+11 ;YIKES! GOES THRU ALL CROSS-REFERENCES, EVEN IF NO CHANGE IN THE DATA!
SET DG=0
FOR
SET DG=$ORDER(^DD(DDP,DDS4FLD,1,DG))
if DG<1
QUIT
Begin DoDot:2
+12 SET DIC=DIE
SET X=DDSOLD
+13 if $DATA(^DD(DDP,DDS4FLD,1,DG,2))#2
XECUTE ^(2)
End DoDot:2
+14 IF $GET(DDS4AUD2)
SET DG=1
SET X=DDSOLD
SET DIIX="2^"_DDS4FLD
DO AUDIT^DIET
End DoDot:1
+15 ;
+16 IF DDSINT]""
Begin DoDot:1
+17 SET DG=0
FOR
SET DG=$ORDER(^DD(DDP,DDS4FLD,1,DG))
if DG<1
QUIT
Begin DoDot:2
+18 SET DIC=DIE
SET X=DDSINT
+19 if $DATA(^DD(DDP,DDS4FLD,1,DG,1))#2
XECUTE ^(1)
End DoDot:2
+20 IF $GET(DDS4AUD1)
SET DG=1
SET X=DDSINT
SET DIIX="3^"_DDS4FLD
DO AUDIT^DIET
End DoDot:1
+21 if '$DATA(^DD("IX","F",DDP,DDS4FLD))
QUIT
+22 ;
+23 ;Process index file xrefs
+24 NEW DDSFXR,DDSFXREF,DDSRXREF
+25 DO LOADFLD^DIKC1(DDP,DDS4FLD,"KS","",$NAME(@DDSREFT@("F"))_"_","DDSFXR",$NAME(@DDSREFT@("RXR")),.DDSFXREF,.DDSRXREF)
+26 IF $GET(DDSRXREF)]""!($GET(DDSFXREF)]"")
Begin DoDot:1
+27 ;BRX-0404-11337
SET @DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"O")=DDSOLD
End DoDot:1
+28 if $GET(DDSFXREF)]""
DO FIRE^DIKC(DDP,.DA,"KS","DDSFXR","O^")
+29 QUIT
GDA(DDSDA) ;
+1 NEW I
+2 KILL DA
SET DA=$PIECE(DDSDA,",")
+3 FOR I=2:1:$LENGTH(DDSDA,",")-1
SET DA(I-1)=$PIECE(DDSDA,",",I)
+4 QUIT
+5 ;
FORMONLY ;
+1 NEW X
+2 DO GDA(DDS4DA)
+3 SET DDS4FLD=""
+4 FOR
SET DDS4FLD=$ORDER(@DDSREFT@("F0",DDS4DA,DDS4FLD))
if DDS4FLD=""
QUIT
Begin DoDot:1
+5 if '$GET(@DDSREFT@("F0",DDS4DA,DDS4FLD,"F"))
QUIT
+6 SET DDS4FO=$PIECE(DDS4FLD,",")
SET DDS4B=$PIECE(DDS4FLD,",",2)
+7 SET DDSOLD=$GET(@DDSREFT@("F0",DDS4DA,DDS4FLD,"O"))
SET X=$GET(^("D"))
SET DDSEXT=$GET(^("X"),X)
+8 if $GET(^DIST(.404,DDS4B,40,DDS4FO,23))'?."^"
XECUTE ^(23)
+9 SET ^("O")=@DDSREFT@("F0",DDS4DA,DDS4FLD,"D")
SET ^("F")=""
End DoDot:1
+10 QUIT
+11 ;
TRIG ;Called from trigger logic (from DICR via DICRREC)
+1 NEW DDSRXREF
+2 DO LOADFLD^DIKC1(DIH,DIG,"KS","",$NAME(@DDSREFT@("F"))_"_","",$NAME(@DDSREFT@("RXR")),"",.DDSRXREF)
+3 IF $GET(DDSRXREF)]""
IF '$DATA(@DDSREFT@("F"_DIH,DICRIENS,DIG,"O"))
SET ^("O")=DIU
+4 QUIT
