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

DGRPCE1.m

Go to the documentation of this file. 
  1. DGRPCE1 ;ALB/MIR/BRM/LBD,BAJ,TDM,JAM - CONSISTENCY CHECKER EDIT ;10/20/10 4:16pm
  1.  ;;5.3;Registration;**108,226,470,454,489,505,522,451,632,689,657,688,804,754,797,855,903,952,1075**;Aug 13, 1993;Build 13
  1.  ;Per VHA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;DG*5.3*855
  1.  ; 315 Consistency Check added by patch DG*5.3*903 which was submitted to OSEHRA on 
  1.  ; 04/02/2015 by HP. This update was authored by James Harris 2014-2015
  1.  ;DG*5.3*952
  1.  ; 14 Added EXPANDED MH CARE NON-ENROLLEE check
  1.  ;
  1.  N DGMSERR S DGMSERR=",67,72,73,79,81,83,"
  1.  N I,J F I=1:1:8,16,53,57,58,61:1:89 D SASK
  1.  F I=301,303,304,306:1:308,315,402,403,406,407,501:1:507,516,517 D SASK
  1.  ;F I=49,50,52 D SASK ;BELOW REPLACED WITH ^IBCNSP2 CALL
  1.  ;OLDS DR(2,2.312)="S DGRPADI="""";.01;1;2;15;8;7;3;6;S DGRPADI=X;I DGRPADI'=""v"" S Y=""@2312"";17///^S X=""`""_DFN;16///^S X=""01"";S Y=""@23121"";@2312;17;16//^S X=$S(DGRPADI=""s"":""02"",1:"""");@23121;9:14;"
  1.  Q
  1. SASK I DGER[(","_I_","),DGASK'[(","_I_","),DGMSERR'[(","_I_",") F J=I,I*1000:1 Q:'$T(@J)  S DGD=DGD_$P($T(@J),";;",2,999) D SAVE
  1.  S DGASK=DGASK_I_","
  1.  Q
  1. SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q
  1.  S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
  1.  ;
  1.  ;
  1. ELIG ;eligibility code...if M11+, use compiled template, otherwise DR string
  1.  I ^%ZOSF("OS")'["M/11+" S DGD=$P($T(14),";;",2,999) D SAVE Q
  1.  N DA,DIE,DR S DIE="^DPT(",DA=DFN,DR="[DG CONSISTENCY CHECKER]" D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. 1 ;;.01;
  1. 2 ;;1;
  1. 3 ;;.02;
  1. 4 ;;.03;
  1. 5 ;;.05;
  1. 6 ;;.08;
  1. 7 ;;.09;
  1. 8 ;;N FLG S FLG(2)=1 S:$G(DGER)[",61," FLG(1)=1 D EN^DGREGAED(DFN,.FLG);
  1. 14 ;;.361;S DGECODE=$S($D(^DIC(8,+X,0)):$P(^(0),"^",1),1:"");D:DGECODE["EXPANDED MH CARE NON-ENROLLEE" XPANDED^DGOTHD1(DFN);S:$S(DGECODE["ALLIED":0,DGECODE["FEDERAL":0,1:1) Y=.323;.309;.323;D ^DGYZODS;S:'DGODS Y="@14";11500.02;11500.03;@14;
  1. 16 ;;.351;
  1. 53 ;;.07;.31115;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@53";.3111;S:X']"" Y="@53";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@53;
  1. 57 ;;.381;.382///NOW;
  1. 58 ;;.322013;S:X'="Y" Y="@589";.322014;.322015;.32201;S:X'="Y" Y="@581";.322011;.322012;@581;.322016;S:X'="Y" Y="@589";.322017;.322018;@589;
  1. 61 ;;S:$G(DGER)[",8," Y="@619";.132;@619;
  1. 62 ;;.331;
  1. 63 ;;D EN^DGREGTED(DFN,"CONF");
  1. 64 ;;.092;.093;
  1. 65 ;;.2403;
  1. 66 ;;.09;
  1. 67 ;;S:$$DGERCK^DGRPCE1("73^79^80^81^82",.DGER) Y="@67";W !!,$C(7),"SERVICE SEPARATION DATE [LAST] must be a precise date to determine CV Elig",!;.325;.32911;.326;.327;@67;
  1. 68 ;;S:$$DGERCK^DGRPCE1("39^40",.DGER) Y="@68";W !!,$C(7),"COMBAT TO DATE must be a precise date to determine CV Eligibility",!;.5291;S:X'="Y" Y="@68";.5292;.5293;.5294;@68;
  1. 69 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@69";W !!,$C(7),"YUGOSLAVIA TO DATE must be a precise date to determine CV Eligibility",!;.322019;S:X'="Y" Y="@69";.32202;.322021;@69;
  1. 70 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@70";W !!,$C(7),"SOMALIA TO DATE must be a precise date to determine CV Eligibility",!;.322016;S:X'="Y" Y="@70";.322017;.322018,@70;
  1. 71 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@71";W !!,$C(7),"PERSIAN GULF TO DATE must be a precise date to determine CV Eligibility",!;.32201;S:X'="Y" Y="@71";.322011;.322012;@71;
  1. 72 ;;.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@7201";.3291;.32912;.3292;.3293;.329;@7201;S:'$$YN^DGRPCE1(.32945) Y="@7202";.3296;.32913;.3297;.3298;.3295;@7202;
  1.  ;
  1. 73 ;;S:$$DGERCK^DGRPCE1(72,.DGER) Y="@7302";.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@7301";.3291;.32912;.3292;.3293;.329;@7301;S:'$$YN^DGRPCE1(.32945) Y="@7302";.3296;.32913;.3297;.3298;.3295;@7302;
  1. 74 ;;S:'$$YN^DGRPCE1(.32101) Y="@7401";.32101;S:X'="Y" Y="@7401";.32104;.32105;@7401;S:'$$YN^DGRPCE1(.322016) Y="@7402";.322016;S:X'="Y" Y="@7402";.322017;.322018;@7402;
  1. 74000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7403";.322019;S:X'="Y" Y="@7403";.32202;.322021;@7403;S:'$$YN^DGRPCE1(.3221) Y="@7404";.3221;S:X'="Y" Y="@7404";.3222;.3223;@7404;
  1. 74001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7405";.3224;S:X'="Y" Y="@7405";.3225;.3226;@7405;S:'$$YN^DGRPCE1(.3227) Y="@7406";.3227;S:X'="Y" Y="@7406";.3228;.3229;@7406;
  1. 74002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7407";.32201;S:X'="Y" Y="@7407";.322011;.322012;@7407;
  1. 75 ;;S:$$DGERCK^DGRPCE1(74,.DGER) Y="@7507";S:'$$YN^DGRPCE1(.32101) Y="@7501";.32101;S:X'="Y" Y="@7501";.32104;.32105;@7501;S:'$$YN^DGRPCE1(.322016) Y="@7502";.322016;S:X'="Y" Y="@7502";.322017;.322018;@7502;
  1. 75000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7503";.322019;S:X'="Y" Y="@7503";.32202;.322021;@7503;S:'$$YN^DGRPCE1(.3221) Y="@7504";.3221;S:X'="Y" Y="@7504";.3222;.3223;@7504;
  1. 75001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7505";.3224;S:X'="Y" Y="@7505";.3225;.3226;@7505;S:'$$YN^DGRPCE1(.3227) Y="@7506";.3227;S:X'="Y" Y="@7506";.3228;.3229;@7506;
  1. 75002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7507";.32201;S:X'="Y" Y="@7507";.322011;.322012;@7507;
  1. 76 ;;S:$$DGERCK^DGRPCE1("74^75",.DGER) Y="@7607";S:'$$YN^DGRPCE1(.32101) Y="@7601";.32101;S:X'="Y" Y="@7601";.32104;.32105;@7601;S:'$$YN^DGRPCE1(.322016) Y="@7602";.322016;S:X'="Y" Y="@7602";.322017;.322018;@7602;
  1. 76000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7603";.322019;S:X'="Y" Y="@7603";.32202;.322021;@7603;S:'$$YN^DGRPCE1(.3221) Y="@7604";.3221;S:X'="Y" Y="@7604";.3222;.3223;@7604;
  1. 76001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7605";.3224;S:X'="Y" Y="@7605";.3225;.3226;@7605;S:'$$YN^DGRPCE1(.3227) Y="@7606";.3227;S:X'="Y" Y="@7606";.3228;.3229;@7606;
  1. 76002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7607";.32201;S:X'="Y" Y="@7607";.322011;.322012;@7607;
  1. 77 ;;S:(($$DGERCK^DGRPCE1("37^38",.DGER))!('$$YN^DGRPCE1(.525))) Y="@77";.525;S:X'="Y" Y="@77";.526;.527;.528;@77;
  1. 78 ;;S:(($$DGERCK^DGRPCE1("39^40^68",.DGER))!('$$YN^DGRPCE1(.5291))) Y="@78";.5291;S:X'="Y" Y="@78";.5292;.5293;.5294;@78;
  1. 79 ;;S:$$DGERCK^DGRPCE1("72^73",.DGER) Y="@7902";.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@7901";.3291;.32912;.3292;.3293;.329;@7901;S:'$$YN^DGRPCE1(.32945) Y="@7902";.3296;.32913;.3297;.3298;.3295;@7902;
  1. 80 ;;S:(($$DGERCK^DGRPCE1("37^38^77",.DGER))!('$$YN^DGRPCE1(.525))) Y="@8001";.525;S:X'="Y" Y="@8001";.526;.527;.528;@8001;S:$$DGERCK^DGRPCE1("72^73^79",.DGER) Y="@8003";
  1. 80000 ;;.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8002";.3291;.32912;.3292;.3293;.329;@8002;S:'$$YN^DGRPCE1(.32945) Y="@8003";.3296;.32913;.3297;.3298;.3295;@8003;
  1. 81 ;;S:(($$DGERCK^DGRPCE1("39^40^78",.DGER))!('$$YN^DGRPCE1(.5291))) Y="@8101";.5291;S:X'="Y" Y="@8101";.5292;.5293;.5294;@8101;S:$$DGERCK^DGRPCE1("72^73^79^80",.DGER) Y="@8103";
  1. 81000 ;;.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8102";.3291;.32912;.3292;.3293;.329;@8102;S:'$$YN^DGRPCE1(.32945) Y="@8103";.3296;.32913;.3297;.3298;.3295;@8103;
  1. 82 ;;S:($$DGERCK^DGRPCE1("74^75^76",.DGER)) Y="@8207";S:'$$YN^DGRPCE1(.32101) Y="@8201";.32101;S:X'="Y" Y="@8201";.32104;.32105;@8201;S:'$$YN^DGRPCE1(.322016) Y="@8202";.322016;
  1. 82000 ;;S:X'="Y" Y="@8202";.322017;.322018;@8202;S:'$$YN^DGRPCE1(.322019) Y="@8203";.322019;S:X'="Y" Y="@8203";.32202;.322021;@8203;S:'$$YN^DGRPCE1(.3221) Y="@8204";.3221;
  1. 82001 ;;S:X'="Y" Y="@8204";.3222;.3223;@8204;S:'$$YN^DGRPCE1(.3224) Y="@8205";.3224;S:X'="Y" Y="@8205";.3225;.3226;@8205;S:'$$YN^DGRPCE1(.3227) Y="@8206";.3227;S:X'="Y" Y="@8206";
  1. 82002 ;;.3228;.3229;@8206;S:'$$YN^DGRPCE1(.32201) Y="@8207";.32201;S:X'="Y" Y="@8207";.322011;.322012;@8207;S:($$DGERCK^DGRPCE1("72^73^79^80^81",.DGER)) Y="@8209";
  1.  ;DG*5.3*855
  1. 82003 ;;S Y="@8209";.325;.32911;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8208";.3291;.32912;.3292;.3293;.329;@8208;S:'$$YN^DGRPCE1(.32945) Y="@8209";.3296;.32913;.3297;.3298;.3295;@8209;
  1. 83 ;;S:$$DGERCK^DGRPCE1(73,.DGER) Y="@83";@8295;D SET32^DGRPE(DA,.DIPA,1);.325;S DIPA("X1")=X S:X']"" Y="@83";S:$$FV^DGRPMS(X)'=1 Y="@8296";.3214;I X']"" W !?4,$C(7),"Proof is required for Filipino Vet." S Y="@8295";
  1. 83000 ;;@8296;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y) S:$E(Y,1,4)="@601" Y=.326;.32911;.326;.327;
  1. 83001 ;;.3285//NO;S:X'="Y" Y="@83";D SET32^DGRPE(DA,.DIPA,2);.3291;S DIPA("X2")=X S:X']"" Y="@83";S:$$FV^DGRPMS(X)'=1 Y="@832";.3214;I X']"" W !?4,$C(7),"Proof is required for Filipino Vet." S Y=".3291";S Y=.3292;
  1. 83002 ;;@832;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y) S:$E(Y,1,4)="@601" Y=.3292;.32912;.3292;.3293;
  1. 83003 ;;.32945//NO;S:X'="Y" Y="@83";D SET32^DGRPE(DA,.DIPA,3);.3296;S DIPA("X3")=X S:X']"" Y="@83";S:$$FV^DGRPMS(X)'=1 Y="@833";.3214;I X']"" W !?4,$C(7),"Proof is required for Filipino Vet." S Y=".3296";S Y=.3297;@833;
  1. 83004 ;;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y) S:$E(Y,1,4)="@601" Y=.3297;.32913;.3297;.3298;@83;
  1. 84 ;;.3214;
  1. 85 ;;1901;
  1. 86 ;;1901;
  1. 87 ;;D VETTYPE^DGRPE1;D MSG^DGRPE1 S Y=0;@114;K DGRDCHG;D DR^DGRPE1;.302;.3721;D EFF^DGRPE1;D:$G(DGRDCHG) BULL^DGRPE1;K DGRDCHG;
  1. 88 ;;D EN^DGREGTED(DFN,"TEMP");
  1. 89 ;;391;
  1. 301 ;;.01;
  1. 303 ;;.02;
  1. 304 ;;.02;
  1. 306 ;;.09;
  1. 307 ;;.0906;
  1. 308 ;;.351;
  1. 315 ;;D:$$MHVENABL^DGMHVUTL() MHVPCHK^DGMHVUTL(DFN);
  1. 402 ;;.381;
  1. 403 ;;.382;
  1. 406 ;;.313;
  1. 407 ;;.3611;
  1. 501 ;;.525;
  1. 502 ;;.3602;
  1. 503 ;;.3603;
  1. 504 ;;.32102;
  1. 505 ;;.32103;
  1. 506 ;;.322013;
  1.  ; DG*5.3*1075 - If Radiation Indicated? field (#.32103) is not Yes, skip to end.   
  1.  ;             - Add "R" to Radiation Method field (#.3212), making it Required
  1. 507 ;;.32103;S:X'="Y" Y="@50";.3212R;@50;
  1. 516 ;;.03;
  1. 517 ;;.03;
  1.  ;
  1. YN(FLD,DFN,FILE) ; return binary for YES/NO flds in the Patient (#2) file
  1.  N RTN
  1.  Q:$G(FLD)']"" ""
  1.  S:$G(FILE)="" FILE=2 S:$G(DFN)="" DFN=$G(DA) Q:$G(DFN)']"" ""
  1.  S RTN=$$GET1^DIQ(FILE,DFN_",",FLD,"I")
  1.  Q $S(RTN=1:1,RTN=0:0,RTN="Y":1,RTN="N":0,1:"")
  1.  ;
  1. DGERCK(STR,DGER) ;do any of the STR errors exist in DGER?
  1.  N RTN,X
  1.  Q:$G(STR)']"" 0  Q:$G(DGER)']"" 0
  1.  S RTN=0 F X=1:1 Q:RTN!($P(STR,"^",X)="")  I DGER[(","_$P(STR,"^",X)_",") S RTN=1
  1.  Q RTN
  1.  ;
  1. NEWMSE(DFN) ;Is there data in the new MSE sub-file #2.3216?
  1.  I $G(DFN)="" S DFN=$G(DA)
  1.  Q:$G(DFN)="" 0
  1.  I $O(^DPT(DFN,.3216,0)) Q 1
  1.  Q 0
  1.  ;
  1. MSERR() ;Are there MSE data inconsistencies?
  1.  N ERR,RTN
  1.  S RTN=0
  1.  ;DG*5.3*855
  1.  F ERR=9,10,11,12,13,14,18,19,20,22,24,36,51,67,72,73,79,81,82,83 I DGER[(","_ERR_",") S RTN=1 Q
  1.  Q RTN