source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE4.m@ 1141

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

initial load of WorldVistAEHR

File size: 2.3 KB
RevLine 
[613]1DGRPE4 ;ALB/GTS - REGISTRATIONS EDITS ; 5/25/05 08:53am
2 ;;5.3;Registration;**624**;Aug 13, 1993
3 ;
4 ;DGDR contains a string of edits; edit=screen*10+item #
5 ;
6 ;line tag screen*10+item*1000 = continuation line
7 ;
8 N DGPH,DGPHFLG,UPARROUT
9 S UPARROUT=0
10 K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
11 I (DGDR["401") DO
12 . S J1="A401"
13 . S DGDRD=$P($T(@J1),";;",2)
14 . D S
15 . D ^DIE
16 . I $D(Y)'=0 S UPARROUT=1
17 . I UPARROUT=0 DO
18 . . K DR,DA,Y,DIE
19 . . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
20 . . S J1="B401"
21 . . S DGDRD=$P($T(@J1),";;",2)
22 . . D S
23 . . S DIE("NO^")=""
24 . . D ^DIE
25 . . K DR,DA,Y,DIE
26 . . N DGEMPST
27 . . S DGEMPST=(+$P($G(^DPT(DFN,.311)),"^",15))
28 . . I (DGEMPST]"")!(DGEMPST'=3)!(DGEMPST'=9) DO
29 . . . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
30 . . . S J1="C401"
31 . . . S DGDRD=$P($T(@J1),";;",2)
32 . . . D S
33 . . . D ^DIE
34 K DR,DA,Y,DIE
35 F Q:DGDR'["401," S DGDR=$P(DGDR,"401,")_""_$P(DGDR,"401,",2,999)
36 I (UPARROUT=0)&(DGDR["402") DO
37 . K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
38 . S J1="A402"
39 . S DGDRD=$P($T(@J1),";;",2)
40 . D S
41 . D ^DIE
42 . I $D(Y)'=0 S UPARROUT=1
43 . I UPARROUT=0 DO
44 . . K DR,DA,Y,DIE
45 . . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
46 . . S J1="B402"
47 . . S DGDRD=$P($T(@J1),";;",2)
48 . . D S
49 . . S DIE("NO^")=""
50 . . D ^DIE
51 . . K DR,DA,Y,DIE
52 . . N DGEMPST
53 . . S DGEMPST=(+$P($G(^DPT(DFN,.311)),"^",15))
54 . . I (DGEMPST]"")!(DGEMPST'=3)!(DGEMPST'=9) DO
55 . . . S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
56 . . . S J1="C402"
57 . . . S DGDRD=$P($T(@J1),";;",2)
58 . . . D S
59 . . . D ^DIE
60 K DR,DA,Y,DIE
61 F Q:DGDR'["402," S DGDR=$P(DGDR,"402,")_""_$P(DGDR,"402,",2,999)
62 K DR,DA,Y,DIE
63 Q
64S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
65 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
66 Q
67A401 ;;.07;
68B401 ;;.31115;
69C401 ;;S DGST=$P(^DPT(DA,.311),"^",15);S:$S(DGST']"":1,DGST=3:1,DGST=9:1,1:0) Y=0 I Y=0 K DGST;S:($P(^DPT(DA,.311),"^",15)'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;K DGST;
70A402 ;;.2514;
71B402 ;;.2515;
72C402 ;;S DGST=$P(^DPT(DA,.25),"^",15);S:$S(DGST']"":1,DGST=3:1,DGST=9:1,1:0) Y=0 I Y=0 K DGST;S:($P(^DPT(DA,.25),"^",15)'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;K DGST;
Note: See TracBrowser for help on using the repository browser.