- DDS01 ;SFISC/MLH,MKO-PROCESS BLOCK ;24JAN2013
- ;;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.
- ;
- ;***BE CAREFUL PUTTING TAGS INTO THIS IMPORTANT ROUTINE! $T LOOKS FOR A NON-EXISTENCE OF A TAG!****
- ;
- F D IN,CHK Q:"^Q^NB^NP^"[(U_DDACT_U)
- Q
- ;
- IN K DDSBR,DDSFLD,DDSO,DDSU,DIR,DDSREPNT
- S:$D(@DDSREFS@(DDSPG,$S(DDO:DDSBK,1:0),DDO,"N"))#2 DDSU("N")=^("N")
- I DDM,'$G(DDSKM) D CLRMSG^DDS
- G:'DDO COM^DDSCOM
- ;
- S DDSOSV=0
- F DDSI=0,1,2,4,7,10:1:14,20 D ;MOVE FIELD DEFINITION INTO DDSO ARRAY
- . S:$D(^DIST(.404,DDSBK,40,DDO,DDSI))#2 DDSO(DDSI)=^(DDSI)
- K DDSI
- ;
- S DDSFLD=$G(DDSO(1)) K DDSO(1)
- I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,DDSFLD=DDO_","_DDSBK
- ;
- I DDSFLD]"",DDSDA]"" M DDSU=@DDSREFT@("F"_DDP,DDSDA,DDSFLD) ;Restore field's specs & value from ^TMP
- ;
- I '$D(DDSREP)!DDSDA,$$UNED($G(DDSU("A")),$G(DDSO(4)),$G(DDSU("N"))) D Q
- . I $D(DDSACT)#2 S DDACT=DDSACT K DDSACT
- . S:DDACT="U" DDACT="L"
- . S:DDACT="D" DDACT="R"
- . D CURSOR Q:$D(DDSBR)#2
- . S DDSCHKQ=1
- K DDSACT
- ;
- S (X,DDSOLD)=$G(DDSU("D")),DDSEXT=$G(DDSU("X"),X)
- ;
- X:$G(DDSO(11))'?."^" DDSO(11) ;PRE-ACTION
- I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
- I DDACT]"",$T(@DDACT)]"" D @DDACT S DDSCHKQ=1 Q
- ;
- S DIR0N=1 Q:DDSFLD=""
- ;
- S:$G(^DD(DDP,DDSFLD,0))'?."^" DDSU("DD")=^(0)
- I $D(DDSU("N"))[0 S DDACT="N" Q
- Q:$D(DDSO(2))[0
- ;
- D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
- K DDSKM,DDQ
- ;
- S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3)
- S:$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,10) $P(DIR0,U,6)=1
- HITE S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+($P(DDSREP,U,3)-1*$$HITE^DDSR(DDSBK)) ;DJW/GFT
- ;
- I $D(DDSREP),'DDSDA,$P(DDSO(0),U,3)'=2 K DDSU("DD") G SEL^DDSM
- I $D(DDSU("M"))#2 S DDSGL=U_$P(DDSU("M"),U,2) G:'DDSU("M") WP^DDSWP
- S DIR("B")=$G(DDSU("X"),DDSOLD)
- ;
- I $D(DDSU("M"))#2 D SEL^DDS5 G:X'=DDSOLD&(DDACT="N") EXT
- I $P($G(DDSO(0)),U,3)'=2 S DIR(0)=DDP_","_DDSFLD_"O" ;IT'S A FIELD-TYPE READ
- E D DIR^DDSFO
- D ^DIR K DIR,DUOUT,DIRUT,DIROUT ;DO THE READ!
- I DIR0N S (X,Y)=DDSOLD Q
- ;
- EXT I $E(X)=U!$D(DTOUT) S DIR0N=1 Q
- G EXT^DDS02
- ;
- CHK Q:$D(DDSBR)#2
- I $G(DDSCHKQ)=1 K DDSCHKQ Q
- G:$D(DTOUT) TO^DDS3
- G:$E(X)=U UPA^DDS2
- I $G(DDSFLD)=.01,X="",$G(DA),DDSOLD]"" G ^DDS6 ;DELETE ENTRY
- ;
- I $P($G(DDSU("DD")),U,2)["I",$G(DDSOLD)]"" D I %]"",X'=% S DDSNOED=1 ;UNEDITABLE FIELD ALREADY HAS A VALUE
- .N DIERR S %=$$GET1^DIQ(DDSFILE,DDSDA,DDSFLD)
- E I $P($G(DDSU("DD")),U,5,99)["DINUM" S DDSNOED=1
- E S DDSNOED=$S($P($G(DDSU("A")),U,4)="":$P($G(DDSO(4)),U,4),1:$P($G(DDSU("A")),U,4)) ;FIELD 6.4 ('DISABLE EDITING') IN THE FIELD MULTIPLE
- I $G(DDSFLD)]"",$G(DDSOLD)]"",X'=DDSOLD,DDSNOED S %=1 D I %["," S DDSDA=% D POSDA^DDSM(DDSDA,DDSOLD) K DDSCHKQ Q
- .N F,L
- .I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,F="" F S F=$O(@DDSREFT@("F0",F)) Q:F="" D Q:%[","
- ..S L="" F S L=$O(@DDSREFT@("F0",F,L)) Q:L="" I +L=DDO,$P(L,",",2)=DDSBK,$P($G(@DDSREFT@("F0",F,L,"O")),X)="" S %=F Q ;FIND A MATCHING FORM-ONLY VALUE
- .I %'["," S F="" F S F=$O(@DDSREFT@("F"_DDP,F)) Q:F="" D Q:%[","
- ..I F'=DDSDA S L=$G(@DDSREFT@("F"_DDP,F,DDSFLD,"D")) I L]"",$P(L,X)="" S %=F ;FIND A MATCHING FIELD VALUE
- .S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X")
- .
- I 'DIR0N,$G(DDSFLD),$D(DDSU("M"))[0,$G(DDSCHKQ)'=2,DDSNOED D K DDSNOED Q ;User tried to change uneditable field (was UNED^DDS02)
- .S %=$P($G(DDSO(0)),U,2) I %="" S %=$P($G(DDSO(0)),U,5) ;GET CAPTION or UNIQUE NAME
- .D MSG^DDSMSG($$EZBLD^DIALOG(3090,%),1) ;'UNEDITABLE'
- .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")
- ;
- K DDSCHKQ,DDSNOED
- ;
- I $G(DDSFLD)=.01,$G(DDSPTB)]"",$G(DDSREP)<2,'DIR0N D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA)
- I $G(DDSO(12))'?."^" X DDSO(12) ;POST ACTION
- ;
- I 'DIR0N,DDO,$G(DDSFLD)]"" D
- . I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0
- . S DDSCHG=1
- . I DDSDA!'$D(DDSREP),+$G(DDSU("F"))'=1 S $P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"F"),U)=1
- . I $G(DDSO(13))'?."^" X DDSO(13) ;POST ACTION ON CHANGE
- . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG)
- . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG)
- ;
- I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
- Q:DDACT="" I $T(@DDACT)]"" G @DDACT
- I 'DDO G:X]"" ^DDS3 S DDSO(0)=0
- I DDACT="D",$D(DDSREP),'DA S DDACT="N" ;GFT DON'T DOWN-ARROW THRU A MULTIPLE THAT HAS NO .01 FIELD DEFINED
- G:"^U^D^R^L^"[(U_DDACT_U) CURSOR
- G:$D(DDSU("M"))[0 NF
- G:DDSU("M") ^DDS5
- D EDIT^DDSWP I '$D(DDGLCLR) S DDACT="Q" Q
- D R^DDSR
- ;
- NF I 'DDO,DDSOSV S DDO=DDSOSV Q
- ;
- I DDO,$S($D(DDSREP):DDSDA,1:1) D
- . D:'$D(DDSU("M"))
- .. I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDSSTACK="`"_^(DDO) ;ANOTHER PAGE HAS THIS FIELD AS ITS PARENT FIELD!
- .. E I $P($G(DDSO(7)),U,2)]"" S DDSSTACK=$P(DDSO(7),U,2) ;OR THERE IS A SUBPAGE LINK FROM THIS FIELD
- . X:$G(DDSO(10))'?."^" DDSO(10) ;BRANCHING LOGIC
- ;
- I $D(DDSSTACK) D:$G(^DIST(.403,+DDS,21400)) REFRESH^DDS02(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSU ;WE DO A WHOLE RECURSION TO THE SUBPAGE, AND THEN REPAINT THIS PAGE
- I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
- S DDACT="N"
- ;
- CURSOR N ACT,B,BLK,BLK0,FND,N,REP
- K DDSACT
- S:$D(DDSU("N"))[0 DDSU("N")=$G(@DDSREFS@(DDSPG,DDSBK,DDO,"N"))
- S FND=0
- I $D(DDSREP),DDO D MNAV^DDSM(.FND) Q:FND
- ;
- S B=U,(BLK,BLK0)=DDSBK,N=DDSU("N"),ACT=$S(DDO&$G(DDSDN):"N",1:DDACT)
- F D Q:FND!$D(REP)
- . S DDO=$P(N,U,$L($P("U^D^R^L^N",ACT),U))
- . I 'DDO S (DDO,DDSBK)=0,FND=1 Q
- . ;
- . S DDSBK=$P(DDO,",",2),DDO=+DDO
- . I DDSBK D Q:$D(REP)
- .. I $P($G(@DDSREFS@(DDSPG,DDSBK)),U,4) D
- ... S DDO=$P($G(@DDSREFS@(DDSPG,DDSBK)),U,9),ACT="N"
- .. E S ACT=DDACT
- .. I '$P($G(@DDSREFT@(DDSPG,DDSBK)),U),DDSDAORG S B=B_DDSBK_U
- .. E I $P(@DDSREFS@(DDSPG,DDSBK),U,7)>1 S REP=1,DDACT="NB",DDSBR=""
- . E S DDSBK=BLK
- . ;
- . I B'[(U_DDSBK_U) S FND=1 S:DDSBK'=BLK0 DDACT="NB",DDSBR="",DDSACT=ACT
- . ;
- . S:'FND N=$G(@DDSREFS@(DDSPG,DDSBK,+DDO,"N")),BLK=DDSBK
- Q
- ;
- NP ;;
- G:$D(DDSREP)&DDO PGDN^DDSM ;If in REPEATING BLOCK
- S:DDSNP]"" DDSPG=DDSNP
- S:DDSNP="" DDACT="N"
- Q
- PP ;;
- G:$D(DDSREP)&DDO PGUP^DDSM ;If in REPEATING BLOCK
- S DDSPG=$$PP^DDS5(.Y)
- S DDACT=$S(Y=1:"NP",1:"N")
- Q
- NB ;;
- S DDSBK=$$NB^DDS5(.Y),DDACT=$S(Y=1:"NB",1:"N")
- Q
- SEL ;;
- ;I $G(DDSSEL) W $C(7) Q
- S DDACT="N" G PG^DDSRSEL
- SV ;;
- G SV^DDS02
- QT ;;
- G QT^DDS3
- EX ;;
- G EX^DDS3
- CL ;;
- G CL^DDS3
- MOUSE ;;
- G MOUSE^DDS2
- PRNT ;;
- D EN^DDSRP(+DDS,DDSPG)
- RF ;;
- S DDACT="N" I $G(^DIST(.403,+DDS,21400)) D REFRESH^DDS02(DDSPG) ;RE-DO THE DATA BEFORE REFRESHING PAGE
- G R^DDSR
- ;
- ;
- UNED(ATT,DEF,N) ;
- Q $S(N="":1,$P(ATT,U,4)="":$P(DEF,U,4)=1,1:$P(ATT,U,4)=1)&'$P(N,U,11)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS01 6904 printed Feb 19, 2025@00:09:14 Page 2
- DDS01 ;SFISC/MLH,MKO-PROCESS BLOCK ;24JAN2013
- +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 ;***BE CAREFUL PUTTING TAGS INTO THIS IMPORTANT ROUTINE! $T LOOKS FOR A NON-EXISTENCE OF A TAG!****
- +8 ;
- +9 FOR
- DO IN
- DO CHK
- if "^Q^NB^NP^"[(U_DDACT_U)
- QUIT
- +10 QUIT
- +11 ;
- IN KILL DDSBR,DDSFLD,DDSO,DDSU,DIR,DDSREPNT
- +1 if $DATA(@DDSREFS@(DDSPG,$SELECT(DDO
- SET DDSU("N")=^("N")
- +2 IF DDM
- IF '$GET(DDSKM)
- DO CLRMSG^DDS
- +3 if 'DDO
- GOTO COM^DDSCOM
- +4 ;
- +5 SET DDSOSV=0
- +6 ;MOVE FIELD DEFINITION INTO DDSO ARRAY
- FOR DDSI=0,1,2,4,7,10:1:14,20
- Begin DoDot:1
- +7 if $DATA(^DIST(.404,DDSBK,40,DDO,DDSI))#2
- SET DDSO(DDSI)=^(DDSI)
- End DoDot:1
- +8 KILL DDSI
- +9 ;
- +10 SET DDSFLD=$GET(DDSO(1))
- KILL DDSO(1)
- +11 IF $PIECE($GET(DDSO(0)),U,3)=2
- NEW DDP
- SET DDP=0
- SET DDSFLD=DDO_","_DDSBK
- +12 ;
- +13 ;Restore field's specs & value from ^TMP
- IF DDSFLD]""
- IF DDSDA]""
- MERGE DDSU=@DDSREFT@("F"_DDP,DDSDA,DDSFLD)
- +14 ;
- +15 IF '$DATA(DDSREP)!DDSDA
- IF $$UNED($GET(DDSU("A")),$GET(DDSO(4)),$GET(DDSU("N")))
- Begin DoDot:1
- +16 IF $DATA(DDSACT)#2
- SET DDACT=DDSACT
- KILL DDSACT
- +17 if DDACT="U"
- SET DDACT="L"
- +18 if DDACT="D"
- SET DDACT="R"
- +19 DO CURSOR
- if $DATA(DDSBR)#2
- QUIT
- +20 SET DDSCHKQ=1
- End DoDot:1
- QUIT
- +21 KILL DDSACT
- +22 ;
- +23 SET (X,DDSOLD)=$GET(DDSU("D"))
- SET DDSEXT=$GET(DDSU("X"),X)
- +24 ;
- +25 ;PRE-ACTION
- if $GET(DDSO(11))'?."^"
- XECUTE DDSO(11)
- +26 IF $DATA(DDSBR)#2
- DO BR^DDS2
- if $DATA(DDSBR)#2
- QUIT
- +27 IF DDACT]""
- IF $TEXT(@DDACT)]""
- DO @DDACT
- SET DDSCHKQ=1
- QUIT
- +28 ;
- +29 SET DIR0N=1
- if DDSFLD=""
- QUIT
- +30 ;
- +31 if $GET(^DD(DDP,DDSFLD,0))'?."^"
- SET DDSU("DD")=^(0)
- +32 IF $DATA(DDSU("N"))[0
- SET DDACT="N"
- QUIT
- +33 if $DATA(DDSO(2))[0
- QUIT
- +34 ;
- +35 if $GET(@DDSREFT@("HLP"))>0
- DO HLP^DDSMSG()
- +36 KILL DDSKM,DDQ
- +37 ;
- +38 SET DIR0=$PIECE(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3)
- +39 if $PIECE(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,10)
- SET $PIECE(DIR0,U,6)=1
- HITE ;DJW/GFT
- if $PIECE($GET(DDSREP),U,3)>1
- SET $PIECE(DIR0,U)=$PIECE(DIR0,U)+($PIECE(DDSREP,U,3)-1*$$HITE^DDSR(DDSBK))
- +1 ;
- +2 IF $DATA(DDSREP)
- IF 'DDSDA
- IF $PIECE(DDSO(0),U,3)'=2
- KILL DDSU("DD")
- GOTO SEL^DDSM
- +3 IF $DATA(DDSU("M"))#2
- SET DDSGL=U_$PIECE(DDSU("M"),U,2)
- if 'DDSU("M")
- GOTO WP^DDSWP
- +4 SET DIR("B")=$GET(DDSU("X"),DDSOLD)
- +5 ;
- +6 IF $DATA(DDSU("M"))#2
- DO SEL^DDS5
- if X'=DDSOLD&(DDACT="N")
- GOTO EXT
- +7 ;IT'S A FIELD-TYPE READ
- IF $PIECE($GET(DDSO(0)),U,3)'=2
- SET DIR(0)=DDP_","_DDSFLD_"O"
- +8 IF '$TEST
- DO DIR^DDSFO
- +9 ;DO THE READ!
- DO ^DIR
- KILL DIR,DUOUT,DIRUT,DIROUT
- +10 IF DIR0N
- SET (X,Y)=DDSOLD
- QUIT
- +11 ;
- EXT IF $EXTRACT(X)=U!$DATA(DTOUT)
- SET DIR0N=1
- QUIT
- +1 GOTO EXT^DDS02
- +2 ;
- CHK if $DATA(DDSBR)#2
- QUIT
- +1 IF $GET(DDSCHKQ)=1
- KILL DDSCHKQ
- QUIT
- +2 if $DATA(DTOUT)
- GOTO TO^DDS3
- +3 if $EXTRACT(X)=U
- GOTO UPA^DDS2
- +4 ;DELETE ENTRY
- IF $GET(DDSFLD)=.01
- IF X=""
- IF $GET(DA)
- IF DDSOLD]""
- GOTO ^DDS6
- +5 ;
- +6 ;UNEDITABLE FIELD ALREADY HAS A VALUE
- IF $PIECE($GET(DDSU("DD")),U,2)["I"
- IF $GET(DDSOLD)]""
- Begin DoDot:1
- +7 NEW DIERR
- SET %=$$GET1^DIQ(DDSFILE,DDSDA,DDSFLD)
- End DoDot:1
- IF %]""
- IF X'=%
- SET DDSNOED=1
- +8 IF '$TEST
- IF $PIECE($GET(DDSU("DD")),U,5,99)["DINUM"
- SET DDSNOED=1
- +9 ;FIELD 6.4 ('DISABLE EDITING') IN THE FIELD MULTIPLE
- IF '$TEST
- SET DDSNOED=$SELECT($PIECE($GET(DDSU("A")),U,4)="":$PIECE($GET(DDSO(4)),U,4),1:$PIECE($GET(DDSU("A")),U,4))
- +10 IF $GET(DDSFLD)]""
- IF $GET(DDSOLD)]""
- IF X'=DDSOLD
- IF DDSNOED
- SET %=1
- Begin DoDot:1
- +11 NEW F,L
- +12 IF $PIECE($GET(DDSO(0)),U,3)=2
- NEW DDP
- SET DDP=0
- SET F=""
- FOR
- SET F=$ORDER(@DDSREFT@("F0",F))
- if F=""
- QUIT
- Begin DoDot:2
- +13 ;FIND A MATCHING FORM-ONLY VALUE
- SET L=""
- FOR
- SET L=$ORDER(@DDSREFT@("F0",F,L))
- if L=""
- QUIT
- IF +L=DDO
- IF $PIECE(L,",",2)=DDSBK
- IF $PIECE($GET(@DDSREFT@("F0",F,L,"O")),X)=""
- SET %=F
- QUIT
- End DoDot:2
- if %[","
- QUIT
- +14 IF %'[","
- SET F=""
- FOR
- SET F=$ORDER(@DDSREFT@("F"_DDP,F))
- if F=""
- QUIT
- Begin DoDot:2
- +15 ;FIND A MATCHING FIELD VALUE
- IF F'=DDSDA
- SET L=$GET(@DDSREFT@("F"_DDP,F,DDSFLD,"D"))
- IF L]""
- IF $PIECE(L,X)=""
- SET %=F
- End DoDot:2
- if %[","
- QUIT
- +16 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
- if $DATA(DDSU("X"))#2
- SET ^("X")=DDSU("X")
- +17 End DoDot:1
- IF %[","
- SET DDSDA=%
- DO POSDA^DDSM(DDSDA,DDSOLD)
- KILL DDSCHKQ
- QUIT
- +18 ;User tried to change uneditable field (was UNED^DDS02)
- IF 'DIR0N
- IF $GET(DDSFLD)
- IF $DATA(DDSU("M"))[0
- IF $GET(DDSCHKQ)'=2
- IF DDSNOED
- Begin DoDot:1
- +19 ;GET CAPTION or UNIQUE NAME
- SET %=$PIECE($GET(DDSO(0)),U,2)
- IF %=""
- SET %=$PIECE($GET(DDSO(0)),U,5)
- +20 ;'UNEDITABLE'
- DO MSG^DDSMSG($$EZBLD^DIALOG(3090,%),1)
- +21 IF $PIECE($GET(DDSO(0)),U,3)=2
- NEW DDP
- SET DDP=0
- +22 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
- if $DATA(DDSU("X"))#2
- SET ^("X")=DDSU("X")
- End DoDot:1
- KILL DDSNOED
- QUIT
- +23 ;
- +24 KILL DDSCHKQ,DDSNOED
- +25 ;
- +26 IF $GET(DDSFLD)=.01
- IF $GET(DDSPTB)]""
- IF $GET(DDSREP)<2
- IF 'DIR0N
- DO RPF^DDS7(DDP,DDSPTB,DDSDA,.DA)
- +27 ;POST ACTION
- IF $GET(DDSO(12))'?."^"
- XECUTE DDSO(12)
- +28 ;
- +29 IF 'DIR0N
- IF DDO
- IF $GET(DDSFLD)]""
- Begin DoDot:1
- +30 IF $PIECE($GET(DDSO(0)),U,3)=2
- NEW DDP
- SET DDP=0
- +31 SET DDSCHG=1
- +32 IF DDSDA!'$DATA(DDSREP)
- IF +$GET(DDSU("F"))'=1
- SET $PIECE(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"F"),U)=1
- +33 ;POST ACTION ON CHANGE
- IF $GET(DDSO(13))'?."^"
- XECUTE DDSO(13)
- +34 if $DATA(@DDSREFS@("PT",DDP,DDSFLD))
- DO RPB^DDS7(DDP,DDSFLD,DDSPG)
- +35 if $DATA(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG))
- DO RPCF^DDSCOMP(DDSPG)
- End DoDot:1
- +36 ;
- +37 IF $DATA(DDSBR)#2
- DO BR^DDS2
- if $DATA(DDSBR)#2
- QUIT
- +38 if DDACT=""
- QUIT
- IF $TEXT(@DDACT)]""
- GOTO @DDACT
- +39 IF 'DDO
- if X]""
- GOTO ^DDS3
- SET DDSO(0)=0
- +40 ;GFT DON'T DOWN-ARROW THRU A MULTIPLE THAT HAS NO .01 FIELD DEFINED
- IF DDACT="D"
- IF $DATA(DDSREP)
- IF 'DA
- SET DDACT="N"
- +41 if "^U^D^R^L^"[(U_DDACT_U)
- GOTO CURSOR
- +42 if $DATA(DDSU("M"))[0
- GOTO NF
- +43 if DDSU("M")
- GOTO ^DDS5
- +44 DO EDIT^DDSWP
- IF '$DATA(DDGLCLR)
- SET DDACT="Q"
- QUIT
- +45 DO R^DDSR
- +46 ;
- NF IF 'DDO
- IF DDSOSV
- SET DDO=DDSOSV
- QUIT
- +1 ;
- +2 IF DDO
- IF $SELECT($DATA(DDSREP):DDSDA,1:1)
- Begin DoDot:1
- +3 if '$DATA(DDSU("M"))
- Begin DoDot:2
- +4 ;ANOTHER PAGE HAS THIS FIELD AS ITS PARENT FIELD!
- IF $GET(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]""
- SET DDSSTACK="`"_^(DDO)
- +5 ;OR THERE IS A SUBPAGE LINK FROM THIS FIELD
- IF '$TEST
- IF $PIECE($GET(DDSO(7)),U,2)]""
- SET DDSSTACK=$PIECE(DDSO(7),U,2)
- End DoDot:2
- +6 ;BRANCHING LOGIC
- if $GET(DDSO(10))'?."^"
- XECUTE DDSO(10)
- End DoDot:1
- +7 ;
- +8 ;WE DO A WHOLE RECURSION TO THE SUBPAGE, AND THEN REPAINT THIS PAGE
- IF $DATA(DDSSTACK)
- if $GET(^DIST(.403,+DDS,21400))
- DO REFRESH^DDS02(DDSSTACK)
- DO ^DDSSTK
- DO R^DDS3
- KILL DDSU
- +9 IF $DATA(DDSBR)#2
- DO BR^DDS2
- if $DATA(DDSBR)#2
- QUIT
- +10 SET DDACT="N"
- +11 ;
- CURSOR NEW ACT,B,BLK,BLK0,FND,N,REP
- +1 KILL DDSACT
- +2 if $DATA(DDSU("N"))[0
- SET DDSU("N")=$GET(@DDSREFS@(DDSPG,DDSBK,DDO,"N"))
- +3 SET FND=0
- +4 IF $DATA(DDSREP)
- IF DDO
- DO MNAV^DDSM(.FND)
- if FND
- QUIT
- +5 ;
- +6 SET B=U
- SET (BLK,BLK0)=DDSBK
- SET N=DDSU("N")
- SET ACT=$SELECT(DDO&$GET(DDSDN):"N",1:DDACT)
- +7 FOR
- Begin DoDot:1
- +8 SET DDO=$PIECE(N,U,$LENGTH($PIECE("U^D^R^L^N",ACT),U))
- +9 IF 'DDO
- SET (DDO,DDSBK)=0
- SET FND=1
- QUIT
- +10 ;
- +11 SET DDSBK=$PIECE(DDO,",",2)
- SET DDO=+DDO
- +12 IF DDSBK
- Begin DoDot:2
- +13 IF $PIECE($GET(@DDSREFS@(DDSPG,DDSBK)),U,4)
- Begin DoDot:3
- +14 SET DDO=$PIECE($GET(@DDSREFS@(DDSPG,DDSBK)),U,9)
- SET ACT="N"
- End DoDot:3
- +15 IF '$TEST
- SET ACT=DDACT
- +16 IF '$PIECE($GET(@DDSREFT@(DDSPG,DDSBK)),U)
- IF DDSDAORG
- SET B=B_DDSBK_U
- +17 IF '$TEST
- IF $PIECE(@DDSREFS@(DDSPG,DDSBK),U,7)>1
- SET REP=1
- SET DDACT="NB"
- SET DDSBR=""
- End DoDot:2
- if $DATA(REP)
- QUIT
- +18 IF '$TEST
- SET DDSBK=BLK
- +19 ;
- +20 IF B'[(U_DDSBK_U)
- SET FND=1
- if DDSBK'=BLK0
- SET DDACT="NB"
- SET DDSBR=""
- SET DDSACT=ACT
- +21 ;
- +22 if 'FND
- SET N=$GET(@DDSREFS@(DDSPG,DDSBK,+DDO,"N"))
- SET BLK=DDSBK
- End DoDot:1
- if FND!$DATA(REP)
- QUIT
- +23 QUIT
- +24 ;
- NP ;;
- +1 ;If in REPEATING BLOCK
- if $DATA(DDSREP)&DDO
- GOTO PGDN^DDSM
- +2 if DDSNP]""
- SET DDSPG=DDSNP
- +3 if DDSNP=""
- SET DDACT="N"
- +4 QUIT
- PP ;;
- +1 ;If in REPEATING BLOCK
- if $DATA(DDSREP)&DDO
- GOTO PGUP^DDSM
- +2 SET DDSPG=$$PP^DDS5(.Y)
- +3 SET DDACT=$SELECT(Y=1:"NP",1:"N")
- +4 QUIT
- NB ;;
- +1 SET DDSBK=$$NB^DDS5(.Y)
- SET DDACT=$SELECT(Y=1:"NB",1:"N")
- +2 QUIT
- SEL ;;
- +1 ;I $G(DDSSEL) W $C(7) Q
- +2 SET DDACT="N"
- GOTO PG^DDSRSEL
- SV ;;
- +1 GOTO SV^DDS02
- QT ;;
- +1 GOTO QT^DDS3
- EX ;;
- +1 GOTO EX^DDS3
- CL ;;
- +1 GOTO CL^DDS3
- MOUSE ;;
- +1 GOTO MOUSE^DDS2
- PRNT ;;
- +1 DO EN^DDSRP(+DDS,DDSPG)
- RF ;;
- +1 ;RE-DO THE DATA BEFORE REFRESHING PAGE
- SET DDACT="N"
- IF $GET(^DIST(.403,+DDS,21400))
- DO REFRESH^DDS02(DDSPG)
- +2 GOTO R^DDSR
- +3 ;
- +4 ;
- UNED(ATT,DEF,N) ;
- +1 QUIT $SELECT(N="":1,$PIECE(ATT,U,4)="":$PIECE(DEF,U,4)=1,1:$PIECE(ATT,U,4)=1)&'$PIECE(N,U,11)