DGYKREL ;ALB/REW - Religion Update Post-Init for 10/1 Maintenance Patch ; 6/9/94
;;5.3;Registration;**31**;Aug 13, 1993
;
EN ;
; This will update the Religion File (#13). The EN tag may be re-run
N DGPRINT
S DGPRINT=$S($D(ZTQUEUED):0,1:1)
W:DGPRINT !!,">>> Updating Religion File (#13) ..."
I '$$OKREL W:$G(DGPRINT) !,"Problem with Religion File (#13) Update. Please Call your ISC Support."
E W:$G(DGPRINT) !!,"...Religion File (#13) update completed."
Q
OKREL() ;
N DGOK
S DGOK=1
N DGRLLINE,DGRLNODE
F DGRLLINE=1:1 S DGRLNODE=$P($T(RELDATA+DGRLLINE),";;",2) Q:DGRLNODE']"" D UPRELIG(DGRLNODE,.DGOK)
Q DGOK
UPRELIG(DGRLNODE,DGOK) ;update a religion
N B4NAME,B4CODE,NOWNAME,NOWCODE,DGRELIG,DGRLIFN
S B4NAME=$P(DGRLNODE,U,1)
S B4CODE=$P(DGRLNODE,U,2)
S NOWNAME=$P(DGRLNODE,U,3)
S NOWCODE=$P(DGRLNODE,U,4)
;Check for existing religions of same before-name
W:$G(DGPRINT) !
S DGRLIFN=0 F S DGRLIFN=$O(^DIC(13,"B",B4NAME,DGRLIFN)) Q:'DGRLIFN D
.S DGRELIG(DGRLIFN)=""
.W:$G(DGPRINT) !,"FOUND MATCH ON NAME. IEN= ",DGRLIFN," FOR ",B4NAME," (Code=",B4CODE,")"
.D CHGREL(DGRLIFN,.DGOK)
;Check for existing religions of same before-code
S DGRLIFN=0 F S DGRLIFN=$O(^DIC(13,"C",B4CODE,DGRLIFN)) Q:'DGRLIFN D
.Q:$D(DGRELIG(DGRLIFN)) ;don't re-do update done based on name
.S DGRELIG(DGRLIFN)=""
.W:$G(DGPRINT) !,"FOUND MATCH ON CODE. IEN= ",DGRLIFN," FOR ",B4NAME," (Code=",B4CODE,")"
.D CHGREL(DGRLIFN,.DGOK)
;If no existing entires by name or code add a new one
I '$D(DGRELIG) D
.W:$G(DGPRINT) !,"FOUND NO ",B4NAME," (Code=",B4CODE,")"
.D NEWREL
Q
NEWREL ;adds a new religion entry
I ('$L($G(NOWCODE)))!('$L($G(NOWNAME))) S DGOK=0 W:$G(DGPRINT) !,"MISSING INPUT" G QTNR
;Q
N DIC,DIE,DA,DR,X,Y,DGRLIFN
S DIC(0)="L",DIC="^DIC(13,"
S X=NOWNAME
D ^DIC
S DA=+Y
I DA'>0 D G QTNR
.S DGRLIFN=0
.S DGOK=0
.W:$G(DGPRINT) !,"No religion added"
.F S DGRLIFN=$O(^DIC(13,"B",NOWNAME,DGRLIFN)) Q:'DGRLIFN D
..W:$G(DGPRINT) !,"....IEN= ",DGRLIFN," NAME= ",NOWNAME," (Code= ",NOWCODE,") ALREADY EXISTS."
I Y W:$G(DGPRINT) !,"...NEW RELIGION ",NOWNAME," (Code=",NOWCODE,")",$S((+$P(Y,U,3)):" ADDED",1:" ALREADY EXISTS")
S DR="3///^S X=NOWCODE"
S DIE=DIC
D ^DIE
QTNR Q
CHGREL(DGRLIFN,DGOK) ;
N DA,DIC,DIE,DGOLDNM,DGOLDCD,DR,X
S DA=DGRLIFN,DIE="^DIC(13,"
S DGOLDNM=$P($G(^DIC(13,+DGRLIFN,0)),U,1)
S DGOLDCD=$P($G(^DIC(13,+DGRLIFN,0)),U,4)
I (DGOLDNM=NOWNAME)&(DGOLDCD=NOWCODE) D
.W:$G(DGPRINT) !,"...NO CHANGE NEEDED FOR RELIGION ",DGOLDNM," (Code=",DGOLDCD,")"
E D
.W !,"...CHANGING RELIGION ",DGOLDNM," (Code=",DGOLDCD,") TO ",NOWNAME," (Code=",NOWCODE,")"
.S DR=".01///^S X=NOWNAME;3///^S X=NOWCODE"
.D ^DIE
Q
RELDATA ;may not need #24
;;PROTESTANT, OTHER^24^PROTESTANT, OTHER^24
;;PROTESTANT, NO PREFERENCE^25^PROTESTANT, NO DENOMINATION^25
;;NATIVE AMERICAN^30^NATIVE AMERICAN^30
;;BUDDHIST^31^BUDDHIST^31
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYKREL 2938 printed Dec 13, 2024@03:00:13 Page 2
DGYKREL ;ALB/REW - Religion Update Post-Init for 10/1 Maintenance Patch ; 6/9/94
+1 ;;5.3;Registration;**31**;Aug 13, 1993
+2 ;
EN ;
+1 ; This will update the Religion File (#13). The EN tag may be re-run
+2 NEW DGPRINT
+3 SET DGPRINT=$SELECT($DATA(ZTQUEUED):0,1:1)
+4 if DGPRINT
WRITE !!,">>> Updating Religion File (#13) ..."
+5 IF '$$OKREL
if $GET(DGPRINT)
WRITE !,"Problem with Religion File (#13) Update. Please Call your ISC Support."
+6 IF '$TEST
if $GET(DGPRINT)
WRITE !!,"...Religion File (#13) update completed."
+7 QUIT
OKREL() ;
+1 NEW DGOK
+2 SET DGOK=1
+3 NEW DGRLLINE,DGRLNODE
+4 FOR DGRLLINE=1:1
SET DGRLNODE=$PIECE($TEXT(RELDATA+DGRLLINE),";;",2)
if DGRLNODE']""
QUIT
DO UPRELIG(DGRLNODE,.DGOK)
+5 QUIT DGOK
UPRELIG(DGRLNODE,DGOK) ;update a religion
+1 NEW B4NAME,B4CODE,NOWNAME,NOWCODE,DGRELIG,DGRLIFN
+2 SET B4NAME=$PIECE(DGRLNODE,U,1)
+3 SET B4CODE=$PIECE(DGRLNODE,U,2)
+4 SET NOWNAME=$PIECE(DGRLNODE,U,3)
+5 SET NOWCODE=$PIECE(DGRLNODE,U,4)
+6 ;Check for existing religions of same before-name
+7 if $GET(DGPRINT)
WRITE !
+8 SET DGRLIFN=0
FOR
SET DGRLIFN=$ORDER(^DIC(13,"B",B4NAME,DGRLIFN))
if 'DGRLIFN
QUIT
Begin DoDot:1
+9 SET DGRELIG(DGRLIFN)=""
+10 if $GET(DGPRINT)
WRITE !,"FOUND MATCH ON NAME. IEN= ",DGRLIFN," FOR ",B4NAME," (Code=",B4CODE,")"
+11 DO CHGREL(DGRLIFN,.DGOK)
End DoDot:1
+12 ;Check for existing religions of same before-code
+13 SET DGRLIFN=0
FOR
SET DGRLIFN=$ORDER(^DIC(13,"C",B4CODE,DGRLIFN))
if 'DGRLIFN
QUIT
Begin DoDot:1
+14 ;don't re-do update done based on name
if $DATA(DGRELIG(DGRLIFN))
QUIT
+15 SET DGRELIG(DGRLIFN)=""
+16 if $GET(DGPRINT)
WRITE !,"FOUND MATCH ON CODE. IEN= ",DGRLIFN," FOR ",B4NAME," (Code=",B4CODE,")"
+17 DO CHGREL(DGRLIFN,.DGOK)
End DoDot:1
+18 ;If no existing entires by name or code add a new one
+19 IF '$DATA(DGRELIG)
Begin DoDot:1
+20 if $GET(DGPRINT)
WRITE !,"FOUND NO ",B4NAME," (Code=",B4CODE,")"
+21 DO NEWREL
End DoDot:1
+22 QUIT
NEWREL ;adds a new religion entry
+1 IF ('$LENGTH($GET(NOWCODE)))!('$LENGTH($GET(NOWNAME)))
SET DGOK=0
if $GET(DGPRINT)
WRITE !,"MISSING INPUT"
GOTO QTNR
+2 ;Q
+3 NEW DIC,DIE,DA,DR,X,Y,DGRLIFN
+4 SET DIC(0)="L"
SET DIC="^DIC(13,"
+5 SET X=NOWNAME
+6 DO ^DIC
+7 SET DA=+Y
+8 IF DA'>0
Begin DoDot:1
+9 SET DGRLIFN=0
+10 SET DGOK=0
+11 if $GET(DGPRINT)
WRITE !,"No religion added"
+12 FOR
SET DGRLIFN=$ORDER(^DIC(13,"B",NOWNAME,DGRLIFN))
if 'DGRLIFN
QUIT
Begin DoDot:2
+13 if $GET(DGPRINT)
WRITE !,"....IEN= ",DGRLIFN," NAME= ",NOWNAME," (Code= ",NOWCODE,") ALREADY EXISTS."
End DoDot:2
End DoDot:1
GOTO QTNR
+14 IF Y
if $GET(DGPRINT)
WRITE !,"...NEW RELIGION ",NOWNAME," (Code=",NOWCODE,")",$SELECT((+$PIECE(Y,U,3)):" ADDED",1:" ALREADY EXISTS")
+15 SET DR="3///^S X=NOWCODE"
+16 SET DIE=DIC
+17 DO ^DIE
QTNR QUIT
CHGREL(DGRLIFN,DGOK) ;
+1 NEW DA,DIC,DIE,DGOLDNM,DGOLDCD,DR,X
+2 SET DA=DGRLIFN
SET DIE="^DIC(13,"
+3 SET DGOLDNM=$PIECE($GET(^DIC(13,+DGRLIFN,0)),U,1)
+4 SET DGOLDCD=$PIECE($GET(^DIC(13,+DGRLIFN,0)),U,4)
+5 IF (DGOLDNM=NOWNAME)&(DGOLDCD=NOWCODE)
Begin DoDot:1
+6 if $GET(DGPRINT)
WRITE !,"...NO CHANGE NEEDED FOR RELIGION ",DGOLDNM," (Code=",DGOLDCD,")"
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 WRITE !,"...CHANGING RELIGION ",DGOLDNM," (Code=",DGOLDCD,") TO ",NOWNAME," (Code=",NOWCODE,")"
+9 SET DR=".01///^S X=NOWNAME;3///^S X=NOWCODE"
+10 DO ^DIE
End DoDot:1
+11 QUIT
RELDATA ;may not need #24
+1 ;;PROTESTANT, OTHER^24^PROTESTANT, OTHER^24
+2 ;;PROTESTANT, NO PREFERENCE^25^PROTESTANT, NO DENOMINATION^25
+3 ;;NATIVE AMERICAN^30^NATIVE AMERICAN^30
+4 ;;BUDDHIST^31^BUDDHIST^31
