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

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1DGYKREL ;ALB/REW - Religion Update Post-Init for 10/1 Maintenance Patch ; 6/9/94
2 ;;5.3;Registration;**31**;Aug 13, 1993
3 ;
4EN ;
5 ; This will update the Religion File (#13). The EN tag may be re-run
6 N DGPRINT
7 S DGPRINT=$S($D(ZTQUEUED):0,1:1)
8 W:DGPRINT !!,">>> Updating Religion File (#13) ..."
9 I '$$OKREL W:$G(DGPRINT) !,"Problem with Religion File (#13) Update. Please Call your ISC Support."
10 E W:$G(DGPRINT) !!,"...Religion File (#13) update completed."
11 Q
12OKREL() ;
13 N DGOK
14 S DGOK=1
15 N DGRLLINE,DGRLNODE
16 F DGRLLINE=1:1 S DGRLNODE=$P($T(RELDATA+DGRLLINE),";;",2) Q:DGRLNODE']"" D UPRELIG(DGRLNODE,.DGOK)
17 Q DGOK
18UPRELIG(DGRLNODE,DGOK) ;update a religion
19 N B4NAME,B4CODE,NOWNAME,NOWCODE,DGRELIG,DGRLIFN
20 S B4NAME=$P(DGRLNODE,U,1)
21 S B4CODE=$P(DGRLNODE,U,2)
22 S NOWNAME=$P(DGRLNODE,U,3)
23 S NOWCODE=$P(DGRLNODE,U,4)
24 ;Check for existing religions of same before-name
25 W:$G(DGPRINT) !
26 S DGRLIFN=0 F S DGRLIFN=$O(^DIC(13,"B",B4NAME,DGRLIFN)) Q:'DGRLIFN D
27 .S DGRELIG(DGRLIFN)=""
28 .W:$G(DGPRINT) !,"FOUND MATCH ON NAME. IEN= ",DGRLIFN," FOR ",B4NAME," (Code=",B4CODE,")"
29 .D CHGREL(DGRLIFN,.DGOK)
30 ;Check for existing religions of same before-code
31 S DGRLIFN=0 F S DGRLIFN=$O(^DIC(13,"C",B4CODE,DGRLIFN)) Q:'DGRLIFN D
32 .Q:$D(DGRELIG(DGRLIFN)) ;don't re-do update done based on name
33 .S DGRELIG(DGRLIFN)=""
34 .W:$G(DGPRINT) !,"FOUND MATCH ON CODE. IEN= ",DGRLIFN," FOR ",B4NAME," (Code=",B4CODE,")"
35 .D CHGREL(DGRLIFN,.DGOK)
36 ;If no existing entires by name or code add a new one
37 I '$D(DGRELIG) D
38 .W:$G(DGPRINT) !,"FOUND NO ",B4NAME," (Code=",B4CODE,")"
39 .D NEWREL
40 Q
41NEWREL ;adds a new religion entry
42 I ('$L($G(NOWCODE)))!('$L($G(NOWNAME))) S DGOK=0 W:$G(DGPRINT) !,"MISSING INPUT" G QTNR
43 ;Q
44 N DIC,DIE,DA,DR,X,Y,DGRLIFN
45 S DIC(0)="L",DIC="^DIC(13,"
46 S X=NOWNAME
47 D ^DIC
48 S DA=+Y
49 I DA'>0 D G QTNR
50 .S DGRLIFN=0
51 .S DGOK=0
52 .W:$G(DGPRINT) !,"No religion added"
53 .F S DGRLIFN=$O(^DIC(13,"B",NOWNAME,DGRLIFN)) Q:'DGRLIFN D
54 ..W:$G(DGPRINT) !,"....IEN= ",DGRLIFN," NAME= ",NOWNAME," (Code= ",NOWCODE,") ALREADY EXISTS."
55 I Y W:$G(DGPRINT) !,"...NEW RELIGION ",NOWNAME," (Code=",NOWCODE,")",$S((+$P(Y,U,3)):" ADDED",1:" ALREADY EXISTS")
56 S DR="3///^S X=NOWCODE"
57 S DIE=DIC
58 D ^DIE
59QTNR Q
60CHGREL(DGRLIFN,DGOK) ;
61 N DA,DIC,DIE,DGOLDNM,DGOLDCD,DR,X
62 S DA=DGRLIFN,DIE="^DIC(13,"
63 S DGOLDNM=$P($G(^DIC(13,+DGRLIFN,0)),U,1)
64 S DGOLDCD=$P($G(^DIC(13,+DGRLIFN,0)),U,4)
65 I (DGOLDNM=NOWNAME)&(DGOLDCD=NOWCODE) D
66 .W:$G(DGPRINT) !,"...NO CHANGE NEEDED FOR RELIGION ",DGOLDNM," (Code=",DGOLDCD,")"
67 E D
68 .W !,"...CHANGING RELIGION ",DGOLDNM," (Code=",DGOLDCD,") TO ",NOWNAME," (Code=",NOWCODE,")"
69 .S DR=".01///^S X=NOWNAME;3///^S X=NOWCODE"
70 .D ^DIE
71 Q
72RELDATA ;may not need #24
73 ;;PROTESTANT, OTHER^24^PROTESTANT, OTHER^24
74 ;;PROTESTANT, NO PREFERENCE^25^PROTESTANT, NO DENOMINATION^25
75 ;;NATIVE AMERICAN^30^NATIVE AMERICAN^30
76 ;;BUDDHIST^31^BUDDHIST^31
Note: See TracBrowser for help on using the repository browser.