- 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 Jan 18, 2025@03:39:35 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 ;