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

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

initial load of WorldVistAEHR

File size: 8.6 KB
Line 
1DGRPMS ;ALB/BRM,LBD - MILITARY SERVICE APIS ; 1/24/05 8:44am
2 ;;5.3;Registration;**451,626,646,673,689**;Aug 13, 1993;Build 1
3 ;
4VALCON1(DFN,IEN,CDATE,FRTO) ; Valid conflict input for OIF/OEF/UNKNOWN OEF/OIF?
5 ; Need to send the ien of the multiple as well as the DFN and
6 ; determine the specific conflict area
7 N Z
8 S Z=$P("OIF^OEF^UNK",U,+$G(^DPT(DFN,.3215,+IEN,0)))
9 ;Q:Z="UNK" 1 ; Never need to check this - only entered through HEC
10 Q $$VALCON(DFN,Z_"-"_IEN,CDATE,FRTO)
11 ;
12VALCON(DFN,CNFLCT,CDATE,FRTO,OEIFAIL) ;is this a valid conflict input?
13 ;
14 ;INPUT:
15 ; FRTO - 0=FRDT 1=TODT (defaults to FRDT if FRTO="")
16 ;OUTPUT:
17 ; OEIFAIL = 1 for not within MSE for OIF/OEF data (pass by ref)
18 ;
19 N RTN,X,Y,FRDT,TODT,CNFLCTV,IGNORE,COMPOW,MSG,DTCHK,CNFLCT2,OEFOIF
20 S OEIFAIL=0
21 Q:'$D(DFN) "0^INVALID PATIENT"
22 Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
23 Q:'$$VALID^DGRPDT(.CDATE) "0^INVALID DATE"
24 S FRTO=+$G(FRTO)
25 I 'FRTO S TODT=$$GETDT(DFN,.CNFLCT),FRDT=CDATE K DGFRDT
26 E S FRDT=$$GETDT(DFN,.CNFLCT,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=CDATE K DGFRDT
27 S DTCHK=$$DTUTIL^DGRPDT(CDATE,$$GETDT(DFN,.CNFLCT,'FRTO),1)
28 I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) Q DTCHK
29 I CNFLCT="COMB"!(CNFLCT="POW") D
30 .S COMPOW=$S(CNFLCT="COMB":1,1:2)
31 .S CNFLCT2=CNFLCT
32 .S CNFLCT=$$COMPOW($S($G(DGCOMLOC):$P(DGCOMLOC,"^"),1:$$GETDT(DFN,CNFLCT,3)))
33 S CNFLCTV=""
34 I CNFLCT]"" S CNFLCTV=$$CNFLCTDT^DGRPDT(FRDT,$S(FRTO:TODT,1:""),.CNFLCT)
35 I ('CNFLCTV) D MSG($P(CNFLCTV,"^",2),2,1) Q CNFLCTV ;dates are not within conflict
36 ;
37 S MSG=$S('$G(COMPOW):"Conflict",$G(COMPOW)=2:"POW",1:"Combat")
38 I FRDT,TODT,'$$B4^DGRPDT(FRDT,TODT,0) D MSG((MSG_" From Date is not Before "_MSG_" To Date"),2,1) Q "0^"_MSG_" From Date is not Before "_MSG_" To Date"
39 S IGNORE=$S('$P(CNFLCT,"-",2):$P($P($T(@($P(CNFLCT,"-"))),";;",2),"^",FRTO+1),1:"")
40 S:$G(COMPOW) IGNORE=$P($P($T(@(CNFLCT2)),";;",2),"^",FRTO+1)
41 I $G(COMPOW)=2 D
42 . S RTN=$$OVRLPCHK^DGRPDT(DFN,FRDT,TODT,-1,IGNORE)
43 E D
44 . S OEFOIF=$S($P(CNFLCT,"-",2):$P(CNFLCT,"-",2)_U_CNFLCT,1:""),RTN=$$COVRLP2^DGRPDT(DFN,FRDT,TODT,IGNORE,.OEFOIF)
45 . I 'RTN,$G(OEFOIF),$G(OEFOIF(1)) S OEIFAIL=1
46 Q:RTN RTN
47 D MSG($P(RTN,"^",2),2,1)
48 Q RTN
49 ;
50VALMSE(DFN,MDATE,FRTO,FLD) ;is this a valid Military Service Episode date?
51 ;
52 ;INPUT:
53 ; FRTO - 0=FRDT 1=TODT (defaults to FRDT if FRTO="")
54 ; FLD - MSE field being edited/added (MSL,MSNTL,MSNNTL)
55 ;
56 N RTN,X,Y,FRDT,TODT,IGNORE,DTCHK
57 Q:'$D(DFN) "0^INVALID PATIENT"
58 Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
59 Q:'$$VALID^DGRPDT(.MDATE) "0^INVALID DATE"
60 S FRTO=+$G(FRTO)
61 I 'FRTO S FRDT=MDATE,TODT=$$GETDT(DFN,.FLD,FRTO) K DGFRDT
62 E S FRDT=$$GETDT(DFN,.FLD,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=MDATE K DGFRDT
63 S DTCHK=$$DTUTIL^DGRPDT(MDATE,$$GETDT(DFN,.FLD,'FRTO),1)
64 I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) K DGCOMBR Q DTCHK
65 I FRTO,FRDT,TODT,'$$B4^DGRPDT(.FRDT,.TODT,0) D MSG("Service Entry Date is not before Service Separation Date",2,1) K DGCOMBR Q "0^Service Entry Date is not before Service Separation Date"
66 S IGNORE=$P($P($T(@(FLD)),";;",2),"^",FRTO+1)
67 S RTN=$$OVRLPCHK^DGRPDT(.DFN,.FRDT,.TODT,1,.IGNORE)
68 I $G(DGCOMBR)']"" S DGCOMBR=$$GETDT(DFN,.FLD,4)
69 I RTN,FRTO,$$BRANCH(.DGCOMBR),('$$WWII(DFN,TODT,.FLD)) D MSG("Branch of Service Requires WWII Dates of Service",2,1) K DGCOMBR Q "0^BOS Requires WWII Dates"
70 K DGCOMBR
71 Q:RTN RTN
72 D MSG($P(RTN,"^",2),2,1)
73 Q RTN
74 ;
75BRANCH(DGCOMBR) ;branches of service that require WWII service dates
76 N BRANCH
77 Q:'$G(DGCOMBR) 0
78 S BRANCH=$P(DGCOMBR,"^",2)
79 Q:BRANCH="MERCHANT SEAMAN" 1
80 Q:BRANCH="F.COMMONWEALTH" 1
81 Q:BRANCH="F.GUERILLA" 1
82 Q:BRANCH="F.SCOUTS NEW" 1
83 Q:BRANCH="F.SCOUTS OLD" 1
84 Q 0
85 ;
86VALCOMP(DFN,CODE,DGEPI) ; Verify component is consistent with the corresponding
87 ; branch of service Also, branch of service must be entered before
88 ; component.
89 ; ACTIVATED NATIONAL GUARD (G) only valid for ARMY or AIR FORCE branch
90 ; ACTIVATED RESERVE (V) only valid for ARMY, AIR FORCE, MARINES, NAVY
91 ; or COAST GUARD branch
92 ; DFN = ien of patient in file 2
93 ; DGEPI = episode # to check (1=LAST, 2=NTL, 3=NNTL)
94 ; CODE = the component code
95 ; OUTPUT: 1 if valid component
96 ; 0 if invalid component or branch of serv missing
97 N Z
98 S Z=+$P($G(^DPT(DFN,.32)),U,DGEPI*5)
99 I 'Z Q 0 ; Require bos
100 I CODE="R" Q 1 ; Regular is valid for all
101 Q:Z=1!(Z=2) 1 ; Army (1)/air force (2) valid for guard and reserves
102 ; reserves also include navy (3), marines (4), coast guard (5)
103 I CODE="V" Q $S(Z>2&(Z<6):1,1:0)
104 ;
105 Q 0
106 ;
107GETDT(DFN,CNFLCT,FRTO) ; get from date, to date, or location from patient file
108 ;
109 N CFLDS,CFLD,CNF1,CNF2,RTN1,IENS,FILE
110 Q:'$D(DFN) ""
111 Q:'$D(^DPT(DFN)) ""
112 Q:$G(CNFLCT)="" ""
113 S:$G(FRTO)="" FRTO=0
114 S CNF1=$P(CNFLCT,"-"),CNF2=+$P(CNFLCT,"-",2)
115 ; OEF/OIF/ UNKNOWN OEF/OIF data without a supplied entry in the
116 ; multiple cannot be retrieved OEF-1 indicates an OEF location
117 ; stored at the '1' subscript of the .3215 multiple
118 I "^OEF^OIF^UNK^"[(U_CNF1_U),'CNF2 Q ""
119 S CFLDS=$P($T(@(CNF1)),";;",2) Q:CFLDS']"" ""
120 S CFLD=$S('FRTO:$P(CFLDS,"^",2),FRTO=1:$P(CFLDS,"^"),1:$P(CFLDS,"^",3))
121 Q:'CFLD ""
122 S IENS=DFN_",",FILE=2
123 S:CNF2 IENS=CNF2_","_IENS,FILE=2.3215 ; For OIF/OEF, must set ref to multiple
124 S RTN1=$$GET1^DIQ(FILE,IENS,CFLD,"I")
125 I FRTO=4 S RTN1=RTN1_"^"_$$EXTERNAL^DILFD(FILE,CFLD,"",RTN1)
126 Q RTN1
127 ;
128WWII(DFN,TODT,FLD) ; was this patient in WWII?
129 ; this API assumes the WWII period to be from 12/07/41-12/31/46
130 ;
131 N OK,NODE,DATA,WWIIS,WWIIE,PATDT,PATE,PATS
132 Q:'$G(DFN) "-1^UNKNOWN"
133 S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
134 S WWIIS=2411207,WWIIE=2461231
135 D GETDAT^DGRPDT(DFN,.NODE,.DATA)
136 S PATDT=$G(FLD) Q:PATDT']"" 0
137 S PATS=$P($G(DATA(PATDT)),"^"),PATE=$P($G(DATA(PATDT)),"^",2)
138 S:'$G(TODT) TODT=PATE
139 S OK=0
140 S OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,PATS)
141 S:'OK OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,TODT)
142 S:'OK OK=$$RWITHIN^DGRPDT(PATS,TODT,WWIIS,WWIIE)
143 Q $G(OK)
144DELMSE(DFN,TYPE) ; delete MSE from patient
145 ;
146 ; Input: DFN - Internal entry number for the Patient File (#2)
147 ; TYPE - 1=Last MSE 2=Next to Last MSE 3=Next to Next to Last
148 ;
149 Q:'$G(TYPE)
150 Q:(('$G(DFN))!'$D(^DPT(DFN)))
151 N IENS,FDA,X,X1,X2,Y,ZZ,ROOT
152 S IENS=DFN_",",ROOT="FDA(2,IENS)",X=""
153 I TYPE=1 F ZZ=.324,.326,.327,.328 S @ROOT@(ZZ)=X
154 I TYPE=2 F ZZ=.329,.3292,.3293,.3294 S @ROOT@(ZZ)=X
155 I TYPE=3 F ZZ=.3295,.3297,.3298,.3299 S @ROOT@(ZZ)=X
156 D FILE^DIE("K","FDA","ERR")
157 Q
158 ;
159COMPOW(VAL) ;convert POW and Combat Location fields
160 ;
161 N ABRV
162 Q:'$G(VAL) ""
163 S ABRV=$$GET1^DIQ(22,VAL_",",1,"I")
164 Q:ABRV="WWI" "WWI"
165 Q:ABRV="WWII-EUROPE" "WWIIE"
166 Q:ABRV="WWII-PACIFIC" "WWIIP"
167 Q:ABRV="KOREAN" "KOR"
168 Q:ABRV="VIETNAM" "VIET"
169 Q:ABRV="OTHER" "OTHER"
170 Q:ABRV="PERSIAN GULF" "GULF"
171 Q:ABRV="YUGOSLAVIA" "YUG"
172 Q:ABRV="SOMALIA" "SOM"
173 Q ""
174 ;
175FV(X) ;Is this a Filipino Vet branch of service?
176 ;Added for HVE II (DG*5.3*451)
177 ;INPUT: X = IEN Branch of Service file #23
178 ;OUTPUT: 1 = Filipino Vet BOS (F.COMMONWEALTH, F.GUERILLA, F.SCOUTS NEW)
179 ; 2 = Filipino Vet BOS (F.SCOUTS OLD)
180 ; 0 = Not Filipino Vet BOS
181 N FV
182 I '$G(X) Q 0
183 S FV=$P($G(^DIC(23,X,0)),U,1)
184 Q $S(FV="F.SCOUTS OLD":2,$E(FV,1,2)="F.":1,1:0)
185 ;
186FVP ;MUMPS cross-reference "AFV1" on Service Branch [Last] (#.325), "AFV2"
187 ;on Service Branch [NTL] (#.3291), and "AFV3" on Service Branch [NNTL]
188 ;(#.3296) in the Patient file #2. If the Service Branch fields do not
189 ;contain a Filipino Veteran branch of service, the Filipino Vet Proof
190 ;field (#.3214) will be deleted.
191 Q:'$G(DA)
192 N BOS,MS,FV,IENS,FDA
193 S MS=$G(^DPT(DA,.32))
194 F BOS=5,10,15 S FV=$$FV($P(MS,U,BOS)) Q:FV=1
195 I FV=1 Q ;Filipino Vet BOS found, quit
196 ;Delete Filipino Vet Proof
197 S IENS=DA_",",FDA(2,IENS,.3214)="@"
198 D FILE^DIE("","FDA")
199 Q
200 ;
201MSG(MSGTXT,LF1,LF2) ; This api will format the output text in order to utilize
202 ; the EN^DDIOL utility.
203 ;INPUT: MSGTXT = Message text to display
204 ; LF1 = Number of line feeds to preceed the message
205 ; L2F = Number of line feeds to follow the message
206 ;
207 N MSGARY,LFSTR
208 S $P(LFSTR,"!",50)="!"
209 S:$G(LF1)'="" MSGARY(.5,"F")=$E(LFSTR,1,(LF1-1))
210 S MSGARY(1)=MSGTXT
211 S:$G(LF2)'="" MSGARY(2,"F")=$E(LFSTR,1,LF2)
212 D EN^DDIOL(.MSGARY)
213 Q
214 ;
215CNFLCT ;; *** DO NOT REMOVE BELOW CONFLICT FIELD LOCATIONS ***
216 ;; FROM DATE^TO DATE
217WWI ;;
218WWIIE ;;
219WWIIP ;;
220KOR ;;
221VIET ;;.32104^.32105
222LEB ;;.3222^.3223
223GREN ;;.3225^.3226
224PAN ;;.3228^.3229
225GULF ;;.322011^.322012
226SOM ;;.322017^.322018
227YUG ;;.32202^.322021
228OEF ;;.02^.03
229OIF ;;.02^.03
230UNK ;;.02^.03
231 ;;
232 ;; **BELOW VALUES ARE USED FOR MSE CHECKS - DO NOT REMOVE ***
233 ;; ENTRY DATE^SEPERATION DATE
234MSL ;;.326^.327^.325
235MSNTL ;;.3292^.3293^.3291
236MSNNTL ;;.3297^.3298^.3296
237 ;;
238 ;; **BELOW VALUES ARE USED FOR POW AND COMBAT CHECKS - DO NOT REMOVE
239 ;; FROM DATE^TO DATE^LOCATION
240COMB ;;.5293^.5294^.5292
241POW ;;.527^.528^.526
242 ;;
Note: See TracBrowser for help on using the repository browser.