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

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1DGRPC3 ;ALB/PJR,LBD - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 08/15/2006 1:00 PM
2 ;;5.3;Registration;**451,632,673,657**;Aug 13, 1993;Build 19
3 ;
479 ;; MSE Dates overlap
5 ;; Don't check if MSE Dates Incomplete or if MSE TO precedes FROM
6 ;; or unless at least 2 ranges
7 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR!($L(ANYMSE)<2) D NEXT G @DGLST
8 I ANYMSE[1,'$$OVRLPCHK^DGRPDT(DFN,$P(DGP(.32),"^",6),$P(DGP(.32),"^",7),1,".326^.327") S X=79 D COMB S MSERR=1 D NEXT G @DGLST
9 I ANYMSE'[1,'$$OVRLPCHK^DGRPDT(DFN,$P(DGP(.32),"^",11),$P(DGP(.32),"^",12),1,".3292^.3293") S X=79 D COMB S MSERR=1 D NEXT G @DGLST
10 D NEXT G @DGLST
1180 ;; POW Dates not within MSE
12 I '$P(DGP(.52),"^",6) D NEXT G @DGLST ;; Don't check if no POW Data
13 ;; Don't check if POW Data Incomplete or if POW TO precedes FROM
14 I ((","_DGER_",")[(",37,"))!((","_DGER_",")[(",38,")) D NEXT G @DGLST
15 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
16 ;; If POW, but no MSE, then Range is NOT within MSE
17 I 'ANYMSE S X=80 D COMB D NEXT G @DGLST
18 I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),$P(DGP(.52),"^",7),$P(DGP(.52),"^",8)) S X=80 D COMB
19 D NEXT G @DGLST
2081 ;; Combat Dates not within MSE
21 I '$P(DGP(.52),"^",12) D NEXT G @DGLST ;; Don't check if no COMBAT Data
22 ;; Don't check if COMBAT Data Incomplete or if COMBAT TO precedes FROM
23 I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
24 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
25 ;; If COMBAT, but no MSE, then Range is NOT within MSE
26 I 'ANYMSE S X=81 D COMB D NEXT G @DGLST
27 I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=81 D COMB
28 D NEXT G @DGLST
2982 ;; Conflict Dates not within MSE
30 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
31 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
32 S LOC="",I2=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC="" I CONARR(LOC)=1 D
33 .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
34 .S DATA=CONSPEC(LOC)
35 .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
36 .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
37 .I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB:'I2 S CONARR(LOC)=2,I2=1
38 .Q
39 ; Check OIF/OEF conflict dates
40 N DGOEIF D GET^DGENOEIF(DFN,.DGOEIF,0,"",0)
41 I $G(DGOEIF("COUNT")),DGER'[",82," D
42 . N Z
43 . S Z=0 F S Z=$O(DGOEIF("IEN",Z)) Q:'Z D Q:DGER[",82,"
44 .. S FROMDAT=$G(DGOEIF("FR",Z)),TODAT=$G(DGOEIF("TO",Z)),LOC=$G(DGOEIF("LOC",Z))
45 .. I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB S I2=1
46 D NEXT G @DGLST
4783 ;Merchant Seaman or Filipino Vet BOS requires service dates during WWII
48 N BOS,BOSN,MS,MSE,OUT
49 F MS=1:1:3 D Q:$G(OUT)
50 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
51 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
52 .S BOS=$P(DGP(.32),U,(5*MS)) Q:'BOS S BOSN=$P($G(^DIC(23,BOS,0)),U)
53 .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
54 .I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
55 D NEXT G @DGLST
5684 ;Filipino Vet BOS requires Filipino Vet Proof
57 N MS,BOS,OUT
58 F MS=1:1:3 D Q:$G(OUT)
59 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
60 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
61 .S BOS=$P(DGP(.32),U,(5*MS))
62 .I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
63 D NEXT G @DGLST
6485 ;Eligible Filipino Vet should have Veteran status = 'YES'
6586 ;Ineligible Filipino Vet should have Veteran status = 'NO'
66 N MS,BOS,FV,FILV,NOTFV,MSE,OUT
67 F MS=1:1:3 D Q:$G(OUT)
68 .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
69 .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
70 .S BOS=$P(DGP(.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
71 .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
72 .I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
73 .I FV=2 S FILV("E")="" Q
74 .I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
75 .S FILV("E")=""
76 I $D(FILV) D
77 .I DGVT'=1,$D(FILV("E")) S X=85 D COMB Q
78 .I DGCHK'[(",86,") Q
79 .I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S X=86 D COMB
80 S DGLST=86
81 D NEXT G @DGLST
8287 ; DG*5.3*657 BAJ 11/24/2005 CC #87 added
83 ; SC Eligibility but no rated Disability Codes
84 ; 1. Svc Connected is answered "YES"
85 ; 2. Eligibility code is either SC < 50% or SC 50-100%
86 ; 3. Svc connected %-age is 0 or greater
87 ; 4. Patient has no rated disabilities
88 ; .. VAEL(1) $P 1 = Primary Eligibility Code $p 2 = Primary Elig External Value
89 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
90 ; .. Rated Disabilities : ^DPT(DFN,.372,0) $P 4 is number of records '($P($G(^DPT(DFN,.372,0)),"^",4)) is TRUE
91 ;
92 ; Get Eligibility info
93 D ELIG^VADPT
94 ;
95 ; If not svc connected, don't check
96 I '$G(VAEL(3)) D NEXT G @DGLST
97 ;
98 I +VAEL(3)=1!(+VAEL(3)=3) D
99 . Q:$P(VAEL(3),"^",2)<0
100 . Q:$P(VAEL(3),"^",2)=""
101 . I '($P($G(^DPT(DFN,.372,0)),"^",4)) S X=87 D COMB
102 D NEXT G @DGLST
103 ;
10499 ; synonymous with END
105END I DGNCK S X=99 D COMB
106 I DGEDCN S DGCON=0 D TIME^DGRPC
107 K C,C1,C2,DGCD,DGD,DGD1,DGD2,DGDATE,DGDEP,DGCHK,DGFL,DGINC,DGISYR,DGLST,DGMS,DGNCK,DGP,DGPTYP,DGREL,DGSCT,DGT,DGTIME,DGTOT,DGVT,I,I2,I2,J,VAIN,X,X1
108 G ^DGRPCF
109 ;
110COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
111 ;;
112NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) S:'DGLST DGLST="END"
113 Q
Note: See TracBrowser for help on using the repository browser.