Released DG*5.3*804 SEQ #721 Extracted from mail message **KIDS**:DG*5.3*804^ **INSTALL NAME** DG*5.3*804 "BLD",7976,0) DG*5.3*804^REGISTRATION^0^3090610^y "BLD",7976,1,0) ^^1^1^3090609^ "BLD",7976,1,1,0) Fix errors caused by DGRPCE1 and DGRPE1. "BLD",7976,4,0) ^9.64PA^^ "BLD",7976,6.3) 8 "BLD",7976,"KRN",0) ^9.67PA^779.2^20 "BLD",7976,"KRN",.4,0) .4 "BLD",7976,"KRN",.401,0) .401 "BLD",7976,"KRN",.402,0) .402 "BLD",7976,"KRN",.403,0) .403 "BLD",7976,"KRN",.5,0) .5 "BLD",7976,"KRN",.84,0) .84 "BLD",7976,"KRN",3.6,0) 3.6 "BLD",7976,"KRN",3.8,0) 3.8 "BLD",7976,"KRN",9.2,0) 9.2 "BLD",7976,"KRN",9.8,0) 9.8 "BLD",7976,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",7976,"KRN",9.8,"NM",1,0) DGRPCE1^^0^B59713574 "BLD",7976,"KRN",9.8,"NM",2,0) DGRPE1^^0^B9510061 "BLD",7976,"KRN",9.8,"NM","B","DGRPCE1",1) "BLD",7976,"KRN",9.8,"NM","B","DGRPE1",2) "BLD",7976,"KRN",19,0) 19 "BLD",7976,"KRN",19,"NM",0) ^9.68A^^ "BLD",7976,"KRN",19.1,0) 19.1 "BLD",7976,"KRN",101,0) 101 "BLD",7976,"KRN",409.61,0) 409.61 "BLD",7976,"KRN",771,0) 771 "BLD",7976,"KRN",779.2,0) 779.2 "BLD",7976,"KRN",870,0) 870 "BLD",7976,"KRN",8989.51,0) 8989.51 "BLD",7976,"KRN",8989.52,0) 8989.52 "BLD",7976,"KRN",8994,0) 8994 "BLD",7976,"KRN","B",.4,.4) "BLD",7976,"KRN","B",.401,.401) "BLD",7976,"KRN","B",.402,.402) "BLD",7976,"KRN","B",.403,.403) "BLD",7976,"KRN","B",.5,.5) "BLD",7976,"KRN","B",.84,.84) "BLD",7976,"KRN","B",3.6,3.6) "BLD",7976,"KRN","B",3.8,3.8) "BLD",7976,"KRN","B",9.2,9.2) "BLD",7976,"KRN","B",9.8,9.8) "BLD",7976,"KRN","B",19,19) "BLD",7976,"KRN","B",19.1,19.1) "BLD",7976,"KRN","B",101,101) "BLD",7976,"KRN","B",409.61,409.61) "BLD",7976,"KRN","B",771,771) "BLD",7976,"KRN","B",779.2,779.2) "BLD",7976,"KRN","B",870,870) "BLD",7976,"KRN","B",8989.51,8989.51) "BLD",7976,"KRN","B",8989.52,8989.52) "BLD",7976,"KRN","B",8994,8994) "BLD",7976,"QDEF") ^^^^^^^^^^YES "BLD",7976,"QUES",0) ^9.62^^ "BLD",7976,"REQB",0) ^9.611^1^1 "BLD",7976,"REQB",1,0) DG*5.3*808^1 "BLD",7976,"REQB","B","DG*5.3*808",1) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 804^3090610 "PKG",5,22,1,"PAH",1,1,0) ^^1^1^3090610 "PKG",5,22,1,"PAH",1,1,1,0) Fix errors caused by DGRPCE1 and DGRPE1. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 2 "RTN","DGRPCE1") 0^1^B59713574^B59700884 "RTN","DGRPCE1",1,0) DGRPCE1 ;ALB/MIR/BRM/LBD,BAJ - CONSISTENCY CHECKER EDIT ; 07/18/06 "RTN","DGRPCE1",2,0) ;;5.3;Registration;**108,226,470,454,489,505,522,451,632,689,657,688,804**;Aug 13, 1993;Build 8 "RTN","DGRPCE1",3,0) N I,J F I=1:1:8,16,53,57,58,61:1:88 D SASK "RTN","DGRPCE1",4,0) ;F I=49,50,52 D SASK ;BELOW REPLACED WITH ^IBCNSP2 CALL "RTN","DGRPCE1",5,0) ;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;" "RTN","DGRPCE1",6,0) Q "RTN","DGRPCE1",7,0) SASK I DGER[(","_I_","),DGASK'[(","_I_",") F J=I,I*1000:1 Q:'$T(@J) S DGD=DGD_$P($T(@J),";;",2,999) D SAVE "RTN","DGRPCE1",8,0) S DGASK=DGASK_I_"," "RTN","DGRPCE1",9,0) Q "RTN","DGRPCE1",10,0) SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q "RTN","DGRPCE1",11,0) S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q "RTN","DGRPCE1",12,0) ; "RTN","DGRPCE1",13,0) ; "RTN","DGRPCE1",14,0) ELIG ;eligibility code...if M11+, use compiled template, otherwise DR string "RTN","DGRPCE1",15,0) I ^%ZOSF("OS")'["M/11+" S DGD=$P($T(14),";;",2,999) D SAVE Q "RTN","DGRPCE1",16,0) N DA,DIE,DR S DIE="^DPT(",DA=DFN,DR="[DG CONSISTENCY CHECKER]" D ^DIE "RTN","DGRPCE1",17,0) Q "RTN","DGRPCE1",18,0) ; "RTN","DGRPCE1",19,0) ; "RTN","DGRPCE1",20,0) 1 ;;.01; "RTN","DGRPCE1",21,0) 2 ;;1; "RTN","DGRPCE1",22,0) 3 ;;.02; "RTN","DGRPCE1",23,0) 4 ;;.03; "RTN","DGRPCE1",24,0) 5 ;;.05; "RTN","DGRPCE1",25,0) 6 ;;.08; "RTN","DGRPCE1",26,0) 7 ;;.09; "RTN","DGRPCE1",27,0) 8 ;;N FLG S FLG(2)=1 S:$G(DGER)[",61," FLG(1)=1 D EN^DGREGAED(DFN,.FLG); "RTN","DGRPCE1",28,0) 14 ;;.361;S DGECODE=$S($D(^DIC(8,+X,0)):$P(^(0),"^",1),1:"");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; "RTN","DGRPCE1",29,0) 16 ;;.351; "RTN","DGRPCE1",30,0) 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; "RTN","DGRPCE1",31,0) 57 ;;.381;.382///NOW; "RTN","DGRPCE1",32,0) 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; "RTN","DGRPCE1",33,0) 61 ;;S:$G(DGER)[",8," Y="@619";.132;@619; "RTN","DGRPCE1",34,0) 62 ;;.331; "RTN","DGRPCE1",35,0) 63 ;;D EN^DGREGTED(DFN,"CONF"); "RTN","DGRPCE1",36,0) 64 ;;.092;.093; "RTN","DGRPCE1",37,0) 65 ;;.2403; "RTN","DGRPCE1",38,0) 66 ;;.09; "RTN","DGRPCE1",39,0) 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; "RTN","DGRPCE1",40,0) 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; "RTN","DGRPCE1",41,0) 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; "RTN","DGRPCE1",42,0) 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; "RTN","DGRPCE1",43,0) 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; "RTN","DGRPCE1",44,0) 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; "RTN","DGRPCE1",45,0) ; "RTN","DGRPCE1",46,0) 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; "RTN","DGRPCE1",47,0) 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; "RTN","DGRPCE1",48,0) 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; "RTN","DGRPCE1",49,0) 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; "RTN","DGRPCE1",50,0) 74002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7407";.32201;S:X'="Y" Y="@7407";.322011;.322012;@7407; "RTN","DGRPCE1",51,0) 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; "RTN","DGRPCE1",52,0) 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; "RTN","DGRPCE1",53,0) 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; "RTN","DGRPCE1",54,0) 75002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7507";.32201;S:X'="Y" Y="@7507";.322011;.322012;@7507; "RTN","DGRPCE1",55,0) 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; "RTN","DGRPCE1",56,0) 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; "RTN","DGRPCE1",57,0) 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; "RTN","DGRPCE1",58,0) 76002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7607";.32201;S:X'="Y" Y="@7607";.322011;.322012;@7607; "RTN","DGRPCE1",59,0) 77 ;;S:(($$DGERCK^DGRPCE1("37^38",.DGER))!('$$YN^DGRPCE1(.525))) Y="@77";.525;S:X'="Y" Y="@77";.526;.527;.528;@77; "RTN","DGRPCE1",60,0) 78 ;;S:(($$DGERCK^DGRPCE1("39^40^68",.DGER))!('$$YN^DGRPCE1(.5291))) Y="@78";.5291;S:X'="Y" Y="@78";.5292;.5293;.5294;@78; "RTN","DGRPCE1",61,0) 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; "RTN","DGRPCE1",62,0) 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"; "RTN","DGRPCE1",63,0) 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; "RTN","DGRPCE1",64,0) 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"; "RTN","DGRPCE1",65,0) 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; "RTN","DGRPCE1",66,0) 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; "RTN","DGRPCE1",67,0) 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; "RTN","DGRPCE1",68,0) 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"; "RTN","DGRPCE1",69,0) 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"; "RTN","DGRPCE1",70,0) 82003 ;;.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; "RTN","DGRPCE1",71,0) 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"; "RTN","DGRPCE1",72,0) 83000 ;;@8296;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y) S:$E(Y,1,4)="@601" Y=.326;.32911;.326;.327; "RTN","DGRPCE1",73,0) 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; "RTN","DGRPCE1",74,0) 83002 ;;@832;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y) S:$E(Y,1,4)="@601" Y=.3292;.32912;.3292;.3293; "RTN","DGRPCE1",75,0) 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; "RTN","DGRPCE1",76,0) 83004 ;;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y) S:$E(Y,1,4)="@601" Y=.3297;.32913;.3297;.3298;@83; "RTN","DGRPCE1",77,0) 84 ;;.3214; "RTN","DGRPCE1",78,0) 85 ;;1901; "RTN","DGRPCE1",79,0) 86 ;;1901; "RTN","DGRPCE1",80,0) 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; "RTN","DGRPCE1",81,0) 88 ;;D EN^DGREGTED(DFN,"TEMP"); "RTN","DGRPCE1",82,0) ; "RTN","DGRPCE1",83,0) YN(FLD,DFN,FILE) ; return binary for YES/NO flds in the Patient (#2) file "RTN","DGRPCE1",84,0) N RTN "RTN","DGRPCE1",85,0) Q:$G(FLD)']"" "" "RTN","DGRPCE1",86,0) S:$G(FILE)="" FILE=2 S:$G(DFN)="" DFN=$G(DA) Q:$G(DFN)']"" "" "RTN","DGRPCE1",87,0) S RTN=$$GET1^DIQ(FILE,DFN_",",FLD,"I") "RTN","DGRPCE1",88,0) Q $S(RTN=1:1,RTN=0:0,RTN="Y":1,RTN="N":0,1:"") "RTN","DGRPCE1",89,0) ; "RTN","DGRPCE1",90,0) DGERCK(STR,DGER) ;do any of the STR errors exist in DGER? "RTN","DGRPCE1",91,0) N RTN,X "RTN","DGRPCE1",92,0) Q:$G(STR)']"" 0 Q:$G(DGER)']"" 0 "RTN","DGRPCE1",93,0) S RTN=0 F X=1:1 Q:RTN!($P(STR,"^",X)="") I DGER[(","_$P(STR,"^",X)_",") S RTN=1 "RTN","DGRPCE1",94,0) Q RTN "RTN","DGRPE1") 0^2^B9510061^B9500798 "RTN","DGRPE1",1,0) DGRPE1 ;ALB/MRL,RTK,BRM,RGL,ERC,TDM - REGISTRATIONS EDITS (CONTINUED) ; 4/2/09 11:26am "RTN","DGRPE1",2,0) ;;5.3;Registration;**114,327,451,631,688,808,804**;Aug 13, 1993;Build 8 "RTN","DGRPE1",3,0) ; "RTN","DGRPE1",4,0) ;***CONTAINS ISM SPECIFIC CODE TO AVOID STORE ERRORS WITH ELIG.*** "RTN","DGRPE1",5,0) ; "RTN","DGRPE1",6,0) I DGRPS'=7 F I=1:1 S J=$P(DGDR,",",I) Q:J="" F J1=J,J*1000 Q:'$T(@J1) S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE1",7,0) I DGRPS=7 S DR="[DG LOAD EDIT SCREEN 7]" "RTN","DGRPE1",8,0) ;S DR(2,2.0361)=".01" "RTN","DGRPE1",9,0) D ^DIE K DIE,DR,DGCT,DGDR,DGDRD,DGDRS,I,J,J1 "RTN","DGRPE1",10,0) ;update/set ELIGIBILITY VERIF. SOURCE field (327/Ineligible Project) "RTN","DGRPE1",11,0) I $D(^DPT(DFN,.361)) S DGELG=^DPT(DFN,.361) D "RTN","DGRPE1",12,0) .N DGXEL "RTN","DGRPE1",13,0) .S DGXEL=$P(DGELG,U,5),DATA(.3613)="V" "RTN","DGRPE1",14,0) .I $S($G(DGXEL)["CEV":1,$G(DGXEL)["VBA":1,$G(DGXEL)["VIVA":1,1:0),$P(DGELG,U,6)=.5 S DATA(.3613)="H" "RTN","DGRPE1",15,0) .I '$$UPD^DGENDBS(2,DFN,.DATA) "RTN","DGRPE1",16,0) Q "RTN","DGRPE1",17,0) S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q "RTN","DGRPE1",18,0) S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q "RTN","DGRPE1",19,0) 701 ;;391;D SC7^DGRPV;1901;.301;S:X'="Y" Y=.313;.302;.313;.312; "RTN","DGRPE1",20,0) 702 ;;.361;D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361;.309;361;.323;D ^DGYZODS;S:'DGODS Y=.36265;11500.02;11500.03;.36265;S:X='"Y" Y="@72";.3626;@72; "RTN","DGRPE1",21,0) 703 ;;.3731; "RTN","DGRPE1",22,0) 1001 ;;.152;S:X="" Y="@101";.1651;.1653;.1654;.307;.1656;@101; "RTN","DGRPE1",23,0) 1002 ;;.153;S:X="" Y="@102";.1657:.1659;.16;@102; "RTN","DGRPE1",24,0) 1101 ;;.3611;.3612;.3614;.3615; "RTN","DGRPE1",25,0) 1102 ;;.306; "RTN","DGRPE1",26,0) 1103 ;;.322; "RTN","DGRPE1",27,0) 1104 ;;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; "RTN","DGRPE1",28,0) MSG W !,"Patient is not a veteran. Can't enter rated disabilities",! Q "RTN","DGRPE1",29,0) ; "RTN","DGRPE1",30,0) BULL ; Rated Disabilities update bulletin "RTN","DGRPE1",31,0) ; "RTN","DGRPE1",32,0) Q ; This bulletin has been disabled. DG*5.3*808 "RTN","DGRPE1",33,0) ; "RTN","DGRPE1",34,0) N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ "RTN","DGRPE1",35,0) S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT","")) "RTN","DGRPE1",36,0) Q:'DGMGRP "RTN","DGRPE1",37,0) D XMY^DGMTUTL(DGMGRP,0,1) "RTN","DGRPE1",38,0) S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9) "RTN","DGRPE1",39,0) S XMTEXT="DGBULL(" "RTN","DGRPE1",40,0) S XMSUB="RATED DISABILITY UPDATED" "RTN","DGRPE1",41,0) S DGLINE=0 "RTN","DGRPE1",42,0) D LINE^DGEN("Patient: "_DGNAME,.DGLINE) "RTN","DGRPE1",43,0) D LINE^DGEN("SSN: "_DGSSN,.DGLINE) "RTN","DGRPE1",44,0) D LINE^DGEN("",.DGLINE) "RTN","DGRPE1",45,0) D LINE^DGEN("Send updates to SC Disabilities to HEC via fax or HECAlert",.DGLINE) "RTN","DGRPE1",46,0) D LINE^DGEN("Outlook mail group so that they can be entered into VHA's",.DGLINE) "RTN","DGRPE1",47,0) D LINE^DGEN("Authoritative Database. SC Disability information entered directly",.DGLINE) "RTN","DGRPE1",48,0) D LINE^DGEN("into VistA may be overlaid.",.DGLINE) "RTN","DGRPE1",49,0) D ^XMD "RTN","DGRPE1",50,0) Q "RTN","DGRPE1",51,0) DR ; "RTN","DGRPE1",52,0) K DGSCPC "RTN","DGRPE1",53,0) S DGSCPC=$P($G(^DPT(DFN,.3)),U,2) "RTN","DGRPE1",54,0) S DR(2,2.04)=".01;2;3" "RTN","DGRPE1",55,0) Q "RTN","DGRPE1",56,0) EFF ; "RTN","DGRPE1",57,0) I $G(DGSCPC)=$P($G(^DPT(DFN,.3)),U,2) Q "RTN","DGRPE1",58,0) S DGFDA(2,DFN_",",.3014)="@" "RTN","DGRPE1",59,0) D FILE^DIE("","DGFDA","DGERR") "RTN","DGRPE1",60,0) K DGFDA,DGSCPC "RTN","DGRPE1",61,0) Q "RTN","DGRPE1",62,0) VETTYPE ; "RTN","DGRPE1",63,0) S:$S('$D(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0) Y="@114" Q "RTN","DGRPE1",64,0) S:'$S('$D(^("TYPE")):1,'$D(^DG(391,+^("TYPE"),0)):1,$P(^(0),"^",2):0,1:1) Y="@114" "RTN","DGRPE1",65,0) Q "VER") 8.0^22.0 "BLD",7976,6) ^721 **END** **END**