Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDS01

DDS01.m

Go to the documentation of this file.
  1. DDS01 ;SFISC/MLH,MKO-PROCESS BLOCK ;24JAN2013
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. ;***BE CAREFUL PUTTING TAGS INTO THIS IMPORTANT ROUTINE! $T LOOKS FOR A NON-EXISTENCE OF A TAG!****
  1. ;
  1. F D IN,CHK Q:"^Q^NB^NP^"[(U_DDACT_U)
  1. Q
  1. ;
  1. IN K DDSBR,DDSFLD,DDSO,DDSU,DIR,DDSREPNT
  1. S:$D(@DDSREFS@(DDSPG,$S(DDO:DDSBK,1:0),DDO,"N"))#2 DDSU("N")=^("N")
  1. I DDM,'$G(DDSKM) D CLRMSG^DDS
  1. G:'DDO COM^DDSCOM
  1. ;
  1. S DDSOSV=0
  1. F DDSI=0,1,2,4,7,10:1:14,20 D ;MOVE FIELD DEFINITION INTO DDSO ARRAY
  1. . S:$D(^DIST(.404,DDSBK,40,DDO,DDSI))#2 DDSO(DDSI)=^(DDSI)
  1. K DDSI
  1. ;
  1. S DDSFLD=$G(DDSO(1)) K DDSO(1)
  1. I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,DDSFLD=DDO_","_DDSBK
  1. ;
  1. I DDSFLD]"",DDSDA]"" M DDSU=@DDSREFT@("F"_DDP,DDSDA,DDSFLD) ;Restore field's specs & value from ^TMP
  1. ;
  1. I '$D(DDSREP)!DDSDA,$$UNED($G(DDSU("A")),$G(DDSO(4)),$G(DDSU("N"))) D Q
  1. . I $D(DDSACT)#2 S DDACT=DDSACT K DDSACT
  1. . S:DDACT="U" DDACT="L"
  1. . S:DDACT="D" DDACT="R"
  1. . D CURSOR Q:$D(DDSBR)#2
  1. . S DDSCHKQ=1
  1. K DDSACT
  1. ;
  1. S (X,DDSOLD)=$G(DDSU("D")),DDSEXT=$G(DDSU("X"),X)
  1. ;
  1. X:$G(DDSO(11))'?."^" DDSO(11) ;PRE-ACTION
  1. I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
  1. I DDACT]"",$T(@DDACT)]"" D @DDACT S DDSCHKQ=1 Q
  1. ;
  1. S DIR0N=1 Q:DDSFLD=""
  1. ;
  1. S:$G(^DD(DDP,DDSFLD,0))'?."^" DDSU("DD")=^(0)
  1. I $D(DDSU("N"))[0 S DDACT="N" Q
  1. Q:$D(DDSO(2))[0
  1. ;
  1. D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
  1. K DDSKM,DDQ
  1. ;
  1. S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3)
  1. S:$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,10) $P(DIR0,U,6)=1
  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
  1. ;
  1. I $D(DDSREP),'DDSDA,$P(DDSO(0),U,3)'=2 K DDSU("DD") G SEL^DDSM
  1. I $D(DDSU("M"))#2 S DDSGL=U_$P(DDSU("M"),U,2) G:'DDSU("M") WP^DDSWP
  1. S DIR("B")=$G(DDSU("X"),DDSOLD)
  1. ;
  1. I $D(DDSU("M"))#2 D SEL^DDS5 G:X'=DDSOLD&(DDACT="N") EXT
  1. I $P($G(DDSO(0)),U,3)'=2 S DIR(0)=DDP_","_DDSFLD_"O" ;IT'S A FIELD-TYPE READ
  1. E D DIR^DDSFO
  1. D ^DIR K DIR,DUOUT,DIRUT,DIROUT ;DO THE READ!
  1. I DIR0N S (X,Y)=DDSOLD Q
  1. ;
  1. EXT I $E(X)=U!$D(DTOUT) S DIR0N=1 Q
  1. G EXT^DDS02
  1. ;
  1. CHK Q:$D(DDSBR)#2
  1. I $G(DDSCHKQ)=1 K DDSCHKQ Q
  1. G:$D(DTOUT) TO^DDS3
  1. G:$E(X)=U UPA^DDS2
  1. I $G(DDSFLD)=.01,X="",$G(DA),DDSOLD]"" G ^DDS6 ;DELETE ENTRY
  1. ;
  1. I $P($G(DDSU("DD")),U,2)["I",$G(DDSOLD)]"" D I %]"",X'=% S DDSNOED=1 ;UNEDITABLE FIELD ALREADY HAS A VALUE
  1. .N DIERR S %=$$GET1^DIQ(DDSFILE,DDSDA,DDSFLD)
  1. E I $P($G(DDSU("DD")),U,5,99)["DINUM" S DDSNOED=1
  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
  1. I $G(DDSFLD)]"",$G(DDSOLD)]"",X'=DDSOLD,DDSNOED S %=1 D I %["," S DDSDA=% D POSDA^DDSM(DDSDA,DDSOLD) K DDSCHKQ Q
  1. .N F,L
  1. .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:%[","
  1. ..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
  1. .I %'["," S F="" F S F=$O(@DDSREFT@("F"_DDP,F)) Q:F="" D Q:%[","
  1. ..I F'=DDSDA S L=$G(@DDSREFT@("F"_DDP,F,DDSFLD,"D")) I L]"",$P(L,X)="" S %=F ;FIND A MATCHING FIELD VALUE
  1. .S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X")
  1. .
  1. 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)
  1. .S %=$P($G(DDSO(0)),U,2) I %="" S %=$P($G(DDSO(0)),U,5) ;GET CAPTION or UNIQUE NAME
  1. .D MSG^DDSMSG($$EZBLD^DIALOG(3090,%),1) ;'UNEDITABLE'
  1. .I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0
  1. .S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X")
  1. ;
  1. K DDSCHKQ,DDSNOED
  1. ;
  1. I $G(DDSFLD)=.01,$G(DDSPTB)]"",$G(DDSREP)<2,'DIR0N D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA)
  1. I $G(DDSO(12))'?."^" X DDSO(12) ;POST ACTION
  1. ;
  1. I 'DIR0N,DDO,$G(DDSFLD)]"" D
  1. . I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0
  1. . S DDSCHG=1
  1. . I DDSDA!'$D(DDSREP),+$G(DDSU("F"))'=1 S $P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"F"),U)=1
  1. . I $G(DDSO(13))'?."^" X DDSO(13) ;POST ACTION ON CHANGE
  1. . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG)
  1. . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG)
  1. ;
  1. I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
  1. Q:DDACT="" I $T(@DDACT)]"" G @DDACT
  1. I 'DDO G:X]"" ^DDS3 S DDSO(0)=0
  1. I DDACT="D",$D(DDSREP),'DA S DDACT="N" ;GFT DON'T DOWN-ARROW THRU A MULTIPLE THAT HAS NO .01 FIELD DEFINED
  1. G:"^U^D^R^L^"[(U_DDACT_U) CURSOR
  1. G:$D(DDSU("M"))[0 NF
  1. G:DDSU("M") ^DDS5
  1. D EDIT^DDSWP I '$D(DDGLCLR) S DDACT="Q" Q
  1. D R^DDSR
  1. ;
  1. NF I 'DDO,DDSOSV S DDO=DDSOSV Q
  1. ;
  1. I DDO,$S($D(DDSREP):DDSDA,1:1) D
  1. . D:'$D(DDSU("M"))
  1. .. I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDSSTACK="`"_^(DDO) ;ANOTHER PAGE HAS THIS FIELD AS ITS PARENT FIELD!
  1. .. E I $P($G(DDSO(7)),U,2)]"" S DDSSTACK=$P(DDSO(7),U,2) ;OR THERE IS A SUBPAGE LINK FROM THIS FIELD
  1. . X:$G(DDSO(10))'?."^" DDSO(10) ;BRANCHING LOGIC
  1. ;
  1. 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
  1. I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
  1. S DDACT="N"
  1. ;
  1. CURSOR N ACT,B,BLK,BLK0,FND,N,REP
  1. K DDSACT
  1. S:$D(DDSU("N"))[0 DDSU("N")=$G(@DDSREFS@(DDSPG,DDSBK,DDO,"N"))
  1. S FND=0
  1. I $D(DDSREP),DDO D MNAV^DDSM(.FND) Q:FND
  1. ;
  1. S B=U,(BLK,BLK0)=DDSBK,N=DDSU("N"),ACT=$S(DDO&$G(DDSDN):"N",1:DDACT)
  1. F D Q:FND!$D(REP)
  1. . S DDO=$P(N,U,$L($P("U^D^R^L^N",ACT),U))
  1. . I 'DDO S (DDO,DDSBK)=0,FND=1 Q
  1. . ;
  1. . S DDSBK=$P(DDO,",",2),DDO=+DDO
  1. . I DDSBK D Q:$D(REP)
  1. .. I $P($G(@DDSREFS@(DDSPG,DDSBK)),U,4) D
  1. ... S DDO=$P($G(@DDSREFS@(DDSPG,DDSBK)),U,9),ACT="N"
  1. .. E S ACT=DDACT
  1. .. I '$P($G(@DDSREFT@(DDSPG,DDSBK)),U),DDSDAORG S B=B_DDSBK_U
  1. .. E I $P(@DDSREFS@(DDSPG,DDSBK),U,7)>1 S REP=1,DDACT="NB",DDSBR=""
  1. . E S DDSBK=BLK
  1. . ;
  1. . I B'[(U_DDSBK_U) S FND=1 S:DDSBK'=BLK0 DDACT="NB",DDSBR="",DDSACT=ACT
  1. . ;
  1. . S:'FND N=$G(@DDSREFS@(DDSPG,DDSBK,+DDO,"N")),BLK=DDSBK
  1. Q
  1. ;
  1. NP ;;
  1. G:$D(DDSREP)&DDO PGDN^DDSM ;If in REPEATING BLOCK
  1. S:DDSNP]"" DDSPG=DDSNP
  1. S:DDSNP="" DDACT="N"
  1. Q
  1. PP ;;
  1. G:$D(DDSREP)&DDO PGUP^DDSM ;If in REPEATING BLOCK
  1. S DDSPG=$$PP^DDS5(.Y)
  1. S DDACT=$S(Y=1:"NP",1:"N")
  1. Q
  1. NB ;;
  1. S DDSBK=$$NB^DDS5(.Y),DDACT=$S(Y=1:"NB",1:"N")
  1. Q
  1. SEL ;;
  1. ;I $G(DDSSEL) W $C(7) Q
  1. S DDACT="N" G PG^DDSRSEL
  1. SV ;;
  1. G SV^DDS02
  1. QT ;;
  1. G QT^DDS3
  1. EX ;;
  1. G EX^DDS3
  1. CL ;;
  1. G CL^DDS3
  1. MOUSE ;;
  1. G MOUSE^DDS2
  1. PRNT ;;
  1. D EN^DDSRP(+DDS,DDSPG)
  1. RF ;;
  1. S DDACT="N" I $G(^DIST(.403,+DDS,21400)) D REFRESH^DDS02(DDSPG) ;RE-DO THE DATA BEFORE REFRESHING PAGE
  1. G R^DDSR
  1. ;
  1. ;
  1. UNED(ATT,DEF,N) ;
  1. Q $S(N="":1,$P(ATT,U,4)="":$P(DEF,U,4)=1,1:$P(ATT,U,4)=1)&'$P(N,U,11)