source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG53654P.m

Last change on this file was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1DG53654P ;ALB/BAJ - Synchronize the PERIOD OF SERVICE file (#21);09/01/2005
2 ;;5.3;Registration;**654**;Aug 13, 1993
3 ;
4 ; This routine will will update the PERIOD OF SERVICE file (#21). It modifies
5 ; data in specific fields. This routine will neither add nor delete records
6 ; from the file
7 ;
8 ; "B" VALUE FIELD# FIELD NAME FROM TO
9 ; ---------------------------------------------------------------------------------------------------------------
10 ; CHAMPUS .01 NAME CHAMPUS TRICARE
11 ; CHAMPUS .02 ABBREVIATION CHA TRI
12 ; CHAMPUS 20 BRIEF DESCRIPTION CHAMPUS PTS AT VA FACILITY TRICARE PTS AT VA FACILITY
13 ; PERSIAN GULF WAR 20 BRIEF DESCRIPTION PERSUAN GULF WAR VETERAN (On or after 8/2/1990)
14 ; POST-VIETNAM .05 END DATE <blank> 8/1/1990
15 ; POST-VIETNAM 20 BRIEF DESCRIPTION (On or after 5/8/75) (5/8/75 - 8/1/1990)
16 ; PRE-KOREAN 20 BRIEF DESCRIPTION (Peacetime before 6/27/50) Peacetime before 6/27/1950
17 ; KOREAN 20 BRIEF DESCRIPTION (6/27/50-1/31/55) (6/27/1950-1/31/1955)
18 ; MERCHANT MARINE 20 BRIEF DESCRIPTION (12/41-8/15/45) (12/1941-8/15/1945)
19 ; POST-KOREAN 20 BRIEF DESCRIPTION (2/1/55-2/27/61) (2/1/1955-2/27/1961)
20 ; VIETNAM ERA 20 BRIEF DESCRIPTION (2/28/61-5/7/75) (2/28/1961-5/7/1975)
21 ; WORLD WAR I 20 BRIEF DESCRIPTION (4/6/17-11/11/18) (4/6/1917-11/11/1918)
22 ; WORLD WAR II 20 BRIEF DESCRIPTION (12/7/41-12/31/46) (12/7/1941-12/31/1946)
23 ;
24 ;
25 Q
26EN ; Driver - Initialize variables and populate file
27 ;
28 ; Populate file using API UPD^DGENDBS
29 ; UPD^DGENDBS takes the following parameters:
30 ; FILE - File or sub-file number
31 ; DGENDA - New name for traditional DA array, with same meaning.
32 ; Pass by reference.
33 ; DATA - Data array to file (pass by reference)
34 ; Format: DATA(<field #>)=<value>
35 ;
36 ; Additional variables
37 ; MSGARR - array to manage data sent to message APIs
38 ; XDATA - array to manage data sent to DGENDBS API
39 ;
40 N MSGARR,XDATA
41 ; log start of install
42 D BMES^XPDUTL(">>>Installing DG*5.3*654...")
43 K ^TMP($J)
44 ;
45 ; populate work arrays
46 D SETUP
47 ;
48 ; call API to update records
49 D UPDATE
50 ;
51 ; notify user if errors encountered
52 I $D(^TMP($J,"ERRORS")) D
53 . D BMES^XPDUTL("Errors encountered... Job # "_$J)
54 . D MES^XPDUTL(" Please contact the CIO Field Office for assistance")
55 . D MES^XPDUTL(" and record the Job number (above) for reference.")
56 ;
57 D BMES^XPDUTL(">>>Install of DG*5.3*654 complete")
58 Q
59 ;
60UPDATE ; update records
61 N DATA,DGENDA,ERR,FILE,POS
62 ; period of service file is 21
63 S FILE=21,(POS,ERR)=""
64 F S POS=$O(XDATA(POS)) Q:POS="" D
65 . D MES^XPDUTL("Updating "_MSGARR(POS))
66 . M DATA=XDATA(POS)
67 . I '$$UPD^DGENDBS(FILE,.POS,.DATA,.ERR) D
68 . . ;S ^TMP($J,"ERRORS",POS)=ERR_"^"_MSGARR(POS)_"^"_$H
69 . . D MES^XPDUTL("Error in filing "_MSGARR(POS)_" values")
70 . . S ERR=""
71 . K DATA
72 Q
73 ;
74SETUP ; setup message and data arrays
75 ; PBNAME = Data Index pointer in "B" x-ref
76 ; POS = Data Index (D0 value)
77 ; PFNUM = Field number
78 ; PBDATA = New data to change/insert (per table in DATA tag)
79 ;
80 ; Arrays created
81 ; MSGARR array contains a pointer to the index record
82 ; MSGARR(POS) = PBNAME
83 ;
84 ; XDATA array contains the items to change
85 ; XDATA(POS,PFNUM) = PDATA
86 ;
87 ;
88 N POS,PBNAME,PFNUM,PDATA,X,K
89 F K=1:1 S X=$P($T(DATA+K),";;",2) Q:X="" D ;assemble pointers and data strings
90 . S PBNAME=$P(X,"^",1)
91 . S POS=$$LOOKUP(PBNAME) I POS="ERROR" D Q
92 . . ;S ^TMP($J,"ERRORS")="NO SUCH RECORD^"_PBNAME_"^"_$H
93 . . D MES^XPDUTL("Error in filing "_PBNAME_" values")
94 . S PFNUM=$P(X,"^",2)
95 . S PDATA=$P(X,"^",3)
96 . S MSGARR(POS)=PBNAME
97 . S XDATA(POS,PFNUM)=PDATA
98 ;
99 Q
100 ;
101LOOKUP(PBNAME) ; Return IEN for POS File #21, using the "B" x-ref
102 N RETVAL
103 S RETVAL=$O(^DIC(21,"B",PBNAME,""))
104 I 'RETVAL Q "ERROR"
105 Q RETVAL
106 ;
107DATA ; POS values to lookup *** Data table, DO NOT ADJUST ***
108 ;;CHAMPUS^.01^TRICARE
109 ;;CHAMPUS^.02^TRI
110 ;;CHAMPUS^20^TRICARE PTS AT VA FACILITY
111 ;;KOREAN^20^(6/27/1950-1/31/1955)
112 ;;MERCHANT MARINE^20^(12/7/1941-8/15/1945)
113 ;;PERSIAN GULF WAR^20^(On or after 8/2/1990)
114 ;;POST-VIETNAM^.05^2900801
115 ;;POST-VIETNAM^20^(5/8/1975-8/1/1990)
116 ;;POST-KOREAN^20^(2/1/1955-2/27/1961)
117 ;;PRE-KOREAN^20^Peacetime before 6/27/1950
118 ;;VIETNAM ERA^20^(2/28/1961-5/7/1975)
119 ;;WORLD WAR I^20^(4/6/1917-11/11/1918)
120 ;;WORLD WAR II^20^(12/7/1941-12/31/1946)
121 ;;
122 Q
123 ;
Note: See TracBrowser for help on using the repository browser.