Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DG53819C

DG53819C.m

Go to the documentation of this file.
  1. DG53819C ;ALB/MJB - POST INSTALL ROUTINE ; 11/19/09
  1. ;;5.3;Registration;**819**;Aug 13, 1993;Build 16
  1. ;
  1. Q
  1. EN ; START UPDATES
  1. D ADD
  1. D UPD
  1. Q
  1. ADD ;Add suffixes to the Suffix file (#45.68)
  1. N DGI,DGERR,DGSUFF,DGIFN,DGQUES
  1. S DGIFN=0
  1. F DGI=1:1 S DGSUFF=$P($T(DGSUFF+DGI),";;",2) Q:DGSUFF="QUIT" D
  1. .D SUFFIX
  1. Q
  1. SUFFIX ; Add Suffix
  1. K DD,DO
  1. N DA,DIC,DIE,DLAYGO,DR,X,Y,DGDT
  1. S DLAYGO=45.68
  1. S DIC="^DIC(45.68,",DIC(0)="XLZ"
  1. S X=$P(DGSUFF,U,1)
  1. S DGDT=$P(DGSUFF,U,2)
  1. D ^DIC I Y<0 D BMES^XPDUTL(">> Error adding Suffix. Call Customer Support.") Q
  1. D BMES^XPDUTL(" >> Suffix added to FACILITY SUFFIX file.")
  1. S (DIC,DIE)="^DIC(45.68,"_+Y_",""E"",",DA(1)=+Y,DIC("P")=$P(^DD(45.68,10,0),U,2),DIC(0)="XLZ",X=DGDT
  1. D ^DIC
  1. I Y<0 D BMES^XPDUTL(">> Error adding Suffix Effective Date. Call Customer Support.") Q
  1. S DA=+Y
  1. S DR=".01////^S X=DGDT;.02////1"
  1. D ^DIE
  1. Q
  1. ;
  1. DGSUFF ; SUFFIX
  1. ;;B1^3091214
  1. ;;B2^3091214
  1. ;;B3^3091214
  1. ;;B4^3091214
  1. ;;PB^2971001
  1. ;;PC^2971001
  1. ;;PD^2971001
  1. ;;PE^2971001
  1. ;;QUIT
  1. ;
  1. UPD ;Update suffixes in the Suffix file (#45.68)
  1. N DGI,DGERR,DGSUFF,DGIFN,DGQUES
  1. S DGIFN=0
  1. F DGI=1:1 S DGSUFF=$P($T(DGSUFU+DGI),";;",2) Q:DGSUFF="QUIT" D
  1. .D SUFFUP
  1. Q
  1. SUFFUP ; Update Suffix
  1. K DD,DO
  1. N DA,DIC,DIE,DLAYGO,DR,X,Y,DGDT
  1. S DLAYGO=45.68
  1. S DIC="^DIC(45.68,",DIC(0)="XLZ"
  1. S X=$P(DGSUFF,U,1)
  1. S DGDT=$P(DGSUFF,U,2)
  1. D ^DIC I Y<0 D BMES^XPDUTL(">> Error updating Suffix. Call Customer Support.") Q
  1. D BMES^XPDUTL(" >> Suffix updated in FACILITY SUFFIX file.")
  1. S (DIC,DIE)="^DIC(45.68,"_+Y_",""E"",",DA(1)=+Y,DIC("P")=$P(^DD(45.68,10,0),U,2),DIC(0)="XLZ",X=2931001
  1. D ^DIC
  1. I Y<0 D BMES^XPDUTL(">> Error updating Suffix Effective Date. Call Customer Support.") Q
  1. S DA=+Y
  1. S DR=".02////1"
  1. D ^DIE
  1. Q
  1. ;
  1. DGSUFU ; SUFFIX
  1. ;;BV^2931001
  1. ;;BW^2931001
  1. ;;BX^2931001
  1. ;;QUIT
  1. ;