DG53819C ;ALB/MJB - POST INSTALL ROUTINE ; 11/19/09
;;5.3;Registration;**819**;Aug 13, 1993;Build 16
;
Q
EN ; START UPDATES
D ADD
D UPD
Q
ADD ;Add suffixes to the Suffix file (#45.68)
N DGI,DGERR,DGSUFF,DGIFN,DGQUES
S DGIFN=0
F DGI=1:1 S DGSUFF=$P($T(DGSUFF+DGI),";;",2) Q:DGSUFF="QUIT" D
.D SUFFIX
Q
SUFFIX ; Add Suffix
K DD,DO
N DA,DIC,DIE,DLAYGO,DR,X,Y,DGDT
S DLAYGO=45.68
S DIC="^DIC(45.68,",DIC(0)="XLZ"
S X=$P(DGSUFF,U,1)
S DGDT=$P(DGSUFF,U,2)
D ^DIC I Y<0 D BMES^XPDUTL(">> Error adding Suffix. Call Customer Support.") Q
D BMES^XPDUTL(" >> Suffix added to FACILITY SUFFIX file.")
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
D ^DIC
I Y<0 D BMES^XPDUTL(">> Error adding Suffix Effective Date. Call Customer Support.") Q
S DA=+Y
S DR=".01////^S X=DGDT;.02////1"
D ^DIE
Q
;
DGSUFF ; SUFFIX
;;B1^3091214
;;B2^3091214
;;B3^3091214
;;B4^3091214
;;PB^2971001
;;PC^2971001
;;PD^2971001
;;PE^2971001
;;QUIT
;
UPD ;Update suffixes in the Suffix file (#45.68)
N DGI,DGERR,DGSUFF,DGIFN,DGQUES
S DGIFN=0
F DGI=1:1 S DGSUFF=$P($T(DGSUFU+DGI),";;",2) Q:DGSUFF="QUIT" D
.D SUFFUP
Q
SUFFUP ; Update Suffix
K DD,DO
N DA,DIC,DIE,DLAYGO,DR,X,Y,DGDT
S DLAYGO=45.68
S DIC="^DIC(45.68,",DIC(0)="XLZ"
S X=$P(DGSUFF,U,1)
S DGDT=$P(DGSUFF,U,2)
D ^DIC I Y<0 D BMES^XPDUTL(">> Error updating Suffix. Call Customer Support.") Q
D BMES^XPDUTL(" >> Suffix updated in FACILITY SUFFIX file.")
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
D ^DIC
I Y<0 D BMES^XPDUTL(">> Error updating Suffix Effective Date. Call Customer Support.") Q
S DA=+Y
S DR=".02////1"
D ^DIE
Q
;
DGSUFU ; SUFFIX
;;BV^2931001
;;BW^2931001
;;BX^2931001
;;QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53819C 1863 printed Dec 13, 2024@02:38:53 Page 2
DG53819C ;ALB/MJB - POST INSTALL ROUTINE ; 11/19/09
+1 ;;5.3;Registration;**819**;Aug 13, 1993;Build 16
+2 ;
+3 QUIT
EN ; START UPDATES
+1 DO ADD
+2 DO UPD
+3 QUIT
ADD ;Add suffixes to the Suffix file (#45.68)
+1 NEW DGI,DGERR,DGSUFF,DGIFN,DGQUES
+2 SET DGIFN=0
+3 FOR DGI=1:1
SET DGSUFF=$PIECE($TEXT(DGSUFF+DGI),";;",2)
if DGSUFF="QUIT"
QUIT
Begin DoDot:1
+4 DO SUFFIX
End DoDot:1
+5 QUIT
SUFFIX ; Add Suffix
+1 KILL DD,DO
+2 NEW DA,DIC,DIE,DLAYGO,DR,X,Y,DGDT
+3 SET DLAYGO=45.68
+4 SET DIC="^DIC(45.68,"
SET DIC(0)="XLZ"
+5 SET X=$PIECE(DGSUFF,U,1)
+6 SET DGDT=$PIECE(DGSUFF,U,2)
+7 DO ^DIC
IF Y<0
DO BMES^XPDUTL(">> Error adding Suffix. Call Customer Support.")
QUIT
+8 DO BMES^XPDUTL(" >> Suffix added to FACILITY SUFFIX file.")
+9 SET (DIC,DIE)="^DIC(45.68,"_+Y_",""E"","
SET DA(1)=+Y
SET DIC("P")=$PIECE(^DD(45.68,10,0),U,2)
SET DIC(0)="XLZ"
SET X=DGDT
+10 DO ^DIC
+11 IF Y<0
DO BMES^XPDUTL(">> Error adding Suffix Effective Date. Call Customer Support.")
QUIT
+12 SET DA=+Y
+13 SET DR=".01////^S X=DGDT;.02////1"
+14 DO ^DIE
+15 QUIT
+16 ;
DGSUFF ; SUFFIX
+1 ;;B1^3091214
+2 ;;B2^3091214
+3 ;;B3^3091214
+4 ;;B4^3091214
+5 ;;PB^2971001
+6 ;;PC^2971001
+7 ;;PD^2971001
+8 ;;PE^2971001
+9 ;;QUIT
+10 ;
UPD ;Update suffixes in the Suffix file (#45.68)
+1 NEW DGI,DGERR,DGSUFF,DGIFN,DGQUES
+2 SET DGIFN=0
+3 FOR DGI=1:1
SET DGSUFF=$PIECE($TEXT(DGSUFU+DGI),";;",2)
if DGSUFF="QUIT"
QUIT
Begin DoDot:1
+4 DO SUFFUP
End DoDot:1
+5 QUIT
SUFFUP ; Update Suffix
+1 KILL DD,DO
+2 NEW DA,DIC,DIE,DLAYGO,DR,X,Y,DGDT
+3 SET DLAYGO=45.68
+4 SET DIC="^DIC(45.68,"
SET DIC(0)="XLZ"
+5 SET X=$PIECE(DGSUFF,U,1)
+6 SET DGDT=$PIECE(DGSUFF,U,2)
+7 DO ^DIC
IF Y<0
DO BMES^XPDUTL(">> Error updating Suffix. Call Customer Support.")
QUIT
+8 DO BMES^XPDUTL(" >> Suffix updated in FACILITY SUFFIX file.")
+9 SET (DIC,DIE)="^DIC(45.68,"_+Y_",""E"","
SET DA(1)=+Y
SET DIC("P")=$PIECE(^DD(45.68,10,0),U,2)
SET DIC(0)="XLZ"
SET X=2931001
+10 DO ^DIC
+11 IF Y<0
DO BMES^XPDUTL(">> Error updating Suffix Effective Date. Call Customer Support.")
QUIT
+12 SET DA=+Y
+13 SET DR=".02////1"
+14 DO ^DIE
+15 QUIT
+16 ;
DGSUFU ; SUFFIX
+1 ;;BV^2931001
+2 ;;BW^2931001
+3 ;;BX^2931001
+4 ;;QUIT
+5 ;
