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

DG53654P.m

Go to the documentation of this file. 
  1. DG53654P ;ALB/BAJ - Synchronize the PERIOD OF SERVICE file (#21);09/01/2005
  1.  ;;5.3;Registration;**654,1015**;Aug 13, 1993;Build 21
  1.  ;
  1.  ; This routine will will update the PERIOD OF SERVICE file (#21).  It modifies
  1.  ; data in specific fields. This routine will neither add nor delete records
  1.  ; from the file
  1.  ;
  1.  ; "B" VALUE         FIELD#      FIELD NAME              FROM                           TO
  1.  ; ---------------------------------------------------------------------------------------------------------------
  1.  ; CHAMPUS           .01         NAME                 CHAMPUS                        TRICARE
  1.  ; CHAMPUS           .02         ABBREVIATION         CHA                            TRI
  1.  ; CHAMPUS            20         BRIEF DESCRIPTION    CHAMPUS PTS AT VA FACILITY     TRICARE PTS AT VA FACILITY
  1.  ; PERSIAN GULF WAR   20         BRIEF DESCRIPTION    PERSUAN GULF WAR VETERAN       (On or after 8/2/1990)
  1.  ; POST-VIETNAM      .05         END DATE             <blank>                        8/1/1990
  1.  ; POST-VIETNAM       20         BRIEF DESCRIPTION    (On or after 5/8/75)           (5/8/75 - 8/1/1990)
  1.  ; PRE-KOREAN         20         BRIEF DESCRIPTION    (Peacetime before 6/27/50)     Peacetime before 6/27/1950
  1.  ; KOREAN             20         BRIEF DESCRIPTION    (6/27/50-1/31/55)              (6/27/1950-1/31/1955)
  1.  ; MERCHANT MARINE    20         BRIEF DESCRIPTION    (12/41-8/15/45)                (12/1941-8/15/1945)
  1.  ; POST-KOREAN        20         BRIEF DESCRIPTION    (2/1/55-2/27/61)               (2/1/1955-2/27/1961)
  1.  ; VIETNAM ERA        20         BRIEF DESCRIPTION    (2/28/61-5/7/75)               (2/28/1961-5/7/1975)
  1.  ; WORLD WAR I        20         BRIEF DESCRIPTION    (4/6/17-11/11/18)              (4/6/1917-11/11/1918)
  1.  ; WORLD WAR II       20         BRIEF DESCRIPTION    (12/7/41-12/31/46)             (12/7/1941-12/31/1946)
  1.  ; 
  1.  ;
  1.  Q
  1. EN ; Driver - Initialize variables and populate file
  1.  ;
  1.  ; Populate file using API UPD^DGENDBS
  1.  ;       UPD^DGENDBS takes the following parameters:
  1.  ;   FILE - File or sub-file number
  1.  ;   DGENDA - New name for traditional DA array, with same meaning.
  1.  ;            Pass by reference.
  1.  ;   DATA - Data array to file (pass by reference)
  1.  ;          Format: DATA(<field #>)=<value>
  1.  ; 
  1.  ; Additional variables
  1.  ; MSGARR - array to manage data sent to message APIs
  1.  ; XDATA  - array to manage data sent to DGENDBS API
  1.  ;  
  1.  N MSGARR,XDATA
  1.  ; log start of install
  1.  D BMES^XPDUTL(">>>Installing DG*5.3*654...")
  1.  K ^TMP($J)
  1.  ; 
  1.  ; populate work arrays
  1.  D SETUP
  1.  ;
  1.  ; call API to update records
  1.  D UPDATE
  1.  ;
  1.  ; notify user if errors encountered
  1.  I $D(^TMP($J,"ERRORS")) D
  1.  . D BMES^XPDUTL("Errors encountered... Job # "_$J)
  1.  . D MES^XPDUTL(" Please contact the CIO Field Office for assistance")
  1.  . D MES^XPDUTL(" and record the Job number (above) for reference.")
  1.  ;
  1.  D BMES^XPDUTL(">>>Install of DG*5.3*654 complete")
  1.  Q
  1.  ;
  1. UPDATE ; update records
  1.  N DATA,DGENDA,ERR,FILE,POS
  1.  ; period of service file is 21
  1.  S FILE=21,(POS,ERR)=""
  1.  F  S POS=$O(XDATA(POS)) Q:POS=""  D
  1.  . D MES^XPDUTL("Updating "_MSGARR(POS))
  1.  . M DATA=XDATA(POS)
  1.  . I '$$UPD^DGENDBS(FILE,.POS,.DATA,.ERR) D
  1.  . . ;S ^TMP($J,"ERRORS",POS)=ERR_"^"_MSGARR(POS)_"^"_$H
  1.  . . D MES^XPDUTL("Error in filing "_MSGARR(POS)_" values")
  1.  . . S ERR=""
  1.  . K DATA
  1.  Q
  1.  ;
  1. SETUP ; setup message and data arrays
  1.  ; PBNAME        = Data Index pointer in "B" x-ref
  1.  ; POS           = Data Index (D0 value)
  1.  ; PFNUM         = Field number
  1.  ; PBDATA        = New data to change/insert (per table in DATA tag)
  1.  ; 
  1.  ; Arrays created
  1.  ; MSGARR array contains a pointer to the index record
  1.  ; MSGARR(POS) = PBNAME
  1.  ;       
  1.  ; XDATA array contains the items to change
  1.  ; XDATA(POS,PFNUM) = PDATA
  1.  ; 
  1.  ;
  1.  N POS,PBNAME,PFNUM,PDATA,X,K
  1.  F K=1:1 S X=$P($T(DATA+K),";;",2) Q:X=""  D             ;assemble pointers and data strings
  1.  . S PBNAME=$P(X,"^",1)
  1.  . S POS=$$LOOKUP(PBNAME) I POS="ERROR" D  Q
  1.  . . ;S ^TMP($J,"ERRORS")="NO SUCH RECORD^"_PBNAME_"^"_$H
  1.  . . D MES^XPDUTL("Error in filing "_PBNAME_" values")
  1.  . S PFNUM=$P(X,"^",2)
  1.  . S PDATA=$P(X,"^",3)
  1.  . S MSGARR(POS)=PBNAME
  1.  . S XDATA(POS,PFNUM)=PDATA
  1.  ;
  1.  Q
  1.  ;
  1. LOOKUP(PBNAME) ; Return IEN for POS File #21, using the "B" x-ref
  1.  N RETVAL
  1.  S RETVAL=$O(^DIC(21,"B",PBNAME,""))
  1.  I 'RETVAL Q "ERROR"
  1.  Q RETVAL
  1.  ;
  1. DATA ; POS values to lookup *** Data table, DO NOT ADJUST ***
  1.  ;;CHAMPUS^.01^TRICARE
  1.  ;;CHAMPUS^.02^TRI
  1.  ;;CHAMPUS^20^TRICARE PTS AT VA FACILITY
  1.  ;;KOREAN^20^(6/27/1950-1/31/1955)
  1.  ;;MERCHANT MARINE^20^(12/7/1941-8/15/1945)
  1.  ;;PERSIAN GULF WAR^20^(On or after 8/2/1990)
  1.  ;;POST-VIETNAM^.05^2900801
  1.  ;;POST-VIETNAM^20^(5/8/1975-8/1/1990)
  1.  ;;POST-KOREAN^20^(2/1/1955-2/27/1961)
  1.  ;;PRE-KOREAN^20^Peacetime before 6/27/1950
  1.  ;;VIETNAM ERA^20^(2/28/1961-5/7/1975)
  1.  ;;WORLD WAR I^20^(4/6/1917-11/11/1918)
  1.  ;;WORLD WAR II^20^(12/7/1941-12/31/1946)
  1.  ;;
  1.  Q
  1.  ;