- DDS02 ;SFISC/MKO - OVERFLOW FROM ^DDS01 ;24JUL2015
- ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- ;;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.
- REFRESH(DDSPG) ;Refreshes the setup for page
- N B,D,I,DIE,DDSDA,DDP
- F B=0:0 S B=$O(@DDSREFT@(DDSPG,B)) Q:'B D
- .I '$D(DDSDA) S DDSDA=^(B),DIE=^(B,DDSDA,"GL"),DDP=$P(@DDSREFS@(DDSPG,B),U,3) ;GET THE ORIGINAL PAGE DATA
- .S D="" F S D=$O(@DDSREFT@(DDSPG,B,D)) Q:D="" I +$G(^(D))=1 S $P(^(D),U)=0 ;REMEMBER TO RELOAD BLOCKS ON THIS PAGE!
- .S I="" F S I=$O(@DDSREFT@("F0",I)) Q:I="" F S D=$O(@DDSREFT@("F0",I,D)) Q:D="" I $P(D,",",2)=B,$G(^(D,"F"))=3 K @DDSREFT@("F0",I,D) ;KILL OLD FORM-ONLY VALUE
- I $D(D) D EN^DDS1(DDSPG)
- Q
- ;
- ;
- ;
- SV ;Save
- S DDACT="N"
- I $G(DDSDN)=1,DDO D ERR3^DDS3 Q
- I DDSSC'>1,'$P(DDSSC(DDSSC),U,4) D S^DDS3 Q ;INCLUDED '$G(DDSSEL)
- D MSG^DDSMSG($$EZBLD^DIALOG(3093),1) ;**CANNOT SAVE
- 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"!($P($G(DDSU("DD")),U,2)["t") X $$OUTPUT^DIETLIBF(DDP,DDSFLD) S Y(0)=Y ;OUTPUT TRANSFORM
- ;
- 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($$EZBLD^DIALOG($S(DDSKEY:3092.2,1:3092.1)),1) ;'REQUIRED KEY FIELD'
- ;
- S DY=$P(DIR0,U),DX=$P(DIR0,U,2)
- REPNT I DDSEXT'=DDSX!$G(DDSREPNT) D K DDSREPNT ;WRITE OUT NEW VALUE, IF IT DIFFERS FROM WHAT WAS INPUT
- . 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)
- ;
- CHECKEY I $G(DDSU("K")),DDSY]""!(DDSFLD'=.01) D Q:'$D(DDSY) ;CHECK KEY
- . 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($$EZBLD^DIALOG(3094),1) ;"Another Entry already exists with this KEY value."
- .. 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")="" ;CHANGE THE DATA!
- K DDSY
- Q
- ;
- DEC(FILE,FIELD,DEC) ;NOT USED (??)
- S DEC="S X=$G(@DDSREFT@(""F"_FILE_""",DIIENS,"_FIELD_",""D""),"_$E(DEC,5,999)_")"
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS02 3847 printed Mar 13, 2025@21:47:44 Page 2
- DDS02 ;SFISC/MKO - OVERFLOW FROM ^DDS01 ;24JUL2015
- +1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
- +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.
- REFRESH(DDSPG) ;Refreshes the setup for page
- +1 NEW B,D,I,DIE,DDSDA,DDP
- +2 FOR B=0:0
- SET B=$ORDER(@DDSREFT@(DDSPG,B))
- if 'B
- QUIT
- Begin DoDot:1
- +3 ;GET THE ORIGINAL PAGE DATA
- IF '$DATA(DDSDA)
- SET DDSDA=^(B)
- SET DIE=^(B,DDSDA,"GL")
- SET DDP=$PIECE(@DDSREFS@(DDSPG,B),U,3)
- +4 ;REMEMBER TO RELOAD BLOCKS ON THIS PAGE!
- SET D=""
- FOR
- SET D=$ORDER(@DDSREFT@(DDSPG,B,D))
- if D=""
- QUIT
- IF +$GET(^(D))=1
- SET $PIECE(^(D),U)=0
- +5 ;KILL OLD FORM-ONLY VALUE
- SET I=""
- FOR
- SET I=$ORDER(@DDSREFT@("F0",I))
- if I=""
- QUIT
- FOR
- SET D=$ORDER(@DDSREFT@("F0",I,D))
- if D=""
- QUIT
- IF $PIECE(D,",",2)=B
- IF $GET(^(D,"F"))=3
- KILL @DDSREFT@("F0",I,D)
- End DoDot:1
- +6 IF $DATA(D)
- DO EN^DDS1(DDSPG)
- +7 QUIT
- +8 ;
- +9 ;
- +10 ;
- SV ;Save
- +1 SET DDACT="N"
- +2 IF $GET(DDSDN)=1
- IF DDO
- DO ERR3^DDS3
- QUIT
- +3 ;INCLUDED '$G(DDSSEL)
- IF DDSSC'>1
- IF '$PIECE(DDSSC(DDSSC),U,4)
- DO S^DDS3
- QUIT
- +4 ;**CANNOT SAVE
- DO MSG^DDSMSG($$EZBLD^DIALOG(3093),1)
- +5 QUIT
- +6 ;
- 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 ;OUTPUT TRANSFORM
- IF Y]""
- IF $PIECE($GET(DDSU("DD")),U,2)["O"!($PIECE($GET(DDSU("DD")),U,2)["t")
- XECUTE $$OUTPUT^DIETLIBF(DDP,DDSFLD)
- 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 ;'REQUIRED KEY FIELD'
- DO MSG^DDSMSG($$EZBLD^DIALOG($SELECT(DDSKEY:3092.2,1:3092.1)),1)
- End DoDot:1
- if '$DATA(DDSY)
- QUIT
- +23 ;
- +24 SET DY=$PIECE(DIR0,U)
- SET DX=$PIECE(DIR0,U,2)
- REPNT ;WRITE OUT NEW VALUE, IF IT DIFFERS FROM WHAT WAS INPUT
- IF DDSEXT'=DDSX!$GET(DDSREPNT)
- Begin DoDot:1
- +1 XECUTE IOXY
- +2 SET DDSX=$EXTRACT(DDSEXT,1,$PIECE(DIR0,U,3))
- +3 IF '$PIECE(DIR0,U,6)
- SET DDSX=DDSX_$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))
- +4 IF '$TEST
- SET DDSX=$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))_DDSX
- +5 WRITE $PIECE(DDGLVID,DDGLDEL)_DDSX_$PIECE(DDGLVID,DDGLDEL,10)
- End DoDot:1
- KILL DDSREPNT
- +6 ;
- CHECKEY ;CHECK KEY
- IF $GET(DDSU("K"))
- IF DDSY]""!(DDSFLD'=.01)
- Begin DoDot:1
- +1 NEW DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS
- +2 DO LOADXREF^DIKC1(DDP,"","",DDSU("K"),$NAME(@DDSREFT@("F"))_"_","DDSFXR")
- +3 if $DATA(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2
- SET DDSVSV=^("D")
- SET ^("D")=DDSY
- +4 SET DDSUNIQ=1
- SET DDSUI=0
- +5 FOR
- SET DDSUI=$ORDER(DDSFXR(DDP,DDSUI))
- if 'DDSUI
- QUIT
- Begin DoDot:2
- +6 SET DIIENS=DDSDA
- +7 DO SETXARR^DIKC(DDP,DDSUI,"DDSFXR","","D")
- +8 SET DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR")
- End DoDot:2
- if 'DDSUNIQ
- QUIT
- +9 IF 'DDSUNIQ
- Begin DoDot:2
- +10 KILL DDSY
- +11 SET DDSCHKQ=1
- SET DIR0("L")=DDSEXT
- +12 ;"Another Entry already exists with this KEY value."
- DO MSG^DDSMSG($$EZBLD^DIALOG(3094),1)
- +13 KILL @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")
- if $DATA(DDSVSV)#2
- SET ^("D")=DDSVSV
- End DoDot:2
- End DoDot:1
- if '$DATA(DDSY)
- QUIT
- +14 ;
- +15 if $GET(DDSDA)!'$DATA(DDSREP)
- Begin DoDot:1
- +16 if $DATA(Y(0))
- SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT
- +17 ;CHANGE THE DATA!
- SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY
- IF DDSY=""
- IF $DATA(DDSU("X"))
- SET ^("X")=""
- End DoDot:1
- +18 KILL DDSY
- +19 QUIT
- +20 ;
- DEC(FILE,FIELD,DEC) ;NOT USED (??)
- +1 SET DEC="S X=$G(@DDSREFT@(""F"_FILE_""",DIIENS,"_FIELD_",""D""),"_$EXTRACT(DEC,5,999)_")"
- +2 QUIT
- +3 ;
- 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
