source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLSC.m@ 1147

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1SDWLSC ;IOFO BAY PINES/DMR - WAITING LIST-RATED DISABILITY ;09/02/2004 2:10 PM
2 ;;5.3;scheduling;**394,417**;SEP 02 2004
3 ;
4 ;
5 ;***********************************************************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ; 12/09/2005 SD*5.3*394 New Routine for SC disabilities prompt
11 ;
12 ;IA Agreements:
13 ;
14 ;DBIA - 1476 For reference to PRIMARY ELIG. ^DPT(IEN,.372).
15 ;DBIA - 427 For reference to ^DIC(8).
16 ;
17 ;Variable: SDWLNSC killed in routine SDWLE113 - Routine SDWLSC called from SDWLE111.
18 ; SDWLDFN NOT killed - referenced only.
19 ;
20 ;09/23/2006 Patch SD*5.3*417 Upper/Lower case usage.
21 ;
22 D 2^VADPT S SDWLNSC=0
23 Q:'$D(SDWLDFN)
24 Q:$$GET1^DIQ(2,SDWLDFN_",",.301,"E")'="YES"
25 Q:$P(VAEL(1),"^",2)'["50%"
26 S SDWLNSC=$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2)
27 W !!,"PATIENT'S SERVICE CONNECTION AND RATED DISABILITIES:"
28 IF $D(^DPT(SDWLDFN,.3)) D
29 .W !,$S($P($G(^DPT(SDWLDFN,.3)),"^",1)="Y":"SC Percent: "_$P(^(.3),"^",2)_"%",1:"Service Connected: No")
30 .W !,"Primary Eligibility Code: "_$P(VAEL(1),"^",2)
31 ;Rated Disabilities
32 N SDSER,SDRAT,SDPER,SDREC,NN,NUM,ANS S (NN,NUM)=0
33 F S NN=$O(^DPT(SDWLDFN,.372,NN)) Q:'NN D
34 .S SDREC=$G(^DPT(SDWLDFN,.372,NN,0)) IF SDREC'="" D
35 ..S SDRAT="" S NUM=$P($G(SDREC),"^",1) IF NUM>0 S SDRAT=$$GET1^DIQ(31,NUM_",",.01)
36 ..S SDSER="" S SDSER=$S($P(SDREC,"^",3)="1":"SC",1:"NSC")
37 ..W !," "_SDRAT_" ("_SDSER_" - "_$P(SDREC,"^",2)_"%)"
38 ..Q
39 W !
40 N SDSCFLD,SDELIG S SDSCFLD=0
41 S SDELIG=$$GET1^DIQ(2,SDWLDFN_",",.301,"E")
42 IF $P(VAEL(1),U,2)="" W !,"'PRIMARY ELIGIBILITY CODE' field is blank please update patient record." S SDSCFLG=1
43 IF SDELIG="YES",($P(VAEL(3),"^",2)<50),($P(VAEL(1),"^",2)'="SC LESS THAN 50%") D
44 .W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLD=1
45 IF SDELIG="YES",($P(VAEL(3),"^",2)>49),($P(VAEL(1),"^",2)'="SERVICE CONNECTED 50% to 100%") D
46 .W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLD=1
47 IF $P($G(^DPT(SDWLDFN,.372,0)),"^",4)<1 W !,"NO SERVICE CONNECTED DISABILITIES LISTED" W !
48 D SBR
49 K SDSCFLD Q
50SBR IF $D(SDWLEDIT) Q
51 S ANS="" N X
52 S X=$$GET1^DIQ(2,SDWLDFN_",",.302) IF X>49 S SDWLNSC=1 Q
53 I SDSCFLD=1 Q
54SBR0 S DIR("B")="NO",DIR("A")="IS THIS APPOINTMENT FOR A SERVICE CONNECTED CONDITION? (Y OR N):",DIR(0)="Y^AO" D ^DIR S ANS=$S(Y=1:"Y",1:"N")
55 I ANS'="Y"&(ANS'="N") W !,*7,"ENTER (Y or N) PLEASE!" G SBR
56 I ANS["Y" S SDWLNSC=1
57 Q
Note: See TracBrowser for help on using the repository browser.