DG53P314 ;ALB/RPM - Patch DG*5.3*314 Install Utility Routine ; 12/12/00 5:19pm
;;5.3;Registration;**314**;AUG 13, 1993
;
;
ENV ;Main entry point for Environment check point.
;
S XPDABORT=""
D PROGCHK(.XPDABORT) ;checks programmer variables
I XPDABORT="" K XPDABORT
Q
;
;
PRE ;Main entry point for Pre-init items.
Q
;
;
POST ;Main entry point for Post-init items.
;
D POST1 ;Add new entry to ELIGIBILITY CODE file (#8)
D POST2 ;Add new entry to ENROLLMENT STATUS file (#27.15)
D POST3 ;Add PURPLE HEART RECIPIENT to PERIOD OF SERVICE file (#21)
Q
;
;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
;
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO
.D BMES^XPDUTL("*****")
.D MES^XPDUTL("Your programming variables are not set up properly.")
.D MES^XPDUTL("Installation aborted.")
.D MES^XPDUTL("*****")
.S XPDABORT=2
Q
;
;
POST1 ;Add new entry to ELIGIBILITY CODE file (#8)
;
NEW DGEC,DGPH,DGFDA,DGERR
S DGEC="PURPLE HEART RECIPIENT"
D BMES^XPDUTL("*** Adding 'PURPLE HEART RECIPIENT' to the ELIGIBILITY CODE file (#8).")
S DGPH=$$FIND1^DIC(8.1,"","X",DGEC)
I 'DGPH D Q
. D BMES^XPDUTL("*** PURPLE HEART RECIPIENT entry missing from file 8.1 - contact NVS.")
I $$FIND1^DIC(8,"","X",DGEC) D Q
. D BMES^XPDUTL("*** PURPLE HEART RECIPIENT entry already exists!")
;add entry to file
S DGFDA(8,"+1,",.01)=DGEC
S DGFDA(8,"+1,",1)="BLUE"
S DGFDA(8,"+1,",2)="PH"
S DGFDA(8,"+1,",3)=2
S DGFDA(8,"+1,",4)="Y"
S DGFDA(8,"+1,",5)=DGEC
S DGFDA(8,"+1,",7)=1
S DGFDA(8,"+1,",8)=DGEC
S DGFDA(8,"+1,",9)="VA STANDARD"
S DGFDA(8,"+1,",11)="VA"
D UPDATE^DIE("E","DGFDA","","DGERR")
I '$D(DGERR) D BMES^XPDUTL("*** PURPLE HEART RECIPIENT successfully added to file #8.")
I $D(DGERR) D BMES^XPDUTL("*** PURPLE HEART RECIPIENT was NOT successfully added to file #8.")
Q
;
POST2 ; Add new entry to ENROLLMENT STATUS file (#27.15)
N FDA,ERR
D BMES^XPDUTL("Add New Pending Status, Purple Heart Unconfirmed.")
I $$FIND1^DIC(27.15,"","X","PENDING; PURPLE HEART UNCONFIRMED") D BMES^XPDUTL("*** New Pending Status entry already exists!") Q
S FDA(27.15,"+1,",.01)="PENDING; PURPLE HEART UNCONFIRMED"
S FDA(27.15,"+1,",.02)="P"
D UPDATE^DIE("","FDA","","ERR")
I $D(ERR) D BMES^XPDUTL("ERROR! New Pending Status not added!"),MES^XPDUTL(ERR("DIERR",1)_": "_ERR("DIERR",1,"TEXT",1)) Q
D MES^XPDUTL("New Pending Status successfully added.")
Q
;
POST3 ;Add Purple Heart to the PERIOD OF SERVICE file (#21) eligibility
;sub-file (#21.01)
;
N DGPHEC ;Purple Heart Eligibility Code name
N DGPHIEN ;Purple Heart IEN in file #8
N DGCNT ;Counter for number of Periods of Service modified
N DGPOS ;Period of Service name
N DGPOSIEN ;Period of Service IEN in file #21
N DGFDA ;FDA for DBS call
N DGERR ;Error array for DBS call
;
D BMES^XPDUTL("** Updating PERIOD OF SERVICE file with Purple Heart Eligibility code.")
S DGPHEC="PURPLE HEART RECIPIENT"
S DGPHIEN=$$FIND1^DIC(8,"","MX",DGPHEC,"","","DGERR")
I 'DGPHIEN!$D(DGERR) D G POST3Q
. D BMES^XPDUTL("** PURPLE HEART RECIPIENT not found in the ELIGIBLITY CODE file (#8).")
. D BMES^XPDUTL("** Unable to update PERIOD OF SERVICE file.")
;
S DGCNT=1
F S DGPOS=$P($T(POSTEX+DGCNT),";;",2) Q:DGPOS="" S DGCNT=DGCNT+1 D
. N DGERR
. S DGPOSIEN=$$FIND1^DIC(21,"","MX",DGPOS,"","","DGERR")
. I 'DGPOSIEN!$D(DGERR) Q
. S DGFDA(21.01,"+1,"_DGPOSIEN_",",.01)=DGPHEC
. D UPDATE^DIE("E","DGFDA","","DGERR")
D BMES^XPDUTL("** PURPLE HEART RECIPIENT successfully added to the PERIOD OF SERVICE file (#21).")
;
POST3Q ;
Q
;
POSTEX ;
;;KOREAN
;;OPERATION DESERT SHIELD
;;PERSIAN GULF WAR
;;POST-KOREAN
;;POST-VIETNAM
;;PRE-KOREAN
;;SPANISH AMERICAN
;;VIETNAM ERA
;;WORLD WAR I
;;WORLD WAR II
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P314 3854 printed Apr 09, 2024@21:56:10 Page 2
DG53P314 ;ALB/RPM - Patch DG*5.3*314 Install Utility Routine ; 12/12/00 5:19pm
+1 ;;5.3;Registration;**314**;AUG 13, 1993
+2 ;
+3 ;
ENV ;Main entry point for Environment check point.
+1 ;
+2 SET XPDABORT=""
+3 ;checks programmer variables
DO PROGCHK(.XPDABORT)
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
+7 ;
PRE ;Main entry point for Pre-init items.
+1 QUIT
+2 ;
+3 ;
POST ;Main entry point for Post-init items.
+1 ;
+2 ;Add new entry to ELIGIBILITY CODE file (#8)
DO POST1
+3 ;Add new entry to ENROLLMENT STATUS file (#27.15)
DO POST2
+4 ;Add PURPLE HEART RECIPIENT to PERIOD OF SERVICE file (#21)
DO POST3
+5 QUIT
+6 ;
+7 ;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
+1 ;
+2 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+3 DO BMES^XPDUTL("*****")
+4 DO MES^XPDUTL("Your programming variables are not set up properly.")
+5 DO MES^XPDUTL("Installation aborted.")
+6 DO MES^XPDUTL("*****")
+7 SET XPDABORT=2
End DoDot:1
+8 QUIT
+9 ;
+10 ;
POST1 ;Add new entry to ELIGIBILITY CODE file (#8)
+1 ;
+2 NEW DGEC,DGPH,DGFDA,DGERR
+3 SET DGEC="PURPLE HEART RECIPIENT"
+4 DO BMES^XPDUTL("*** Adding 'PURPLE HEART RECIPIENT' to the ELIGIBILITY CODE file (#8).")
+5 SET DGPH=$$FIND1^DIC(8.1,"","X",DGEC)
+6 IF 'DGPH
Begin DoDot:1
+7 DO BMES^XPDUTL("*** PURPLE HEART RECIPIENT entry missing from file 8.1 - contact NVS.")
End DoDot:1
QUIT
+8 IF $$FIND1^DIC(8,"","X",DGEC)
Begin DoDot:1
+9 DO BMES^XPDUTL("*** PURPLE HEART RECIPIENT entry already exists!")
End DoDot:1
QUIT
+10 ;add entry to file
+11 SET DGFDA(8,"+1,",.01)=DGEC
+12 SET DGFDA(8,"+1,",1)="BLUE"
+13 SET DGFDA(8,"+1,",2)="PH"
+14 SET DGFDA(8,"+1,",3)=2
+15 SET DGFDA(8,"+1,",4)="Y"
+16 SET DGFDA(8,"+1,",5)=DGEC
+17 SET DGFDA(8,"+1,",7)=1
+18 SET DGFDA(8,"+1,",8)=DGEC
+19 SET DGFDA(8,"+1,",9)="VA STANDARD"
+20 SET DGFDA(8,"+1,",11)="VA"
+21 DO UPDATE^DIE("E","DGFDA","","DGERR")
+22 IF '$DATA(DGERR)
DO BMES^XPDUTL("*** PURPLE HEART RECIPIENT successfully added to file #8.")
+23 IF $DATA(DGERR)
DO BMES^XPDUTL("*** PURPLE HEART RECIPIENT was NOT successfully added to file #8.")
+24 QUIT
+25 ;
POST2 ; Add new entry to ENROLLMENT STATUS file (#27.15)
+1 NEW FDA,ERR
+2 DO BMES^XPDUTL("Add New Pending Status, Purple Heart Unconfirmed.")
+3 IF $$FIND1^DIC(27.15,"","X","PENDING; PURPLE HEART UNCONFIRMED")
DO BMES^XPDUTL("*** New Pending Status entry already exists!")
QUIT
+4 SET FDA(27.15,"+1,",.01)="PENDING; PURPLE HEART UNCONFIRMED"
+5 SET FDA(27.15,"+1,",.02)="P"
+6 DO UPDATE^DIE("","FDA","","ERR")
+7 IF $DATA(ERR)
DO BMES^XPDUTL("ERROR! New Pending Status not added!")
DO MES^XPDUTL(ERR("DIERR",1)_": "_ERR("DIERR",1,"TEXT",1))
QUIT
+8 DO MES^XPDUTL("New Pending Status successfully added.")
+9 QUIT
+10 ;
POST3 ;Add Purple Heart to the PERIOD OF SERVICE file (#21) eligibility
+1 ;sub-file (#21.01)
+2 ;
+3 ;Purple Heart Eligibility Code name
NEW DGPHEC
+4 ;Purple Heart IEN in file #8
NEW DGPHIEN
+5 ;Counter for number of Periods of Service modified
NEW DGCNT
+6 ;Period of Service name
NEW DGPOS
+7 ;Period of Service IEN in file #21
NEW DGPOSIEN
+8 ;FDA for DBS call
NEW DGFDA
+9 ;Error array for DBS call
NEW DGERR
+10 ;
+11 DO BMES^XPDUTL("** Updating PERIOD OF SERVICE file with Purple Heart Eligibility code.")
+12 SET DGPHEC="PURPLE HEART RECIPIENT"
+13 SET DGPHIEN=$$FIND1^DIC(8,"","MX",DGPHEC,"","","DGERR")
+14 IF 'DGPHIEN!$DATA(DGERR)
Begin DoDot:1
+15 DO BMES^XPDUTL("** PURPLE HEART RECIPIENT not found in the ELIGIBLITY CODE file (#8).")
+16 DO BMES^XPDUTL("** Unable to update PERIOD OF SERVICE file.")
End DoDot:1
GOTO POST3Q
+17 ;
+18 SET DGCNT=1
+19 FOR
SET DGPOS=$PIECE($TEXT(POSTEX+DGCNT),";;",2)
if DGPOS=""
QUIT
SET DGCNT=DGCNT+1
Begin DoDot:1
+20 NEW DGERR
+21 SET DGPOSIEN=$$FIND1^DIC(21,"","MX",DGPOS,"","","DGERR")
+22 IF 'DGPOSIEN!$DATA(DGERR)
QUIT
+23 SET DGFDA(21.01,"+1,"_DGPOSIEN_",",.01)=DGPHEC
+24 DO UPDATE^DIE("E","DGFDA","","DGERR")
End DoDot:1
+25 DO BMES^XPDUTL("** PURPLE HEART RECIPIENT successfully added to the PERIOD OF SERVICE file (#21).")
+26 ;
POST3Q ;
+1 QUIT
+2 ;
POSTEX ;
+1 ;;KOREAN
+2 ;;OPERATION DESERT SHIELD
+3 ;;PERSIAN GULF WAR
+4 ;;POST-KOREAN
+5 ;;POST-VIETNAM
+6 ;;PRE-KOREAN
+7 ;;SPANISH AMERICAN
+8 ;;VIETNAM ERA
+9 ;;WORLD WAR I
+10 ;;WORLD WAR II
+11 ;;
