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

DGRPC3.m

Go to the documentation of this file.
  1. DGRPC3 ;ALB/PJR,LBD,BAJ,TDM,JDB,JDB,JDB - CHECK CONSISTENCY OF PATIENT DATA (CONT) ;10/20/10 3:40pm
  1. ;;5.3;Registration;**451,632,673,657,688,754,797,867,903,952,1098,1109,1111**;Aug 13, 1993;Build 18
  1. ;Per VHA Directive 6402, this routine should not be modified.
  1. ;
  1. ; 315 subroutine added by patch DG*5.3*903 which was submitted to OSEHRA
  1. ; on 04/02/2015 by HP. This update was authored by James Harris 2014-2015
  1. ;
  1. 79 ;; MSE Dates overlap
  1. ;; Don't check if MSE Dates Incomplete or if MSE TO precedes FROM
  1. ;; or unless at least 2 ranges
  1. S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR!($L(ANYMSE)<2) D NEXT G @DGLST
  1. ;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
  1. I $D(DGPMSE) D D NEXT G @DGLST
  1. .N MS,MSE,OUT S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
  1. ..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE verified by HEC
  1. ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE
  1. ..I '$$OVRLPCHK^DGRPDT(DFN,$P(DGPMSE(MS),U),$P(DGPMSE(MS),U,2),1,"","",MSE) S X=79 D COMB S (MSERR,OUT)=1 Q
  1. ;Otherwise, use MSE data in DGP(.32)
  1. 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
  1. 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
  1. D NEXT G @DGLST
  1. 80 ;; POW Dates not within MSE
  1. ;; Check turned off by EVC project (DG*5.3*688)
  1. D NEXT G @DGLST
  1. 81 ;; Combat Dates not within MSE
  1. I '$P(DGP(.52),"^",12) D NEXT G @DGLST ;; Don't check if no COMBAT Data
  1. ;; Don't check if COMBAT Data Incomplete or if COMBAT TO precedes FROM
  1. I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
  1. S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
  1. ;; If COMBAT, but no MSE, then Range is NOT within MSE
  1. I 'ANYMSE S X=81 D COMB D NEXT G @DGLST
  1. I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=81 D COMB
  1. D NEXT G @DGLST
  1. 82 ;; Conflict Dates not within MSE
  1. S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
  1. S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
  1. S LOC="",I2=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC="" I CONARR(LOC)=1 D
  1. .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
  1. .S DATA=CONSPEC(LOC)
  1. .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
  1. .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
  1. .I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB:'I2 S CONARR(LOC)=2,I2=1
  1. .Q
  1. ; Check OIF/OEF conflict dates
  1. N DGOEIF D GET^DGENOEIF(DFN,.DGOEIF,0,"",0)
  1. I $G(DGOEIF("COUNT")),DGER'[",82," D
  1. . N Z
  1. . S Z=0 F S Z=$O(DGOEIF("IEN",Z)) Q:'Z D Q:DGER[",82,"
  1. .. S FROMDAT=$G(DGOEIF("FR",Z)),TODAT=$G(DGOEIF("TO",Z)),LOC=$G(DGOEIF("LOC",Z))
  1. .. I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB S I2=1
  1. D NEXT G @DGLST
  1. 83 ;Merchant Seaman or Filipino Vet BOS requires service dates during WWII
  1. N BOS,BOSN,MS,MSE,OUT
  1. ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
  1. I $D(DGPMSE) D D NEXT G @DGLST
  1. .S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
  1. ..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE if verified by HEC
  1. ..S BOS=$P(DGPMSE(MS),U,3) Q:'BOS S BOSN=$P(^DIC(23,BOS,0),U)
  1. ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE S MSE="MSE-"_MSE
  1. ..I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
  1. ;Otherwise, get MSE data from DGP(.32)
  1. F MS=1:1:3 D Q:$G(OUT)
  1. .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
  1. .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
  1. .S BOS=$P(DGP(.32),U,(5*MS)) Q:'BOS S BOSN=$P($G(^DIC(23,BOS,0)),U)
  1. .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
  1. .I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
  1. D NEXT G @DGLST
  1. 84 ;Filipino Vet BOS requires Filipino Vet Proof
  1. N MS,BOS,OUT,MSE
  1. ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
  1. I $D(DGPMSE) D D NEXT G @DGLST
  1. .S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
  1. ..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE if verified by HEC
  1. ..S BOS=$P(DGPMSE(MS),U,3) Q:'BOS
  1. ..I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
  1. ;Otherwise use MSE data in DGP(.32)
  1. F MS=1:1:3 D Q:$G(OUT)
  1. .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
  1. .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
  1. .S BOS=$P(DGP(.32),U,(5*MS))
  1. .I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
  1. D NEXT G @DGLST
  1. 85 ;Eligible Filipino Vet should have Veteran status = 'YES'
  1. 86 ;Ineligible Filipino Vet should have Veteran status = 'NO'
  1. N MS,BOS,FV,FILV,NOTFV,MSE,OUT
  1. ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
  1. I $D(DGPMSE) D
  1. .S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
  1. ..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE if verified by HEC
  1. ..S BOS=$P(DGPMSE(MS),U,3),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
  1. ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE S MSE="MSE-"_MSE
  1. ..I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
  1. ..I FV=2 S FILV("E")="" Q
  1. ..I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
  1. ..S FILV("E")=""
  1. ;Otherwise, get MSE data from DGP(.32)
  1. E F MS=1:1:3 D Q:$G(OUT)
  1. .I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
  1. .I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
  1. .S BOS=$P(DGP(.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
  1. .S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
  1. .I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
  1. .I FV=2 S FILV("E")="" Q
  1. .I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
  1. .S FILV("E")=""
  1. I $D(FILV) D
  1. .I DGVT'=1,$D(FILV("E")) S X=85 D COMB Q
  1. .I DGCHK'[(",86,") Q
  1. .I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S X=86 D COMB
  1. S DGLST=86
  1. D NEXT G @DGLST
  1. 87 ; DG*5.3*657 BAJ 11/24/2005 CC #87 added
  1. ; SC Eligibility but no rated Disability Codes
  1. ; 1. Svc Connected is answered "YES"
  1. ; 2. Eligibility code is either SC < 50% or SC 50-100%
  1. ; 3. Svc connected %-age is 0 or greater
  1. ; 4. Patient has no rated disabilities
  1. ; .. VAEL(1) $P 1 = Primary Eligibility Code $p 2 = Primary Elig External Value
  1. ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
  1. ; .. Rated Disabilities : ^DPT(DFN,.372,0) $P 4 is number of records '($P($G(^DPT(DFN,.372,0)),"^",4)) is TRUE
  1. ;
  1. ; Get Eligibility info
  1. D ELIG^VADPT
  1. ;
  1. ; If not svc connected, don't check
  1. I '$G(VAEL(3)) D NEXT G @DGLST
  1. ;
  1. I +VAEL(3)=1!(+VAEL(3)=3) D
  1. . Q:$P(VAEL(3),"^",2)<0
  1. . Q:$P(VAEL(3),"^",2)=""
  1. . I '($P($G(^DPT(DFN,.372,0)),"^",4)) S X=87 D COMB
  1. D NEXT G @DGLST
  1. ;
  1. 88 ;Temporary Address check
  1. N STR88,J,DGI,DGERR,START,END
  1. S DGERR=0
  1. I $P(DGP(.121),U,9)="Y" D
  1. . ;check only if current date is within effective range
  1. . S START=$P(DGP(.121),U,7),END=$P(DGP(.121),U,8)
  1. . Q:START="" I END="" S END=9999999
  1. . ; quit if current date is not within range
  1. . I '(DT'<START&(DT'>END)) Q
  1. . ; country is either NULL or non-numeric
  1. . I '$P(DGP(.122),U,3) S DGERR=1 Q
  1. . ; country is not in Country file
  1. . I '$D(^HL(779.004,$P(DGP(.122),U,3))) S DGERR=1 Q
  1. . S STR88="1,4,5,6" I $$FORIEN^DGADDUTL($P(DGP(.122),"^",3)) S STR88="1,4"
  1. . F J=1:1:$L(STR88,",") S DGI=$P(STR88,",",J) Q:DGERR I $P(DGP(.121),U,DGI)="" S DGERR=1
  1. I DGERR S X=88 D COMB
  1. D NEXT G @DGLST
  1. 89 ;
  1. N DGPT,DGELIG
  1. S DGPT=$$GET1^DIQ(2,DFN_",",391),DGELIG=$$GET1^DIQ(2,DFN+",",.361)
  1. I DGELIG="EXPANDED MH CARE NON-ENROLLEE",DGPT'="NON-VETERAN (OTHER)" S X=89 D COMB
  1. D NEXT G @DGLST
  1. 99 ; synonymous with END
  1. END I DGNCK S X=99 D COMB
  1. D OVER99CK
  1. I DGEDCN S DGCON=0 D TIME^DGRPC
  1. K C,C1,C2,DGCD,DGD,DGD1,DGD2,DGDATE,DGDEP,DGCHK,DGFL,DGINC,DGISYR,DGLST,DGMS,DGNCK,DGP,DGPMSE,DGPTYP,DGREL,DGSCT,DGT,DGTIME,DGTOT,DGVT,I,I2,I2,J,VAIN,X,X1
  1. G ^DGRPCF
  1. ;
  1. COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
  1. ;;
  1. NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) S:'DGLST DGLST="END"
  1. Q
  1. ;
  1. OVER99CK N DGP,DGSD,RULE,FILERR
  1. D LOADPT^IVMZ07C(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD)
  1. ;DG*5.3*1109 removed 304:GENDER INVALID from following loop
  1. ;F RULE=301,303,304,306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. ;DG*5.3*1111 removed 301:PERSON LASTNAME REQUIRED and 303:GENDER REQUIRED from following loop
  1. ;F RULE=301,303,306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. F RULE=306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. ;DG*5.3*1098 removed 406:CLAIM NUMBER INVALID, from following for loop
  1. F RULE=402,403,407 S DGLST=RULE_"^IVMZ7CE" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. F RULE=501:1:507,516,517 S DGLST=RULE_"^IVMZ7CS" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. F RULE=313 S DGLST=RULE_"^DGRPC3" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. F RULE=314 S DGLST=RULE_"^DGRPC3" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. F RULE=315 S DGLST=RULE_"^DGRPC3" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
  1. S DGLST="END"
  1. Q
  1. ;
  1. 313 ; NEWBORN REQUIRES SPONSOR
  1. N X
  1. S DOB=$P(^DPT(DFN,0),"^",3)
  1. D NOW^%DTC
  1. S NOW=X
  1. I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;NOT A NEWBORN
  1. I $D(^IBA(355.81,"B",DFN)) Q ;already has a sponsor
  1. S FILERR(RULE)=""
  1. Q
  1. ;
  1. 314 ;NEWBORN SPONSOR MUST BE ELIGIBLE
  1. I '$D(^IBA(355.81,"B",DFN)) Q ;Does not have a sponsor
  1. N X
  1. S DOB=$P(^DPT(DFN,0),"^",3)
  1. D NOW^%DTC
  1. S NOW=X
  1. I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;NOT A NEWBORN
  1. N RELIEN,SPNIEN,SPNDFN,ELIG
  1. ;NEED TO FIND SPONSOR IN PATIENT FILE
  1. S RELIEN="",SPNIEN="",SPNDFN="",ELIG=""
  1. S RELIEN=$O(^IBA(355.81,"B",DFN,RELIEN))
  1. S SPNIEN=$$GET1^DIQ(355.81,RELIEN,.02,"I")
  1. S SPNDFN=$$GET1^DIQ(355.8,SPNIEN,.01,"I")
  1. S SPNDFN=$P(SPNDFN,";",1)
  1. S ELIG=$$GET1^DIQ(2,SPNDFN,.3611,"I")
  1. I ELIG'="" Q ;sponsor has an eligibility status
  1. S FILERR(RULE)=""
  1. Q
  1. ;
  1. 315 ; MHV - subroutine added by patch DG*5.3*903
  1. Q:'$G(DFN)!'$G(DGPRFLG)
  1. ;This functionality will not be executed if "Enable MyHealtheVet Prompts?" (#1100.07
  1. ;field in MAS PARAMETERS (43) file is not set to YES (internal value 1)
  1. Q:+$$MHVENABL^DGMHVUTL()'>0
  1. ;
  1. N DGFLDCHK,DGMHVACT,DGMHVOUT,DGMHVQ,X,Y,DIR
  1. Q:$$MHVOK^DGMHVAC(DFN)
  1. ; Quit if MHV ENROLLED/Registered has not been answered, and enrollment/registration
  1. ; action is pending
  1. S DGMHVACT=$$ENQACHK^DGMHVUTL(DFN) Q:(DGMHVACT]"")&'$G(^DPT(DFN,2))
  1. S:'$$MHVOK^DGMHVAC(DFN) FILERR(315)=""
  1. Q