- 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
