Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDWLSC

SDWLSC.m

Go to the documentation of this file. 
  1. SDWLSC ;IOFO BAY PINES/DMR - WAITING LIST-RATED DISABILITY ;09/02/2004 2:10 PM
  1.  ;;5.3;Scheduling;**394,417,585**;AUG 13, 1993;Build 19
  1.  ;
  1.  ;
  1.  ;***********************************************************************************************************
  1.  ;                                       CHANGE LOG
  1.  ;                                                                                               
  1.  ;       DATE           PATCH           DESCRIPTION
  1.  ;       ----           -----           -----------
  1.  ;       12/09/2005     SD*5.3*394      New Routine for SC disabilities prompt                                                                                          
  1.  ;
  1.  ;ICR Agreements:
  1.  ;
  1.  ;ICR - 1476 For reference to ^DPT(IEN,.372)
  1.  ;ICR - 10061 For reference to 2^VADPT
  1.  ;ICR - 2056 For reference to $$GET1^DIQ
  1.  ;ICR - 427  For reference to ^DIC(8)
  1.  ;ICR - 2516 For reference to ^DIC(8.1 - SD*585
  1.  ;
  1.  ;Variable: SDWLNSC killed in routine SDWLE113 - Routine SDWLSC called from SDWLE111.
  1.  ;          SDWLDFN NOT killed - referenced only.
  1.  ;
  1.  ;09/23/2006 Patch SD*5.3*417 Upper/Lower case usage.
  1.  ;
  1.  D 2^VADPT S SDWLNSC=0
  1.  Q:'$D(SDWLDFN)
  1.  Q:$$GET1^DIQ(2,SDWLDFN_",",.301,"E")'="YES"
  1.  Q:$P(VAEL(1),"^",2)'["50%"
  1.  S SDWLNSC=$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2)
  1.  W !!,"PATIENT'S SERVICE CONNECTION AND RATED DISABILITIES:"
  1.  IF $D(^DPT(SDWLDFN,.3)) D
  1.  .W !,$S($P($G(^DPT(SDWLDFN,.3)),"^",1)="Y":"SC Percent: "_$P(^(.3),"^",2)_"%",1:"Service Connected: No")
  1.  .W !,"Primary Eligibility Code: "_$P(VAEL(1),"^",2)
  1.  ;Rated Disabilities
  1.  N SDSER,SDRAT,SDPER,SDREC,NN,NUM,ANS S (NN,NUM)=0
  1.  F  S NN=$O(^DPT(SDWLDFN,.372,NN)) Q:'NN  D
  1.  .S SDREC=$G(^DPT(SDWLDFN,.372,NN,0)) IF SDREC'="" D
  1.  ..S SDRAT="" S NUM=$P($G(SDREC),"^",1) IF NUM>0 S SDRAT=$$GET1^DIQ(31,NUM_",",.01)
  1.  ..S SDSER="" S SDSER=$S($P(SDREC,"^",3)="1":"SC",1:"NSC")
  1.  ..W !,"    "_SDRAT_"  ("_SDSER_" - "_$P(SDREC,"^",2)_"%)"
  1.  ..Q
  1.  W !
  1.  N SDSCFLD,SDELIG S SDSCFLD=0
  1.  S SDELIG=$$GET1^DIQ(2,SDWLDFN_",",.301,"E")
  1.  IF $P(VAEL(1),U,2)="" W !,"'PRIMARY ELIGIBILITY CODE' field is blank please update patient record." S SDSCFLD=1
  1.  D GETMAS  ;SD*585 get MAS Eligibility Code (file #8.1) for each of patient's eligibilities - returns array SDVAEL
  1.  ;SD*585 modified each out of sync check to use correct code from file 8.1 from array SDVAEL
  1.  I SDELIG="YES",($P(VAEL(3),U,2)<50),($P(SDVAEL(1),U,2))'="SC LESS THAN 50%" D
  1.  .W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLD=1
  1.  I SDELIG="YES",($P(VAEL(3),U,2)>49),($P(SDVAEL(1),U,2))'="SERVICE CONNECTED 50% to 100%" D
  1.  .W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLD=1
  1.  IF $P($G(^DPT(SDWLDFN,.372,0)),"^",4)<1 W !,"NO SERVICE CONNECTED DISABILITIES LISTED" W !
  1.  D SBR
  1.  K SDSCFLD,SDVAEL Q
  1. SBR IF $D(SDWLEDIT) Q
  1.  S ANS="" N X
  1.  S X=$$GET1^DIQ(2,SDWLDFN_",",.302) IF X>49 S SDWLNSC=1 Q
  1.  I SDSCFLD=1 Q
  1. 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")
  1.  I ANS'="Y"&(ANS'="N") W !,*7,"ENTER (Y or N) PLEASE!" G SBR
  1.  I ANS["Y" S SDWLNSC=1
  1.  Q
  1.  ;
  1. GETMAS ;SD*585 get MAS Eligibility Code (file #8.1) for each of patient's
  1.  ;eligibilities that is passed back from Registration API VADPT in
  1.  ;local array VAEL.
  1.  ;Pass back new array SDVAEL
  1.  S SDVAEL(1)=""
  1.  Q:'+$G(VAEL(1))
  1.  Q:'$D(^DIC(8,+VAEL(1),0))
  1.  S MASIEN=0,MASIEN=$P(^DIC(8,+VAEL(1),0),U,9)  ;pointer to file #8.1
  1.  Q:'MASIEN
  1.  Q:'$D(^DIC(8.1,MASIEN,0))
  1.  S SDVAEL(1)=MASIEN_"^"_$P(^DIC(8.1,MASIEN,0),U,1)  ;primary eligibility
  1.  ;check for additional eligibilities in VAEL
  1.  S CT=0
  1.  F  S CT=$O(VAEL(1,CT)) Q:'CT  D
  1.  .Q:'$D(^DIC(8,+VAEL(1,CT),0))
  1.  .S MASIEN=0,MASIEN=$P(^DIC(8,+VAEL(1,CT),0),U,9)  ;pointer to file #8.1
  1.  .Q:'MASIEN
  1.  .Q:'$D(^DIC(8.1,MASIEN,0))
  1.  .S SDVAEL(1,MASIEN)=MASIEN_"^"_$P(^DIC(8.1,MASIEN,0),U,1)  ;additional eligibilities
  1.  K MASIEN,CT
  1.  Q