DG311PTR ;ALB/JJG-Patient Relation Pointer Utility ; 23 MAY 2000
;;5.3;Registration;**311**;Aug 13, 1993
;
; This routine will be run as a post-installation routine for patch
; DG*5.3*311. The main purpose for this routine is to clean up any
; invalid pointers to the PATIENT RELATION file (#408.12) that may
; exist in the PATIENT RELATION field (408.21,.02) of the INDIVIDUAL
; ANNUAL INCOME file (#408.21).
;
POST ;entry point for post-install, setting up checkpoints
N %
I $D(XPDNM) S %=$$NEWCP^XPDUTL("DGIEN21","MAIN^DG311PTR",0)
Q
MAIN ;Main Driver
N DGRECNT
S DGRECNT=0
D LOOP
Q
LOOP ; Locate and correct invalid pointers
N DGIEN21,DGIEN22,DGNOD22,DGIEN2,DGRLIEN
S DGIEN21=""
I $D(XPDNM) S DGIEN21=+$$PARCP^XPDUTL("DGIEN21")
F S DGIEN21=$O(^DGMT(408.21,"C",0,DGIEN21)) Q:'DGIEN21 D
.S DGIEN22=0
.S DGIEN22=$O(^DGMT(408.22,"AIND",DGIEN21,DGIEN22)) Q:'DGIEN22
.S DGNOD22=$G(^DGMT(408.22,DGIEN22,0))
.S DGIEN2=$P(DGNOD22,"^") Q:'DGIEN2
.S DGRLIEN=0
.S DGRLIEN=$O(^DGPR(408.12,"B",DGIEN2,DGRLIEN)) Q:'DGRLIEN
.D UPDATE
.I $D(XPDNM) S %=$$UPCP^XPDUTL("DGIEN21",DGIEN21) ; Update Checkpoint
Q
UPDATE ;Update .02 field in Individual Annual Income file
N DATA,DGENDA,ERROR
S DATA(.02)=DGRLIEN,DGENDA=DGIEN21,ERROR=""
I $$UPD^DGENDBS(408.21,.DGENDA,.DATA,.ERROR) D
.S DGRECNT=DGRECNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG311PTR 1360 printed Dec 13, 2024@02:35:25 Page 2
DG311PTR ;ALB/JJG-Patient Relation Pointer Utility ; 23 MAY 2000
+1 ;;5.3;Registration;**311**;Aug 13, 1993
+2 ;
+3 ; This routine will be run as a post-installation routine for patch
+4 ; DG*5.3*311. The main purpose for this routine is to clean up any
+5 ; invalid pointers to the PATIENT RELATION file (#408.12) that may
+6 ; exist in the PATIENT RELATION field (408.21,.02) of the INDIVIDUAL
+7 ; ANNUAL INCOME file (#408.21).
+8 ;
POST ;entry point for post-install, setting up checkpoints
+1 NEW %
+2 IF $DATA(XPDNM)
SET %=$$NEWCP^XPDUTL("DGIEN21","MAIN^DG311PTR",0)
+3 QUIT
MAIN ;Main Driver
+1 NEW DGRECNT
+2 SET DGRECNT=0
+3 DO LOOP
+4 QUIT
LOOP ; Locate and correct invalid pointers
+1 NEW DGIEN21,DGIEN22,DGNOD22,DGIEN2,DGRLIEN
+2 SET DGIEN21=""
+3 IF $DATA(XPDNM)
SET DGIEN21=+$$PARCP^XPDUTL("DGIEN21")
+4 FOR
SET DGIEN21=$ORDER(^DGMT(408.21,"C",0,DGIEN21))
if 'DGIEN21
QUIT
Begin DoDot:1
+5 SET DGIEN22=0
+6 SET DGIEN22=$ORDER(^DGMT(408.22,"AIND",DGIEN21,DGIEN22))
if 'DGIEN22
QUIT
+7 SET DGNOD22=$GET(^DGMT(408.22,DGIEN22,0))
+8 SET DGIEN2=$PIECE(DGNOD22,"^")
if 'DGIEN2
QUIT
+9 SET DGRLIEN=0
+10 SET DGRLIEN=$ORDER(^DGPR(408.12,"B",DGIEN2,DGRLIEN))
if 'DGRLIEN
QUIT
+11 DO UPDATE
+12 ; Update Checkpoint
IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGIEN21",DGIEN21)
End DoDot:1
+13 QUIT
UPDATE ;Update .02 field in Individual Annual Income file
+1 NEW DATA,DGENDA,ERROR
+2 SET DATA(.02)=DGRLIEN
SET DGENDA=DGIEN21
SET ERROR=""
+3 IF $$UPD^DGENDBS(408.21,.DGENDA,.DATA,.ERROR)
Begin DoDot:1
+4 SET DGRECNT=DGRECNT+1
End DoDot:1
+5 QUIT
