DDS1(DDSPG) ;SFISC/MKO-LOAD PAGE ;11:25 AM 4 Aug 1998
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;Input:
; DDS = Form number^Form name
; DDSPG = Internal page number
; DA = Record array
; DDSREFT = Global location where data (temporarily) is stored
; DDP = Primary file number of form
; DIE = Global root of form
; DDSDA = DA,DA(1),... of form
; DDSDL = Level number
;Also needed for pointed-to blocks:
; DDSDAORG
; DDSDLORG
;Returns:
; DIERR
;
S U="^"
;
;Get header block
S DDS1B=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,2)
I DDS1B]"" D BLK(DDSPG,DDS1B,"",1) G:$G(DIERR) END
;
;Get all other blocks on page
S DDS1BO="" F S DDS1BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",DDS1BO)) Q:DDS1BO="" S DDS1B=$O(^(DDS1BO,0)) Q:'DDS1B D BLK(DDSPG,DDS1B,DDS1BO) G:$G(DIERR) END
;
END K DDS1B,DDS1BO
Q
;
BLK(DDSPG,DDS1B,DDS1BO,DDS1H,DDS1E) ;Load block
;In: DDS1H = 1 if a header block
; DDS1E = 1 if we're loading up a pointed-to block and
; we want interactive dialog (DIC(0)["E") in the lookup
;
I $D(^DIST(.404,DDS1B,0))[0 D BLD^DIALOG(3051,"#"_DDS1B) Q
;
N DDS1PTB,DDS1REP S DDS1PTB=""
I '$G(DDS1H) D
. S DDS1PTB=$G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,1)),DDS1REP=$G(^(2))
. K:DDS1REP<2 DDS1REP
;
I DDS1PTB]"" N @$$D0(DDSDL),DA,DDP,DIE,DDSDL,DDSDA D Q:$G(DIERR)
. I $G(DDS1REP)>1 D
.. D BK^DDS10(.DDS1B,.DDP) Q:$G(DIERR)
.. D GDA^DDS10(DDS1B,$G(DDS1E),.DA) Q:$G(DIERR)
.. S DDP=$G(^DD(DDP,0,"UP"))
.. D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1)
.. D GETD0(.DA,DDSDL)
. E D
.. D SET^DDS10(DDS1B,$G(DDS1E),.DA,.DDP,.DIE,.DDSDL,.DDSDA)
.. I +$G(DIERR)=1,$G(^TMP("DIERR",$J,1))=601 D Q
... L -@(DIE_DA_")")
... K ^TMP("DDS",$J,"LOCK",DIE_DA_")")
... D CLEAN^DILF
... S (DA,D0,DDSDA)=""
.. Q:$G(DIERR)
.. I DA="",'$G(DDS1E),$P($G(@DDSREFT@(DDSPG,DDS1B)),U)]"" S DDSDA=$P(^(DDS1B),U),DA=+DDSDA
.. S D0=DA
;
I $G(DA)!'$G(DDSDAORG),$G(@DDSREFT@(DDSPG,DDS1B,DDSDA))<1 D
. S $P(@DDSREFT@(DDSPG,DDS1B,DDSDA),U)=1
. I $G(DDS1REP)>1 D REP Q
. ;
. S @DDSREFT@(DDSPG,DDS1B,DDSDA,"GL")=DIE
. D ^DDS11(DDS1B)
;
S $P(@DDSREFT@(DDSPG,DDS1B),U)=$G(DDSDA)
Q
;
REP ;Load data for repeating block
N DDS1DDP,DDS1IND,DDS1INI,DDS1MUL,DDS1PDA,DDS1REF,DDS1RT,DDS1SEL
N DDS1SN,DDS1VAL,DDS1FSCR,DDS1SCNT,DDS1STRT,DDS1Q
S DDS1REF=$NA(@DDSREFT@(DDSPG,DDS1B))
S DDS1DDP=$P(@DDSREFS@(DDSPG,DDS1B),U,3)
S DDS1IND=$P(DDS1REP,U,2) S:DDS1IND="" DDS1IND="B"
S DDS1INI=$P(DDS1REP,U,3)
S DDS1SEL=$P(@DDSREFS@(DDSPG,DDS1B),U,10)
S DDS1PDA=DDSDA
;
S DDS1MUL=$O(^DD(DDP,"SB",DDS1DDP,""))
S:$G(^DD(DDS1DDP,0,"SCR"))]"" DDS1FSCR=^("SCR")
;
S $P(@DDS1REF@(DDS1PDA),U,7,10)=DDP_U_DDS1MUL_U_DDS1SEL_U_DDS1IND
S @DDS1REF@(DDSDA,"GL")=$S(DDS1MUL:DIE_+DA_","""_$P($P(^DD(DDP,DDS1MUL,0),U,4),";")_""",",1:^DIC(DDS1DDP,0,"GL"))
;
N DIE,DDP
S DIE=@DDS1REF@(DDSDA,"GL"),DDS1RT=$$CREF^DILF(DIE),DDP=DDS1DDP
S DDS1SN=0
;
I DDS1MUL D
. D DDA^DDS5(0,.DA,.DDSDL)
. S DDSDA=","_DDSDA
. S:'$D(@DDS1RT@(DDS1IND)) DDS1IND="!IEN"
. I DDS1IND="!IEN" D
.. S DA=0 F S DA=$O(@DDS1RT@(DA)) Q:'DA D REPLD
. E D
.. S (DDS1Q,DDS1STRT)=$NA(@DDS1RT@(DDS1IND)),DDS1SCNT=$QL(DDS1Q)
.. F S DDS1Q=$Q(@DDS1Q) Q:DDS1Q="" Q:$NA(@DDS1Q,DDS1SCNT)'=DDS1STRT D
... S DA=$QS(DDS1Q,$QL(DDS1Q)) D REPLD
;
E S DDS1VAL=DA N D0,DA,DDSDA D
. S DDSDA=","
. S (DDS1Q,DDS1STRT)=$NA(@DDS1RT@(DDS1IND,DDS1VAL)),DDS1SCNT=$QL(DDS1Q)
. F S DDS1Q=$Q(@DDS1Q) Q:DDS1Q="" Q:$NA(@DDS1Q,DDS1SCNT)'=DDS1STRT D
.. S DA=$QS(DDS1Q,$QL(DDS1Q)) D REPLD
;
I DDS1INI="l"!(DDS1INI="n") D
. N N,T
. S N=DDS1INI="n"
. S DDS1SN=$O(@DDS1REF@(DDS1PDA," "),-1)+N
. S T=DDS1SN-DDS1REP+2-N
. S DDS1INI=$S(T<1:1_U_DDS1SN,1:T_U_(DDS1REP-'N))_U_DDS1SN
E S DDS1INI="1^1^1"
;
S $P(@DDS1REF@(DDS1PDA),U,2,6)=DDS1PDA_U_DDS1INI_U_+DDS1REP
;
I DDS1MUL D
. D UDA^DDS5(.DA,.DDSDL)
. S DDSDA=$P(DDSDA,",",2,999)
Q
;
REPLD ;Load data
Q:'$D(@DDS1RT@(DA,0)) I $D(DDS1FSCR) N Y S Y=DA X DDS1FSCR Q:'$T
S DDS1SN=DDS1SN+1,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA
S @DDS1REF@(DDS1PDA,DDS1SN)=DDSDA
S @DDS1REF@(DDS1PDA,"B",DDSDA)=DDS1SN
D ^DDS11(DDS1B)
Q
;
D0(DL) ;Given DL, return string D0,D1,...,Dn
N I,S
S S="" F I=0:1:DL S S=S_"D"_I_","
S:S?.E1"," S=$E(S,1,$L(S)-1)
Q S
;
GETD0(DA,DL) ;Given DA array, set D0,D1...
N I
S @("D"_DL)=DA
F I=1:1:DL-1 S @("D"_(DL-I))=DA(I)
Q
DDS1(DDSPG) ;SFISC/MKO-LOAD PAGE ;11:25 AM 4 Aug 1998
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;Input:
+4 ; DDS = Form number^Form name
+5 ; DDSPG = Internal page number
+6 ; DA = Record array
+7 ; DDSREFT = Global location where data (temporarily) is stored
+8 ; DDP = Primary file number of form
+9 ; DIE = Global root of form
+10 ; DDSDA = DA,DA(1),... of form
+11 ; DDSDL = Level number
+12 ;Also needed for pointed-to blocks:
+13 ; DDSDAORG
+14 ; DDSDLORG
+15 ;Returns:
+16 ; DIERR
+17 ;
+18 SET U="^"
+19 ;
+20 ;Get header block
+21 SET DDS1B=$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U,2)
+22 IF DDS1B]""
DO BLK(DDSPG,DDS1B,"",1)
IF $GET(DIERR)
GOTO END
+23 ;
+24 ;Get all other blocks on page
+25 SET DDS1BO=""
FOR
SET DDS1BO=$ORDER(^DIST(.403,+DDS,40,DDSPG,40,"AC",DDS1BO))
IF DDS1BO=""
QUIT
SET DDS1B=$ORDER(^(DDS1BO,0))
IF 'DDS1B
QUIT
DO BLK(DDSPG,DDS1B,DDS1BO)
IF $GET(DIERR)
GOTO END
+26 ;
END KILL DDS1B,DDS1BO
+1 QUIT
+2 ;
BLK(DDSPG,DDS1B,DDS1BO,DDS1H,DDS1E) ;Load block
+1 ;In: DDS1H = 1 if a header block
+2 ; DDS1E = 1 if we're loading up a pointed-to block and
+3 ; we want interactive dialog (DIC(0)["E") in the lookup
+4 ;
+5 IF $DATA(^DIST(.404,DDS1B,0))[0
DO BLD^DIALOG(3051,"#"_DDS1B)
QUIT
+6 ;
+7 NEW DDS1PTB,DDS1REP
SET DDS1PTB=""
+8 IF '$GET(DDS1H)
Begin DoDot:1
+9 SET DDS1PTB=$GET(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,1))
SET DDS1REP=$GET(^(2))
+10 IF DDS1REP<2
KILL DDS1REP
End DoDot:1
+11 ;
+12 IF DDS1PTB]""
NEW @$$D0(DDSDL),DA,DDP,DIE,DDSDL,DDSDA
Begin DoDot:1
+13 IF $GET(DDS1REP)>1
Begin DoDot:2
+14 DO BK^DDS10(.DDS1B,.DDP)
IF $GET(DIERR)
QUIT
+15 DO GDA^DDS10(DDS1B,$GET(DDS1E),.DA)
IF $GET(DIERR)
QUIT
+16 SET DDP=$GET(^DD(DDP,0,"UP"))
+17 DO GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1)
+18 DO GETD0(.DA,DDSDL)
End DoDot:2
+19 IF '$TEST
Begin DoDot:2
+20 DO SET^DDS10(DDS1B,$GET(DDS1E),.DA,.DDP,.DIE,.DDSDL,.DDSDA)
+21 IF +$GET(DIERR)=1
IF $GET(^TMP("DIERR",$JOB,1))=601
Begin DoDot:3
+22 LOCK -@(DIE_DA_")")
+23 KILL ^TMP("DDS",$JOB,"LOCK",DIE_DA_")")
+24 DO CLEAN^DILF
+25 SET (DA,D0,DDSDA)=""
End DoDot:3
QUIT
+26 IF $GET(DIERR)
QUIT
+27 IF DA=""
IF '$GET(DDS1E)
IF $PIECE($GET(@DDSREFT@(DDSPG,DDS1B)),U)]""
SET DDSDA=$PIECE(^(DDS1B),U)
SET DA=+DDSDA
+28 SET D0=DA
End DoDot:2
End DoDot:1
IF $GET(DIERR)
QUIT
+29 ;
+30 IF $GET(DA)!'$GET(DDSDAORG)
IF $GET(@DDSREFT@(DDSPG,DDS1B,DDSDA))<1
Begin DoDot:1
+31 SET $PIECE(@DDSREFT@(DDSPG,DDS1B,DDSDA),U)=1
+32 IF $GET(DDS1REP)>1
DO REP
QUIT
+33 ;
+34 SET @DDSREFT@(DDSPG,DDS1B,DDSDA,"GL")=DIE
+35 DO ^DDS11(DDS1B)
End DoDot:1
+36 ;
+37 SET $PIECE(@DDSREFT@(DDSPG,DDS1B),U)=$GET(DDSDA)
+38 QUIT
+39 ;
REP ;Load data for repeating block
+1 NEW DDS1DDP,DDS1IND,DDS1INI,DDS1MUL,DDS1PDA,DDS1REF,DDS1RT,DDS1SEL
+2 NEW DDS1SN,DDS1VAL,DDS1FSCR,DDS1SCNT,DDS1STRT,DDS1Q
+3 SET DDS1REF=$NAME(@DDSREFT@(DDSPG,DDS1B))
+4 SET DDS1DDP=$PIECE(@DDSREFS@(DDSPG,DDS1B),U,3)
+5 SET DDS1IND=$PIECE(DDS1REP,U,2)
IF DDS1IND=""
SET DDS1IND="B"
+6 SET DDS1INI=$PIECE(DDS1REP,U,3)
+7 SET DDS1SEL=$PIECE(@DDSREFS@(DDSPG,DDS1B),U,10)
+8 SET DDS1PDA=DDSDA
+9 ;
+10 SET DDS1MUL=$ORDER(^DD(DDP,"SB",DDS1DDP,""))
+11 IF $GET(^DD(DDS1DDP,0,"SCR"))]""
SET DDS1FSCR=^("SCR")
+12 ;
+13 SET $PIECE(@DDS1REF@(DDS1PDA),U,7,10)=DDP_U_DDS1MUL_U_DDS1SEL_U_DDS1IND
+14 SET @DDS1REF@(DDSDA,"GL")=$SELECT(DDS1MUL:DIE_+DA_","""_$PIECE($PIECE(^DD(DDP,DDS1MUL,0),U,4),";")_""",",1:^DIC(DDS1DDP,0,"GL"))
+15 ;
+16 NEW DIE,DDP
+17 SET DIE=@DDS1REF@(DDSDA,"GL")
SET DDS1RT=$$CREF^DILF(DIE)
SET DDP=DDS1DDP
+18 SET DDS1SN=0
+19 ;
+20 IF DDS1MUL
Begin DoDot:1
+21 DO DDA^DDS5(0,.DA,.DDSDL)
+22 SET DDSDA=","_DDSDA
+23 IF '$DATA(@DDS1RT@(DDS1IND))
SET DDS1IND="!IEN"
+24 IF DDS1IND="!IEN"
Begin DoDot:2
+25 SET DA=0
FOR
SET DA=$ORDER(@DDS1RT@(DA))
IF 'DA
QUIT
DO REPLD
End DoDot:2
+26 IF '$TEST
Begin DoDot:2
+27 SET (DDS1Q,DDS1STRT)=$NAME(@DDS1RT@(DDS1IND))
SET DDS1SCNT=$QLENGTH(DDS1Q)
+28 FOR
SET DDS1Q=$QUERY(@DDS1Q)
IF DDS1Q=""
QUIT
IF $NAME(@DDS1Q,DDS1SCNT)'=DDS1STRT
QUIT
Begin DoDot:3
+29 SET DA=$QSUBSCRIPT(DDS1Q,$QLENGTH(DDS1Q))
DO REPLD
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 IF '$TEST
SET DDS1VAL=DA
NEW D0,DA,DDSDA
Begin DoDot:1
+32 SET DDSDA=","
+33 SET (DDS1Q,DDS1STRT)=$NAME(@DDS1RT@(DDS1IND,DDS1VAL))
SET DDS1SCNT=$QLENGTH(DDS1Q)
+34 FOR
SET DDS1Q=$QUERY(@DDS1Q)
IF DDS1Q=""
QUIT
IF $NAME(@DDS1Q,DDS1SCNT)'=DDS1STRT
QUIT
Begin DoDot:2
+35 SET DA=$QSUBSCRIPT(DDS1Q,$QLENGTH(DDS1Q))
DO REPLD
End DoDot:2
End DoDot:1
+36 ;
+37 IF DDS1INI="l"!(DDS1INI="n")
Begin DoDot:1
+38 NEW N,T
+39 SET N=DDS1INI="n"
+40 SET DDS1SN=$ORDER(@DDS1REF@(DDS1PDA," "),-1)+N
+41 SET T=DDS1SN-DDS1REP+2-N
+42 SET DDS1INI=$SELECT(T<1:1_U_DDS1SN,1:T_U_(DDS1REP-'N))_U_DDS1SN
End DoDot:1
+43 IF '$TEST
SET DDS1INI="1^1^1"
+44 ;
+45 SET $PIECE(@DDS1REF@(DDS1PDA),U,2,6)=DDS1PDA_U_DDS1INI_U_+DDS1REP
+46 ;
+47 IF DDS1MUL
Begin DoDot:1
+48 DO UDA^DDS5(.DA,.DDSDL)
+49 SET DDSDA=$PIECE(DDSDA,",",2,999)
End DoDot:1
+50 QUIT
+51 ;
REPLD ;Load data
+1 IF '$DATA(@DDS1RT@(DA,0))
QUIT
IF $DATA(DDS1FSCR)
NEW Y
SET Y=DA
XECUTE DDS1FSCR
IF '$TEST
QUIT
+2 SET DDS1SN=DDS1SN+1
SET $PIECE(DDSDA,",")=DA
SET @("D"_DDSDL)=DA
+3 SET @DDS1REF@(DDS1PDA,DDS1SN)=DDSDA
+4 SET @DDS1REF@(DDS1PDA,"B",DDSDA)=DDS1SN
+5 DO ^DDS11(DDS1B)
+6 QUIT
+7 ;
D0(DL) ;Given DL, return string D0,D1,...,Dn
+1 NEW I,S
+2 SET S=""
FOR I=0:1:DL
SET S=S_"D"_I_","
+3 IF S?.E1","
SET S=$EXTRACT(S,1,$LENGTH(S)-1)
+4 QUIT S
+5 ;
GETD0(DA,DL) ;Given DA array, set D0,D1...
+1 NEW I
+2 SET @("D"_DL)=DA
+3 FOR I=1:1:DL-1
SET @("D"_(DL-I))=DA(I)
+4 QUIT
