Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m
r613 r623 1 DGRPCE 2 ;;5.3;Registration;**121,122,175,297,342,451,626,689,653,634**;Aug 13, 1993;Build 30 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 NKEY 38 39 40 41 42 43 44 45 46 47 48 49 50 51 KVAR 52 Q 53 54 55 56 SASK 57 58 SAVE 59 60 ELDR 61 62 63 64 65 66 67 68 69 70 71 72 MON 73 74 75 76 77 15 78 23 79 25 80 26 81 27 82 28 83 29 84 30 85 31 86 32 87 33 88 34 89 35 90 37 91 38 92 39 93 40 94 41 95 42 96 43 97 44 98 45 99 46 100 47 101 48 102 51 103 56 104 60 105 106 107 108 ASKSSN(DEP) 109 110 111 112 113 114 PS 115 116 117 118 119 120 121 122 CATDIB 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 ASKDEL() 149 150 151 152 153 154 155 156 157 1 DGRPCE ;ALB/MRL,KV,PJR,BRM - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am 2 ;;5.3;Registration;**121,122,175,297,342,451,626,689,653,634**;Aug 13, 1993;Build 28 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 ; 20 ;KV;11/15/00;DG*5.3*297;Disable addition of CD Elig Code in Reg. Screens 21 ; ;Adding CD Elig Codes in Load/Edit Screen used to 22 ; ;cause undefined line tag error. 23 ; 24 S DGVTYN=$P($G(^DPT(DFN,"VET")),"^",1),DGDR="DR",(DR,DGD,DGDRC,DGCCF)="",DGASK=",",DGER=","_DGER D ^DGRPCE1 25 S DGEK=0 F I=9,10,11,12,13,14,18,19,20,22,24,36,51 Q:DGEK I DGER[(","_I_",") S DGEK=1 Q 26 I 'DGKEY(1) D:DGEK ELDR S I=15 D SASK S I=23 D SASK 27 ;New EHR code DAOU/WCJ 2/5/05 28 ;skip veteran related fields for agency EHR 29 G NKEY:$G(DUZ("AG"))="E" 30 ;End EHR new code 31 F I=29,30,31,32,33,43,44,45,48,56 D SASK,MON:DGCCF S DGCCF=0 32 G NKEY:DGKEY(3) F I=25,26,27,28,34,35 D SASK 33 I DGASK'[26 F I=41,42 I DGASK'[41 D SASK 34 I DGASK'[27 S I=60 I DGASK'[25 D SASK 35 I DGASK'[34 F I=37,38 I DGASK'[37 D SASK 36 I DGASK'[35 F I=39,40 I DGASK'[39 D SASK 37 NKEY D ^DGRPCE1 38 I $S(DGER[49:1,(DGER[50):1,(DGER[52):1,1:0) D 39 .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q 40 .D REG^IBCNBME(DFN) 41 .Q 42 D Q S DIE="^DPT(",(DA,Y)=DFN D ^DIE:$D(DR) 43 I DGER[54 D GETREL^DGMTU11(DFN,"SD",$$LYR^DGMTSCU1(DT)) D 44 . I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") D ASKSSN(DGREL("S")) 45 . F DGDEP=0:0 S DGDEP=$O(DGREL("D",DGDEP)) Q:'DGDEP I $$SSN^DGMTU1(+DGREL("D",DGDEP))']"" D ASKSSN(DGREL("D",DGDEP)) 46 ; 47 I DGER[59 D CATDIB 48 I DGER["82" D EN2^DGRP6CL 49 ; 50 K DGREL,DGDEP 51 KVAR K DR,DGEDCN,DGCT,DGER,DGINC55,DGRPADI,DGRPOUT,DGVTYN 52 Q K %,C,DA,DGASK,DGCCF,DGCT1,DGCT2,DGCT3,DGD,DGD1,DGD2,DGDR,DGDRC,DGECODE,DGEDIT,DGEK,DGKEY,DGP,DGRPADI,DGRPE,DIC,DIE,DIK,I,I1,J,X,X1,X2 53 K DGCOMLOC,DGCOMBR,FRDT,DGFRDT 54 D KVAR^VADPT 55 Q 56 SASK I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=$P($T(@I),";;",2,999),DGASK=DGASK_I_",",DGCCF=1 D SAVE 57 Q 58 SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q 59 S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q 60 ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38," 61 ;Previous VA code prior to EHR changes 62 ;I 'DGKEY(1) S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE 63 ;I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE 64 ;D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE 65 ;New code DAOU/WCJ 2/5/05 Skip veteran specific fields 66 I 'DGKEY(1),$G(DUZ("AG"))'="E" S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE 67 I 'DGKEY(2),$G(DUZ("AG"))'="E" F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE 68 D:DGD]"" SAVE I 'DGKEY(3),$G(DUZ("AG"))'="E" S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE 69 ;End new code DAOU/WCJ 2/5/05 70 I 'DGKEY(1) D ELIG^DGRPCE1 71 Q 72 MON I $S(I<40:1,I=56:1,1:0) D SAVE Q 73 I $S(I<46:1,1:0),DGASK'[(","_(I-14)_",") D SAVE Q 74 I DGASK'[(","_(I-15)_",") D SAVE 75 Q 76 ; 77 15 ;;.152;S:X']"" Y="@15";S DIE("NO^")="";.307;I X']"" W !!,*7,"But I need a reason why this applicant is ineligible!" S Y=.152;@15;K DIE("NO^"); 78 23 ;;.3611;S:X'="V" Y="@23";.3612;S DIE("NO^")="";I X']"" W !!,*7,"But I need to know the date eligibility was verifed!";@23;K DIE("NO^"); 79 25 ;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25; 80 26 ;; 81 27 ;; 82 28 ;; 83 29 ;;.36205;S:X'="Y" Y="@29";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim A&A" S Y=.36205;.36295;@29; 84 30 ;;.36215;S:X'="Y" Y="@30";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim HOUSEBOUND" S Y=.36215;.36295;@30; 85 31 ;;.36235;S:X'="Y" Y="@31";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim VA PENSION" S Y=.36235;.36295;@31; 86 32 ;;.36255;S:X'="Y" Y="@32";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim MIL. RET." S Y=.36255;.3625;@32; 87 33 ;; 88 34 ;;.525;S:X'="Y" Y="@34";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim POW STATUS" S Y=.525;.526:.528;@34; 89 35 ;; 90 37 ;;.525;S:X'="Y" Y="@37";.526:.528;@37; 91 38 ;;.525;S:X'="Y" Y="@38";.526:.528;@38; 92 39 ;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39; 93 40 ;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40; 94 41 ;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41; 95 42 ;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42; 96 43 ;; 97 44 ;; 98 45 ;; 99 46 ;; 100 47 ;; 101 48 ;;.36265;S:X'="Y" Y="@48";.3626;@48; 102 51 ;;I DGVTYN'="Y" S Y="@51";.324:.328;@51; 103 56 ;;.3025;S:X'="Y" Y="@56";.36295;@56; 104 60 ;;.32102;S:X'="Y" Y="@60";.32107;.3211;.32109;.3213;@60; 105 ; 106 ; NOTE: #46 & 47 REMOVED WITH PIMS5.3 107 ; 108 ASKSSN(DEP) ;edit ssns if missing 109 ; 110 ; input: DEP as string for dependent (from GETREL) 111 ; 112 W !,$$NAME^DGMTU1(+DEP) 113 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE 114 PS ; 115 S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE 116 I $$GET1^DIQ(408.13,DA_",",.09)["P" D 117 . S DR=.1,DA=$P(DA,";") D ^DIE 118 . I X']"" W !,"If SSN is a Pseudo SSN, the Pseudo SSN Reason field is required." G PS 119 K DA,DR,DIE 120 Q 121 ; 122 CATDIB ; 123 ;Could be inconsistent because there is the catastrophic disability 124 ;code without supporting information, or visa versa 125 ; 126 N DGCDIS,CODE,INFO 127 S (INFO,CODE)=0 128 I $$GET^DGENCDA(DFN,.DGCDIS),DGCDIS("DATE") S INFO=1 129 S CODE=$$HASCAT^DGENCDA(DFN) 130 I CODE D Q 131 .W !!,">>> Catastrophically Disabled eligibilty requires additional information <<<" 132 .D EDITCD^DGENCD(DFN) 133 I INFO D 134 . ;KV;11/15/00;DG*5.3*297;Start of modifications 135 . W !!,"The patient record indicates that a determination was made " 136 . W "that the patient",!,"is catastrophically disabled." 137 . W !!,"To add Catastrophic Disability Eligibility Code(s), please use " 138 . W "the menu option",!,"DGEN PATIENT ENROLLMENT.",!! 139 .I $$ASKDEL() D 140 .. I $$DELETE^DGENCDA1(DFN) D 141 ...W !,">>> Determination Deleted <<<" 142 ..; 143 ..;could fail if lock could not be obtained 144 ..E W !,"Catastrophic disability determination can not be deleted at this time.",!,"Please try again later." 145 ;KV;11/15/00;DG*5.3*297;End of modifications 146 Q 147 ; 148 ASKDEL() ; 149 ;ask whether to delete catastrphic disability determination 150 N DIR 151 S DIR(0)="Y" 152 ;KV;11/15/00;DG*5.3*297;Cosmetic change for DIR("A") 153 S DIR("A")="Do you want to delete the determination showing that patient is catastrophically disabled" 154 S DIR("B")="YES" 155 D ^DIR 156 Q:$D(DIRUT) 0 157 Q $S(Y=1:1,1:0)
Note:
See TracChangeset
for help on using the changeset viewer.
