source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDS5.m@ 1150

Last change on this file since 1150 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
RevLine 
[613]1DDS5 ;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;9:53 AM 1 Oct 1999
2 ;;22.0;VA FileMan;**8**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 I X="" D:DDSOLD="" NF^DDS01 D:DDSOLD]"" DM^DDS6 Q
5 I DIR0N,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSGL,1,28))=$E(DDSGL,29,999)_X
6 I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDS5PG=^(DDO)
7 E I $P($G(DDSO(7)),U,2)="" D:X=DDSOLD NF^DDS01 Q
8 D MULT,R^DDSR
9 ;
10 K DDSSTACK
11 X:$G(^DIST(.404,DDSBK,40,DDO,10))'?."^" ^(10)
12 I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSBR
13 D:$D(DDSBR)#2 BR^DDS2
14 Q
15MULT ;
16 N DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP
17 ;
18 I $G(DDS5PG) S DDSPG=DDS5PG K DDS5PG
19 E D
20 . S DDSPG(1)=$P($G(DDSO(7)),U,2) Q:DDSPG(1)=""
21 . S DDSPG=$O(^DIST(.403,+DDS,40,"B",DDSPG(1),"")) Q:DDSPG=""
22 Q:$D(^DIST(.403,+DDS,40,+$G(DDSPG),0))[0
23 N:'$P(^(0),U,6) DDSSC
24 ;
25 D DDA(Y,.DA,.DDSDL)
26 I Y'=-1 D
27 . N DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG
28 . S DIE=U_$P(DDSU("M"),U,2),DDP=$P(DDSU("M"),U,3)
29 . S DDSDLORG=DDSDL,DDSDAORG=DA,DDSDA=DA_","
30 . F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI),DDSDA=DDSDA_DA(DDSI)_","
31 . K DDSI
32 . S DDSSTK=1
33 . D PROC^DDS
34 D LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
35 D UDA(.DA,.DDSDL)
36 Q
37 ;
38LST(DA,DDSDL,DDP,DDSDA,DDSFLD) ;Save last edited subrecord
39 ;In: DA array, DDSDL at subfile level
40 ; DDP, DDSDA, DDSFLD at file level
41 N DDSDIE,Y
42 S DDSDIE=U_$P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2)
43 I $D(@(DDSDIE_"+$G(DA),0)"))[0 D
44 . S DA=$S($D(@(DDSDIE_"0)"))#2:$P(^(0),U,3),1:$O(^(0)))
45 . I DA>0 D
46 .. N C
47 .. S Y=$P(@(DDSDIE_DA_",0)"),U)
48 .. S C=$P(^DD(+$P(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2)
49 .. D Y^DIQ
50 . E S (DA,Y)=""
51 E S (DA,Y)=""
52 I DA>0,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSDIE,1,28))=$E(DDSDIE,29,999)_DA
53 ;
54 S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y,^("D")=DA,DDACT="N"
55 Q
56 ;
57SEL ;Issue the read at the Select mult prompt
58 S DIR(0)="PO"_DDSGL_":QEMZ"_$E("L",'$D(DDSTP)&'$P($G(DDSO(4)),U,5))_$E("V",$P($G(DDSO(4)),U,6))
59 I $D(@(DDSGL_"0)"))[0 S ^(0)=U_$P($G(DDSU("DD")),U,2)_U_U
60 E I $P(@(DDSGL_"0)"),U,2)'=$P($G(DDSU("DD")),U,2) S $P(^(0),U,2)=$P($G(DDSU("DD")),U,2)
61 D DDA(0,.DA,.DDSDL) S DDSDA="0,"_DDSDA
62 D ^DIR K DIR,DUOUT,DIRUT,DIROUT
63 D UDA(.DA,.DDSDL) S DDSDA=$P(DDSDA,",",2,999)
64 Q:DDACT'="N"
65 ;
66 I DIR0N S (X,Y)=DDSOLD Q
67 I $P(Y,U,3)=1 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL
68 E S DIR0N=1
69 S Y=$P(Y,U)
70 S:X="" Y=""
71 Q
72 ;
73DDA(Y,DA,DL) ;Push Y onto DA array
74 N I
75 F I=DL:-1:1 S DA(I+1)=DA(I)
76 S DA(1)=DA,DL=DL+1
77 S (DA,@("D"_DL))=$S(+$P($G(Y),"E"):+$P(Y,"E"),1:0)
78 Q
79 ;
80UDA(DA,DL) ;Pop DA array
81 N I
82 S DA=DA(1)
83 F I=2:1:DL S DA(I-1)=DA(I)
84 K DA(DL),@("D"_DL)
85 S DL=DL-1
86 Q
87NP(Y) ;Returns: Next page
88 ; (Y=1 if found, 0 if not found)
89 N P,P1
90 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,4)
91 I P1]"" D
92 . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
93 . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
94 Q $S(Y=1:P,1:DDSPG)
95PP(Y) ;
96 N P,P1
97 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,5)
98 I P1]"" D
99 . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
100 . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
101 Q $S(Y=1:P,1:DDSPG)
102NB(Y) ;
103 N B,BO,X
104 S (B,Y)=0,BO=$P($G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2)
105 I BO F D Q:B=DDSBK!Y
106 . S BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO)) S:'BO BO=$O(^("")) S B=$O(^(BO,""))
107 . S X=$G(@DDSREFS@(DDSPG,B))
108 . I $P(X,U)]"",$P(X,U,5)'="h",$P(X,U,9),B'=DDSBK S Y=1
109 Q B
Note: See TracBrowser for help on using the repository browser.