| 1 | DG53P314 ;ALB/RPM - Patch DG*5.3*314 Install Utility Routine ; 12/12/00 5:19pm
|
|---|
| 2 | ;;5.3;Registration;**314**;AUG 13, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | ;
|
|---|
| 5 | ENV ;Main entry point for Environment check point.
|
|---|
| 6 | ;
|
|---|
| 7 | S XPDABORT=""
|
|---|
| 8 | D PROGCHK(.XPDABORT) ;checks programmer variables
|
|---|
| 9 | I XPDABORT="" K XPDABORT
|
|---|
| 10 | Q
|
|---|
| 11 | ;
|
|---|
| 12 | ;
|
|---|
| 13 | PRE ;Main entry point for Pre-init items.
|
|---|
| 14 | Q
|
|---|
| 15 | ;
|
|---|
| 16 | ;
|
|---|
| 17 | POST ;Main entry point for Post-init items.
|
|---|
| 18 | ;
|
|---|
| 19 | D POST1 ;Add new entry to ELIGIBILITY CODE file (#8)
|
|---|
| 20 | D POST2 ;Add new entry to ENROLLMENT STATUS file (#27.15)
|
|---|
| 21 | D POST3 ;Add PURPLE HEART RECIPIENT to PERIOD OF SERVICE file (#21)
|
|---|
| 22 | Q
|
|---|
| 23 | ;
|
|---|
| 24 | ;
|
|---|
| 25 | PROGCHK(XPDABORT) ;checks for necessary programmer variables
|
|---|
| 26 | ;
|
|---|
| 27 | I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO
|
|---|
| 28 | .D BMES^XPDUTL("*****")
|
|---|
| 29 | .D MES^XPDUTL("Your programming variables are not set up properly.")
|
|---|
| 30 | .D MES^XPDUTL("Installation aborted.")
|
|---|
| 31 | .D MES^XPDUTL("*****")
|
|---|
| 32 | .S XPDABORT=2
|
|---|
| 33 | Q
|
|---|
| 34 | ;
|
|---|
| 35 | ;
|
|---|
| 36 | POST1 ;Add new entry to ELIGIBILITY CODE file (#8)
|
|---|
| 37 | ;
|
|---|
| 38 | NEW DGEC,DGPH,DGFDA,DGERR
|
|---|
| 39 | S DGEC="PURPLE HEART RECIPIENT"
|
|---|
| 40 | D BMES^XPDUTL("*** Adding 'PURPLE HEART RECIPIENT' to the ELIGIBILITY CODE file (#8).")
|
|---|
| 41 | S DGPH=$$FIND1^DIC(8.1,"","X",DGEC)
|
|---|
| 42 | I 'DGPH D Q
|
|---|
| 43 | . D BMES^XPDUTL("*** PURPLE HEART RECIPIENT entry missing from file 8.1 - contact NVS.")
|
|---|
| 44 | I $$FIND1^DIC(8,"","X",DGEC) D Q
|
|---|
| 45 | . D BMES^XPDUTL("*** PURPLE HEART RECIPIENT entry already exists!")
|
|---|
| 46 | ;add entry to file
|
|---|
| 47 | S DGFDA(8,"+1,",.01)=DGEC
|
|---|
| 48 | S DGFDA(8,"+1,",1)="BLUE"
|
|---|
| 49 | S DGFDA(8,"+1,",2)="PH"
|
|---|
| 50 | S DGFDA(8,"+1,",3)=2
|
|---|
| 51 | S DGFDA(8,"+1,",4)="Y"
|
|---|
| 52 | S DGFDA(8,"+1,",5)=DGEC
|
|---|
| 53 | S DGFDA(8,"+1,",7)=1
|
|---|
| 54 | S DGFDA(8,"+1,",8)=DGEC
|
|---|
| 55 | S DGFDA(8,"+1,",9)="VA STANDARD"
|
|---|
| 56 | S DGFDA(8,"+1,",11)="VA"
|
|---|
| 57 | D UPDATE^DIE("E","DGFDA","","DGERR")
|
|---|
| 58 | I '$D(DGERR) D BMES^XPDUTL("*** PURPLE HEART RECIPIENT successfully added to file #8.")
|
|---|
| 59 | I $D(DGERR) D BMES^XPDUTL("*** PURPLE HEART RECIPIENT was NOT successfully added to file #8.")
|
|---|
| 60 | Q
|
|---|
| 61 | ;
|
|---|
| 62 | POST2 ; Add new entry to ENROLLMENT STATUS file (#27.15)
|
|---|
| 63 | N FDA,ERR
|
|---|
| 64 | D BMES^XPDUTL("Add New Pending Status, Purple Heart Unconfirmed.")
|
|---|
| 65 | I $$FIND1^DIC(27.15,"","X","PENDING; PURPLE HEART UNCONFIRMED") D BMES^XPDUTL("*** New Pending Status entry already exists!") Q
|
|---|
| 66 | S FDA(27.15,"+1,",.01)="PENDING; PURPLE HEART UNCONFIRMED"
|
|---|
| 67 | S FDA(27.15,"+1,",.02)="P"
|
|---|
| 68 | D UPDATE^DIE("","FDA","","ERR")
|
|---|
| 69 | I $D(ERR) D BMES^XPDUTL("ERROR! New Pending Status not added!"),MES^XPDUTL(ERR("DIERR",1)_": "_ERR("DIERR",1,"TEXT",1)) Q
|
|---|
| 70 | D MES^XPDUTL("New Pending Status successfully added.")
|
|---|
| 71 | Q
|
|---|
| 72 | ;
|
|---|
| 73 | POST3 ;Add Purple Heart to the PERIOD OF SERVICE file (#21) eligibility
|
|---|
| 74 | ;sub-file (#21.01)
|
|---|
| 75 | ;
|
|---|
| 76 | N DGPHEC ;Purple Heart Eligibility Code name
|
|---|
| 77 | N DGPHIEN ;Purple Heart IEN in file #8
|
|---|
| 78 | N DGCNT ;Counter for number of Periods of Service modified
|
|---|
| 79 | N DGPOS ;Period of Service name
|
|---|
| 80 | N DGPOSIEN ;Period of Service IEN in file #21
|
|---|
| 81 | N DGFDA ;FDA for DBS call
|
|---|
| 82 | N DGERR ;Error array for DBS call
|
|---|
| 83 | ;
|
|---|
| 84 | D BMES^XPDUTL("** Updating PERIOD OF SERVICE file with Purple Heart Eligibility code.")
|
|---|
| 85 | S DGPHEC="PURPLE HEART RECIPIENT"
|
|---|
| 86 | S DGPHIEN=$$FIND1^DIC(8,"","MX",DGPHEC,"","","DGERR")
|
|---|
| 87 | I 'DGPHIEN!$D(DGERR) D G POST3Q
|
|---|
| 88 | . D BMES^XPDUTL("** PURPLE HEART RECIPIENT not found in the ELIGIBLITY CODE file (#8).")
|
|---|
| 89 | . D BMES^XPDUTL("** Unable to update PERIOD OF SERVICE file.")
|
|---|
| 90 | ;
|
|---|
| 91 | S DGCNT=1
|
|---|
| 92 | F S DGPOS=$P($T(POSTEX+DGCNT),";;",2) Q:DGPOS="" S DGCNT=DGCNT+1 D
|
|---|
| 93 | . N DGERR
|
|---|
| 94 | . S DGPOSIEN=$$FIND1^DIC(21,"","MX",DGPOS,"","","DGERR")
|
|---|
| 95 | . I 'DGPOSIEN!$D(DGERR) Q
|
|---|
| 96 | . S DGFDA(21.01,"+1,"_DGPOSIEN_",",.01)=DGPHEC
|
|---|
| 97 | . D UPDATE^DIE("E","DGFDA","","DGERR")
|
|---|
| 98 | D BMES^XPDUTL("** PURPLE HEART RECIPIENT successfully added to the PERIOD OF SERVICE file (#21).")
|
|---|
| 99 | ;
|
|---|
| 100 | POST3Q ;
|
|---|
| 101 | Q
|
|---|
| 102 | ;
|
|---|
| 103 | POSTEX ;
|
|---|
| 104 | ;;KOREAN
|
|---|
| 105 | ;;OPERATION DESERT SHIELD
|
|---|
| 106 | ;;PERSIAN GULF WAR
|
|---|
| 107 | ;;POST-KOREAN
|
|---|
| 108 | ;;POST-VIETNAM
|
|---|
| 109 | ;;PRE-KOREAN
|
|---|
| 110 | ;;SPANISH AMERICAN
|
|---|
| 111 | ;;VIETNAM ERA
|
|---|
| 112 | ;;WORLD WAR I
|
|---|
| 113 | ;;WORLD WAR II
|
|---|
| 114 | ;;
|
|---|
