- 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 Jan 18, 2025@03:36:07 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