| 1 | DGYKREL ;ALB/REW - Religion Update Post-Init for 10/1 Maintenance Patch ; 6/9/94
|
|---|
| 2 | ;;5.3;Registration;**31**;Aug 13, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | EN ;
|
|---|
| 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
|
|---|
| 12 | OKREL() ;
|
|---|
| 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
|
|---|
| 18 | UPRELIG(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
|
|---|
| 41 | NEWREL ;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
|
|---|
| 59 | QTNR Q
|
|---|
| 60 | CHGREL(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
|
|---|
| 72 | RELDATA ;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
|
|---|
