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