- DDS02 ;SFISC/MKO-OVERFLOW FROM ^DDS01 ;1:50 PM 16 Jul 1999 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**8,11**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- UNED ;Change was made to uneditable field
- D MSG^DDSMSG("No editing allowed.",1)
- I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0
- S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X")
- Q
- ;
- SV ;Save
- S DDACT="N"
- I $G(DDSDN)=1,DDO D ERR3^DDS3 Q
- I DDSSC'>1,'$G(DDSSEL),'$P(DDSSC(DDSSC),U,4) D S^DDS3 Q
- N DDSEM
- S DDSEM(1)="You cannot save changes at this level."
- S DDSEM(2)="To close the current page, press <PF1>C."
- D MSG^DDSMSG(.DDSEM,1)
- Q
- ;
- EXT ;Process external form
- I '$P($G(DDSU("DD")),U,2),$P($G(DDSU("DD")),U,2)["P" D PT
- I $P($G(DDSO(0)),U,3)=2,$E($P($G(DDSO(20)),U))="P" D PTFO
- ;
- S:DDSOLD=Y DIR0N=1
- S DDSX=X,DDSY=Y
- I Y]"",$P($G(DDSU("DD")),U,2)["O",$G(^DD(DDP,DDSFLD,2))'?."^" K Y(0) X ^(2) S Y(0)=Y
- ;
- S DDSEXT=$G(Y(0,0),$G(Y(0),Y)),X=DDSY
- ;
- I $D(DDSO(14)) K DDSERROR X DDSO(14) I $D(DDSERROR)#2 D Q
- . K DDSERROR,DDSY S DIR0("L")=DDSEXT,DDSCHKQ=1
- ;
- I DDSY="",DDSFLD'=.01 D Q:'$D(DDSY)
- . N DDSREQ,DDSKEY
- . S DDSREQ=$P($G(DDSU("A")),U)
- . S:DDSREQ="" DDSREQ=$P($G(DDSO(4)),U)
- . S:DDSREQ="" DDSREQ=$P($G(DDSU("DD")),U,2)["R"
- . S DDSKEY=$D(^DD("KEY","F",DDP,DDSFLD))>0
- . I 'DDSREQ,'DDSKEY Q
- . K DDSY
- . S DDSCHKQ=1,DIR0("L")=DDSEXT
- . D MSG^DDSMSG("This is a required "_$S(DDSKEY:"key ",1:"")_"field.",1)
- ;
- S DY=$P(DIR0,U),DX=$P(DIR0,U,2)
- I DDSEXT'=DDSX D
- . X IOXY
- . S DDSX=$E(DDSEXT,1,$P(DIR0,U,3))
- . I '$P(DIR0,U,6) S DDSX=DDSX_$J("",$P(DIR0,U,3)-$L(DDSEXT))
- . E S DDSX=$J("",$P(DIR0,U,3)-$L(DDSEXT))_DDSX
- . W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10)
- ;
- I $G(DDSU("K")),DDSY]""!(DDSFLD'=.01) D Q:'$D(DDSY)
- . N DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS
- . D LOADXREF^DIKC1(DDP,"","",DDSU("K"),$NA(@DDSREFT@("F"))_"_","DDSFXR")
- . S:$D(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2 DDSVSV=^("D") S ^("D")=DDSY
- . S DDSUNIQ=1,DDSUI=0
- . F S DDSUI=$O(DDSFXR(DDP,DDSUI)) Q:'DDSUI D Q:'DDSUNIQ
- .. S DIIENS=DDSDA
- .. D SETXARR^DIKC(DDP,DDSUI,"DDSFXR","","D")
- .. S DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR")
- . I 'DDSUNIQ D
- .. K DDSY
- .. S DDSCHKQ=1,DIR0("L")=DDSEXT
- .. D MSG^DDSMSG("Another entry already exists with this key value.",1)
- .. K @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D") S:$D(DDSVSV)#2 ^("D")=DDSVSV
- ;
- D:$G(DDSDA)!'$D(DDSREP)
- . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT
- . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY I DDSY="",$D(DDSU("X")) S ^("X")=""
- K DDSY
- Q
- ;
- PT ;Modify Y for pointer type fields
- I $P(Y,U,3)=1 D
- . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_U_$P(DDSU("DD"),U,3)
- S Y=$P(Y,U)
- Q
- ;
- PTFO ;Modify Y for pointer type form only fields
- I $P(Y,U,3)=1 D
- . N R,I S R=""
- . F I=1:1 Q:$D(DA(I))[0 S R=R_DA(I)_","
- . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,@DDSREFT@("ADD",@DDSREFT@("ADD"))=+Y_","_R_$S($P(DDSO(20),U,3):^DIC(+$P(DDSO(20),U,3),0,"GL"),1:U_$P($P(DDSO(20),U,3),":"))
- S Y=$S(Y=-1:"",1:$P(Y,U))
- Q
- DDS02 ;SFISC/MKO-OVERFLOW FROM ^DDS01 ;1:50 PM 16 Jul 1999 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**8,11**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- UNED ;Change was made to uneditable field
- +1 DO MSG^DDSMSG("No editing allowed.",1)
- +2 IF $PIECE($GET(DDSO(0)),U,3)=2
- NEW DDP
- SET DDP=0
- +3 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
- IF $DATA(DDSU("X"))#2
- SET ^("X")=DDSU("X")
- +4 QUIT
- +5 ;
- SV ;Save
- +1 SET DDACT="N"
- +2 IF $GET(DDSDN)=1
- IF DDO
- DO ERR3^DDS3
- QUIT
- +3 IF DDSSC'>1
- IF '$GET(DDSSEL)
- IF '$PIECE(DDSSC(DDSSC),U,4)
- DO S^DDS3
- QUIT
- +4 NEW DDSEM
- +5 SET DDSEM(1)="You cannot save changes at this level."
- +6 SET DDSEM(2)="To close the current page, press <PF1>C."
- +7 DO MSG^DDSMSG(.DDSEM,1)
- +8 QUIT
- +9 ;
- EXT ;Process external form
- +1 IF '$PIECE($GET(DDSU("DD")),U,2)
- IF $PIECE($GET(DDSU("DD")),U,2)["P"
- DO PT
- +2 IF $PIECE($GET(DDSO(0)),U,3)=2
- IF $EXTRACT($PIECE($GET(DDSO(20)),U))="P"
- DO PTFO
- +3 ;
- +4 IF DDSOLD=Y
- SET DIR0N=1
- +5 SET DDSX=X
- SET DDSY=Y
- +6 IF Y]""
- IF $PIECE($GET(DDSU("DD")),U,2)["O"
- IF $GET(^DD(DDP,DDSFLD,2))'?."^"
- KILL Y(0)
- XECUTE ^(2)
- SET Y(0)=Y
- +7 ;
- +8 SET DDSEXT=$GET(Y(0,0),$GET(Y(0),Y))
- SET X=DDSY
- +9 ;
- +10 IF $DATA(DDSO(14))
- KILL DDSERROR
- XECUTE DDSO(14)
- IF $DATA(DDSERROR)#2
- Begin DoDot:1
- +11 KILL DDSERROR,DDSY
- SET DIR0("L")=DDSEXT
- SET DDSCHKQ=1
- End DoDot:1
- QUIT
- +12 ;
- +13 IF DDSY=""
- IF DDSFLD'=.01
- Begin DoDot:1
- +14 NEW DDSREQ,DDSKEY
- +15 SET DDSREQ=$PIECE($GET(DDSU("A")),U)
- +16 IF DDSREQ=""
- SET DDSREQ=$PIECE($GET(DDSO(4)),U)
- +17 IF DDSREQ=""
- SET DDSREQ=$PIECE($GET(DDSU("DD")),U,2)["R"
- +18 SET DDSKEY=$DATA(^DD("KEY","F",DDP,DDSFLD))>0
- +19 IF 'DDSREQ
- IF 'DDSKEY
- QUIT
- +20 KILL DDSY
- +21 SET DDSCHKQ=1
- SET DIR0("L")=DDSEXT
- +22 DO MSG^DDSMSG("This is a required "_$SELECT(DDSKEY:"key ",1:"")_"field.",1)
- End DoDot:1
- IF '$DATA(DDSY)
- QUIT
- +23 ;
- +24 SET DY=$PIECE(DIR0,U)
- SET DX=$PIECE(DIR0,U,2)
- +25 IF DDSEXT'=DDSX
- Begin DoDot:1
- +26 XECUTE IOXY
- +27 SET DDSX=$EXTRACT(DDSEXT,1,$PIECE(DIR0,U,3))
- +28 IF '$PIECE(DIR0,U,6)
- SET DDSX=DDSX_$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))
- +29 IF '$TEST
- SET DDSX=$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))_DDSX
- +30 WRITE $PIECE(DDGLVID,DDGLDEL)_DDSX_$PIECE(DDGLVID,DDGLDEL,10)
- End DoDot:1
- +31 ;
- +32 IF $GET(DDSU("K"))
- IF DDSY]""!(DDSFLD'=.01)
- Begin DoDot:1
- +33 NEW DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS
- +34 DO LOADXREF^DIKC1(DDP,"","",DDSU("K"),$NAME(@DDSREFT@("F"))_"_","DDSFXR")
- +35 IF $DATA(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2
- SET DDSVSV=^("D")
- SET ^("D")=DDSY
- +36 SET DDSUNIQ=1
- SET DDSUI=0
- +37 FOR
- SET DDSUI=$ORDER(DDSFXR(DDP,DDSUI))
- IF 'DDSUI
- QUIT
- Begin DoDot:2
- +38 SET DIIENS=DDSDA
- +39 DO SETXARR^DIKC(DDP,DDSUI,"DDSFXR","","D")
- +40 SET DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR")
- End DoDot:2
- IF 'DDSUNIQ
- QUIT
- +41 IF 'DDSUNIQ
- Begin DoDot:2
- +42 KILL DDSY
- +43 SET DDSCHKQ=1
- SET DIR0("L")=DDSEXT
- +44 DO MSG^DDSMSG("Another entry already exists with this key value.",1)
- +45 KILL @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")
- IF $DATA(DDSVSV)#2
- SET ^("D")=DDSVSV
- End DoDot:2
- End DoDot:1
- IF '$DATA(DDSY)
- QUIT
- +46 ;
- +47 IF $GET(DDSDA)!'$DATA(DDSREP)
- Begin DoDot:1
- +48 IF $DATA(Y(0))
- SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT
- +49 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY
- IF DDSY=""
- IF $DATA(DDSU("X"))
- SET ^("X")=""
- End DoDot:1
- +50 KILL DDSY
- +51 QUIT
- +52 ;
- PT ;Modify Y for pointer type fields
- +1 IF $PIECE(Y,U,3)=1
- Begin DoDot:1
- +2 SET ^("ADD")=$GET(@DDSREFT@("ADD"))+1
- SET ^("ADD",^("ADD"))=+Y_","_U_$PIECE(DDSU("DD"),U,3)
- End DoDot:1
- +3 SET Y=$PIECE(Y,U)
- +4 QUIT
- +5 ;
- PTFO ;Modify Y for pointer type form only fields
- +1 IF $PIECE(Y,U,3)=1
- Begin DoDot:1
- +2 NEW R,I
- SET R=""
- +3 FOR I=1:1
- IF $DATA(DA(I))[0
- QUIT
- SET R=R_DA(I)_","
- +4 SET ^("ADD")=$GET(@DDSREFT@("ADD"))+1
- SET @DDSREFT@("ADD",@DDSREFT@("ADD"))=+Y_","_R_$SELECT($PIECE(DDSO(20),U,3):^DIC(+$PIECE(DDSO(20),U,3),0,"GL"),1:U_$PIECE($PIECE(DDSO(20),U,3),":"))
- End DoDot:1
- +5 SET Y=$SELECT(Y=-1:"",1:$PIECE(Y,U))
- +6 QUIT
