SDM4 ;ALB/BOK,MGD - MAKE APPOINTMENT ;NOV 12,2024
;;5.3;Scheduling;**263,273,327,394,417,496,585,665,895**;Aug 13, 1993;Build 11
;
;09/15/2002 $N FUNCTION REMOVED AND REPLACED WITH $O - IOFO - BAY PINES - TEH
;
;ICR Agreements:
;
; Reference to ^DPT(IEN,.372) in ICR #1476
; Reference to ^DIC(8) in ICR #427
; Reference to ^DIC(8.1 in ICR #2516
; Reference to ^$$ELIG^DGCOMPACTELIG in ICR #7462
;
;09/23/2005 Patch SD*5.3*417 Upper/Lower case usage.
;04/09/2007 Patch SD*5.3*496 Accept entry in file 44 without STOP CODE
;
;
TYPE ;
D SC
RAT ;Display rated service connected disabilities patch SD*5.3*394
W !!,"COMPACT Act Administrative Eligibility:"
W !," COMPACT Act: ",$$ELIG^DGCOMPACTELIG(DFN,"SDM4")
;
D 2^VADPT
W !!,"PATIENT'S SERVICE CONNECTION AND RATED DISABILITIES:"
IF $$GET1^DIQ(2,DFN_",",.301,"E")="YES"&($P(VAEL(3),"^",2)'="") D
.W !,"SC Percent: "_$P(VAEL(3),"^",2)_"%"
IF $$GET1^DIQ(2,DFN_",",.301,"E")="NO"&($P(VAEL(3),"^",2)="") D
.W !,"Service Connected: No"
;Rated Disabilities
N SDSER,SDRAT,SDPER,SDREC,NN,NUM,ANS,SDELIG,SDATD,SDSCFLG,SDVAEL S (ANS,NN,NUM)=0
F S NN=$O(^DPT(DFN,.372,NN)) Q:'NN D
.S SDREC=$G(^DPT(DFN,.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 !,"Primary Eligibility Code: "_$P(VAEL(1),"^",2)
IF $P($G(^DPT(DFN,.372,0)),"^",4)<1 W !,"No Service Connected Disabilities Listed"
W !
S SDELIG=$$GET1^DIQ(2,DFN_",",.301,"E"),SDSCFLG=0
IF SDELIG="" W !,"'SERVICE CONNECTED?' field is blank please update patient record." S SDSCFLG=1
IF $P(VAEL(1),U,2)="" W !,"'PRIMARY ELIGIBILITY CODE' field is blank please update patient record." S SDSCFLG=1
D GETMAS ;SD*585 get MAS Eligibility Code (file #8.1) for each of patient's eligibilities returns array SDVAEL
;SD*585 modified each out of sync check to use correct code from MAS Eligibility Code file (#8.1) - in array SDVAEL
IF SDELIG="NO",($P(VAEL(3),U,2)>0)!($P(SDVAEL(1),U,2)="SC LESS THAN 50%")!($P(SDVAEL(1),U,2)="SERVICE CONNECTED 50% to 100%")!($P(SDVAEL(1),U,2)="") D ;SD*585
.W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLG=1
IF SDELIG="YES",($P(VAEL(3),"^",2)<50),($P(SDVAEL(1),U,2)'="SC LESS THAN 50%") D ;SD*585
.W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLG=1
IF SDELIG="YES",($P(VAEL(3),"^",2)>49),($P(SDVAEL(1),U,2)'="SERVICE CONNECTED 50% to 100%") D ;SD*585
.W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLG=1
W !
;Ask about service connected appointment
N STOP,STOPN,SIEN S (ACT,IENACT)="" S STOP=$$GET1^DIQ(44,+SC_",",8,"I")
I +STOP>0 S STOPN=$$GET1^DIQ(40.7,+STOP_",",1),IENACT=$O(^SD(409.45,"B",STOPN,IENACT))
E W "***NO STOP CODE ASSIGNED***" S SDATD="REGULAR" D APT Q
IF IENACT'="" S SDATD=99999999999,SDATD=$O(^SD(409.45,IENACT,"E",SDATD),-1) D
.IF SDATD>0 S ACT=$P(^SD(409.45,IENACT,"E",SDATD,0),"^",2)
IF ACT=1 S SDATD=$$GET1^DIQ(44,+SC_",",2507) GOTO APT
S SDATD="",SDATD=$$GET1^DIQ(44,+SC_",",2502) IF SDATD="YES" S SDATD=$$GET1^DIQ(44,+SC_",",2507) W " ***NON-COUNT CLINIC***" GOTO APT
S SDATD="",SDATD=$$INP^SDAM2(DFN,DT) IF SDATD="I" S SDATD=$$GET1^DIQ(44,+SC_",",2507) W " ***PATIENT IS CURRENTLY AN INPATIENT***" GOTO APT
;STOP EXCEPTION CODES
S SDATD="",SDATD=$P(SDVAEL(1),U,2) ;SD*585
IF SDATD'="SC LESS THAN 50%"&(SDATD'="SERVICE CONNECTED 50% to 100%") S SDATD="" S SDATD=$S($D(SDAPTYP):SDAPTYP,$D(^SC(+SC,"AT")):$S($D(^SD(409.1,+^("AT"),0)):$P(^(0),U),1:"REGULAR"),1:"REGULAR") D
.IF SDSCFLG&(SDATD="SERVICE CONNECTED") S SDATD="REGULAR"
IF SDATD="SC LESS THAN 50%"!(SDATD="SERVICE CONNECTED 50% to 100%") D
.D SBR K SDANS,SDECANS S SDECANS=ANS ;alb/sat 665 - add SDECANS
.IF ANS="N" S SDATD=$S($D(SDAPTYP):SDAPTYP,$D(^SC(+SC,"AT")):$S($D(^SD(409.1,+^("AT"),0)):$P(^(0),U),1:"REGULAR"),1:"REGULAR")
.IF ANS="Y" D
..S ANS="" S ANS=$$GET1^DIQ(44,+SC_",",2507) IF ANS="REGULAR"!(ANS="") D
...S NN=$O(^SD(409.1,"B","SERVICE CONNECTED",NN)),SDATD=$$GET1^DIQ(409.1,NN_",",.01)
..IF ANS'="REGULAR"&(ANS'="") S SDATD=ANS
APT W !,"APPOINTMENT TYPE: "_SDATD_"//" R X:DTIME I X']"" S X=SDATD
I X["^" W !,"APPOINTMENT TYPE IS REQUIRED" G APT
I X="S" W !,"PLEASE ENTER MORE THAN ONE CHARACTER" G APT
I SDSCFLG D
.S DIC("S")="I $D(X),$E(X,1,2)'[""SE"""
.S DIC(0)="QEMNZ",DIC=409.1 D ^DIC I Y<0 Q
.S SDSCFLG=0
G APT:SDSCFLG
S SDEC=$S($D(^DIC(8,+VAEL(1),0)):$P(^(0),U,5),1:"")
S DIC("S")="I '$P(^(0),U,3),$S(SDEC[""Y"":1,1:$P(^(0),U,5)),$S('$P(^(0),U,6):1,$D(VAEL(1,+$P(^(0),U,6))):1,+VAEL(1)=$P(^(0),U,6):1,1:0)",DIC="^SD(409.1,",DIC(0)="EQMZ" D ^DIC K DIC
I X["^"!(Y'>0) W !,"Appointment type is required",!,"Patient must have the eligibility code EMPLOYEE, COLLATERAL or SHARING AGREEMENT",!,"to choose those types of appointments." G TYPE
S COLLAT=$S(+Y=1:1,+Y=7:7,1:0),SDAPTYP=+Y,SDDECOD=$P(^SD(409.1,+Y,0),U,6) I COLLAT W !!,"** Note - You are making a ",$P(^SD(409.1,+COLLAT,0),U)," appt.",!
Q:$D(SDAMBAE)
I COLLAT=7 S SDCOL=$P(^SD(409.1,SDAPTYP,0),U,6) I '$D(SDMLT)&'$D(SDD) D ^SDM0,END^SDM
Q
ELIG S SDALLE="",SDEMP=$P(VAEL(1),U,2) W !,"THIS PATIENT HAS OTHER ENTITLED ELIGIBILITIES:" F SDOEL=0:0 S SDOEL=$O(VAEL(1,SDOEL)) Q:SDOEL="" W !?5,$P(VAEL(1,SDOEL),U,2) S SDALLE=SDALLE_"^"_$P(VAEL(1,SDOEL),U,2)
1 W !,"ENTER THE ELIGIBILITY FOR THIS APPOINTMENT: "_SDEMP_"// " R X:DTIME Q:"^"[X S X=$$UPPER^VALM1(X) G ELIG:X["?",1:SDALLE'[("^"_X)
S SDEMP=X_$P($P(SDALLE,"^"_X,2),"^") W $P($P(SDALLE,"^"_X,2),"^")
F SDOEL=0:0 S SDOEL=$O(VAEL(1,SDOEL)) Q:SDOEL="" I $P(VAEL(1,SDOEL),U,2)=SDEMP S SDEMP=SDOEL_"^"_SDEMP Q
Q
SC ;SERVICE CONNECTED MESSAGE/IOFO - BAY PINES/TEH
I $D(^DPT(DFN,.3)) S SDAMSCN=+$P(^(.3),U,2) I SDAMSCN>49 D
.W !,?7,"********** THIS PATIENT IS 50% OR GREATER SERVICE-CONNECTED **********",!
;I $D(SDWLLIST),SDWLLIST D ^SDWLR ;Patch SD*5.3*327
Q
;
GETMAS ;SD*585 get MAS Eligibility Code (file #8.1) for each of patient's
;eligibilities passed back from Registration API VADPT in array VAEL.
;Returns array SDVAEL.
S SDVAEL(1)=""
Q:'+$G(VAEL(1))
Q:'$D(^DIC(8,+VAEL(1),0))
S MASIEN=0,MASIEN=$P(^DIC(8,+VAEL(1),0),U,9) ;pointer to file #8.1
Q:'MASIEN
Q:'$D(^DIC(8.1,MASIEN,0))
S SDVAEL(1)=MASIEN_"^"_$P(^DIC(8.1,MASIEN,0),U,1) ;primary eligibility
;check for additional eligibilities
S CT=0
F S CT=$O(VAEL(1,CT)) Q:'CT D
.Q:'$D(^DIC(8,+VAEL(1,CT),0))
.S MASIEN=0,MASIEN=$P(^DIC(8,+VAEL(1,CT),0),U,9) ;pointer to file #8.1
.Q:'MASIEN
.Q:'$D(^DIC(8.1,MASIEN,0))
.S SDVAEL(1,MASIEN)=MASIEN_"^"_$P(^DIC(8.1,MASIEN,0),U,1)
K CT,MASIEN
Q
;
SBR S (ANS,SDANS)=""
IF SDSCFLG S ANS="N" Q
IF $D(^DPT(DFN,.3)) S SDANS=$$GET1^DIQ(2,DFN_",",.302) IF SDANS>49 S ANS="Y" Q
S DIR("A")="IS THIS APPOINTMENT FOR A SERVICE CONNECTED CONDITION",DIR(0)="Y^A0" D ^DIR S ANS=$S(Y=1:"Y",1:"N")
I ANS'="Y"&(ANS'="N") W !,*7,"ENTER (Y or N) PLEASE!" G SBR
K DIR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDM4 7283 printed Sep 23, 2025@20:35:22 Page 2
SDM4 ;ALB/BOK,MGD - MAKE APPOINTMENT ;NOV 12,2024
+1 ;;5.3;Scheduling;**263,273,327,394,417,496,585,665,895**;Aug 13, 1993;Build 11
+2 ;
+3 ;09/15/2002 $N FUNCTION REMOVED AND REPLACED WITH $O - IOFO - BAY PINES - TEH
+4 ;
+5 ;ICR Agreements:
+6 ;
+7 ; Reference to ^DPT(IEN,.372) in ICR #1476
+8 ; Reference to ^DIC(8) in ICR #427
+9 ; Reference to ^DIC(8.1 in ICR #2516
+10 ; Reference to ^$$ELIG^DGCOMPACTELIG in ICR #7462
+11 ;
+12 ;09/23/2005 Patch SD*5.3*417 Upper/Lower case usage.
+13 ;04/09/2007 Patch SD*5.3*496 Accept entry in file 44 without STOP CODE
+14 ;
+15 ;
TYPE ;
+1 DO SC
RAT ;Display rated service connected disabilities patch SD*5.3*394
+1 WRITE !!,"COMPACT Act Administrative Eligibility:"
+2 WRITE !," COMPACT Act: ",$$ELIG^DGCOMPACTELIG(DFN,"SDM4")
+3 ;
+4 DO 2^VADPT
+5 WRITE !!,"PATIENT'S SERVICE CONNECTION AND RATED DISABILITIES:"
+6 IF $$GET1^DIQ(2,DFN_",",.301,"E")="YES"&($PIECE(VAEL(3),"^",2)'="")
Begin DoDot:1
+7 WRITE !,"SC Percent: "_$PIECE(VAEL(3),"^",2)_"%"
End DoDot:1
+8 IF $$GET1^DIQ(2,DFN_",",.301,"E")="NO"&($PIECE(VAEL(3),"^",2)="")
Begin DoDot:1
+9 WRITE !,"Service Connected: No"
End DoDot:1
+10 ;Rated Disabilities
+11 NEW SDSER,SDRAT,SDPER,SDREC,NN,NUM,ANS,SDELIG,SDATD,SDSCFLG,SDVAEL
SET (ANS,NN,NUM)=0
+12 FOR
SET NN=$ORDER(^DPT(DFN,.372,NN))
if 'NN
QUIT
Begin DoDot:1
+13 SET SDREC=$GET(^DPT(DFN,.372,NN,0))
IF SDREC'=""
Begin DoDot:2
+14 SET SDRAT=""
SET NUM=$PIECE($GET(SDREC),"^",1)
IF NUM>0
SET SDRAT=$$GET1^DIQ(31,NUM_",",.01)
+15 SET SDSER=""
SET SDSER=$SELECT($PIECE(SDREC,"^",3)="1":"SC",1:"NSC")
+16 WRITE !," "_SDRAT_" ("_SDSER_" - "_$PIECE(SDREC,"^",2)_"%)"
+17 QUIT
End DoDot:2
End DoDot:1
+18 WRITE !,"Primary Eligibility Code: "_$PIECE(VAEL(1),"^",2)
+19 IF $PIECE($GET(^DPT(DFN,.372,0)),"^",4)<1
WRITE !,"No Service Connected Disabilities Listed"
+20 WRITE !
+21 SET SDELIG=$$GET1^DIQ(2,DFN_",",.301,"E")
SET SDSCFLG=0
+22 IF SDELIG=""
WRITE !,"'SERVICE CONNECTED?' field is blank please update patient record."
SET SDSCFLG=1
+23 IF $PIECE(VAEL(1),U,2)=""
WRITE !,"'PRIMARY ELIGIBILITY CODE' field is blank please update patient record."
SET SDSCFLG=1
+24 ;SD*585 get MAS Eligibility Code (file #8.1) for each of patient's eligibilities returns array SDVAEL
DO GETMAS
+25 ;SD*585 modified each out of sync check to use correct code from MAS Eligibility Code file (#8.1) - in array SDVAEL
+26 ;SD*585
IF SDELIG="NO"
IF ($PIECE(VAEL(3),U,2)>0)!($PIECE(SDVAEL(1),U,2)="SC LESS THAN 50%")!($PIECE(SDVAEL(1),U,2)="SERVICE CONNECTED 50% to 100%")!($PIECE(SDVAEL(1),U,2)="")
Begin DoDot:1
+27 WRITE !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem."
SET SDSCFLG=1
End DoDot:1
+28 ;SD*585
IF SDELIG="YES"
IF ($PIECE(VAEL(3),"^",2)<50)
IF ($PIECE(SDVAEL(1),U,2)'="SC LESS THAN 50%")
Begin DoDot:1
+29 WRITE !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem."
SET SDSCFLG=1
End DoDot:1
+30 ;SD*585
IF SDELIG="YES"
IF ($PIECE(VAEL(3),"^",2)>49)
IF ($PIECE(SDVAEL(1),U,2)'="SERVICE CONNECTED 50% to 100%")
Begin DoDot:1
+31 WRITE !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem."
SET SDSCFLG=1
End DoDot:1
+32 WRITE !
+33 ;Ask about service connected appointment
+34 NEW STOP,STOPN,SIEN
SET (ACT,IENACT)=""
SET STOP=$$GET1^DIQ(44,+SC_",",8,"I")
+35 IF +STOP>0
SET STOPN=$$GET1^DIQ(40.7,+STOP_",",1)
SET IENACT=$ORDER(^SD(409.45,"B",STOPN,IENACT))
+36 IF '$TEST
WRITE "***NO STOP CODE ASSIGNED***"
SET SDATD="REGULAR"
DO APT
QUIT
+37 IF IENACT'=""
SET SDATD=99999999999
SET SDATD=$ORDER(^SD(409.45,IENACT,"E",SDATD),-1)
Begin DoDot:1
+38 IF SDATD>0
SET ACT=$PIECE(^SD(409.45,IENACT,"E",SDATD,0),"^",2)
End DoDot:1
+39 IF ACT=1
SET SDATD=$$GET1^DIQ(44,+SC_",",2507)
GOTO APT
+40 SET SDATD=""
SET SDATD=$$GET1^DIQ(44,+SC_",",2502)
IF SDATD="YES"
SET SDATD=$$GET1^DIQ(44,+SC_",",2507)
WRITE " ***NON-COUNT CLINIC***"
GOTO APT
+41 SET SDATD=""
SET SDATD=$$INP^SDAM2(DFN,DT)
IF SDATD="I"
SET SDATD=$$GET1^DIQ(44,+SC_",",2507)
WRITE " ***PATIENT IS CURRENTLY AN INPATIENT***"
GOTO APT
+42 ;STOP EXCEPTION CODES
+43 ;SD*585
SET SDATD=""
SET SDATD=$PIECE(SDVAEL(1),U,2)
+44 IF SDATD'="SC LESS THAN 50%"&(SDATD'="SERVICE CONNECTED 50% to 100%")
SET SDATD=""
SET SDATD=$SELECT($DATA(SDAPTYP):SDAPTYP,$DATA(^SC(+SC,"AT")):$SELECT($DATA(^SD(409.1,+^("AT"),0)):$PIECE(^(0),U),1:"REGULAR"),1:"REGULAR")
Begin DoDot:1
+45 IF SDSCFLG&(SDATD="SERVICE CONNECTED")
SET SDATD="REGULAR"
End DoDot:1
+46 IF SDATD="SC LESS THAN 50%"!(SDATD="SERVICE CONNECTED 50% to 100%")
Begin DoDot:1
+47 ;alb/sat 665 - add SDECANS
DO SBR
KILL SDANS,SDECANS
SET SDECANS=ANS
+48 IF ANS="N"
SET SDATD=$SELECT($DATA(SDAPTYP):SDAPTYP,$DATA(^SC(+SC,"AT")):$SELECT($DATA(^SD(409.1,+^("AT"),0)):$PIECE(^(0),U),1:"REGULAR"),1:"REGULAR")
+49 IF ANS="Y"
Begin DoDot:2
+50 SET ANS=""
SET ANS=$$GET1^DIQ(44,+SC_",",2507)
IF ANS="REGULAR"!(ANS="")
Begin DoDot:3
+51 SET NN=$ORDER(^SD(409.1,"B","SERVICE CONNECTED",NN))
SET SDATD=$$GET1^DIQ(409.1,NN_",",.01)
End DoDot:3
+52 IF ANS'="REGULAR"&(ANS'="")
SET SDATD=ANS
End DoDot:2
End DoDot:1
APT WRITE !,"APPOINTMENT TYPE: "_SDATD_"//"
READ X:DTIME
IF X']""
SET X=SDATD
+1 IF X["^"
WRITE !,"APPOINTMENT TYPE IS REQUIRED"
GOTO APT
+2 IF X="S"
WRITE !,"PLEASE ENTER MORE THAN ONE CHARACTER"
GOTO APT
+3 IF SDSCFLG
Begin DoDot:1
+4 SET DIC("S")="I $D(X),$E(X,1,2)'[""SE"""
+5 SET DIC(0)="QEMNZ"
SET DIC=409.1
DO ^DIC
IF Y<0
QUIT
+6 SET SDSCFLG=0
End DoDot:1
+7 if SDSCFLG
GOTO APT
+8 SET SDEC=$SELECT($DATA(^DIC(8,+VAEL(1),0)):$PIECE(^(0),U,5),1:"")
+9 SET DIC("S")="I '$P(^(0),U,3),$S(SDEC[""Y"":1,1:$P(^(0),U,5)),$S('$P(^(0),U,6):1,$D(VAEL(1,+$P(^(0),U,6))):1,+VAEL(1)=$P(^(0),U,6):1,1:0)"
SET DIC="^SD(409.1,"
SET DIC(0)="EQMZ"
DO ^DIC
KILL DIC
+10 IF X["^"!(Y'>0)
WRITE !,"Appointment type is required",!,"Patient must have the eligibility code EMPLOYEE, COLLATERAL or SHARING AGREEMENT",!,"to choose those types of appointments."
GOTO TYPE
+11 SET COLLAT=$SELECT(+Y=1:1,+Y=7:7,1:0)
SET SDAPTYP=+Y
SET SDDECOD=$PIECE(^SD(409.1,+Y,0),U,6)
IF COLLAT
WRITE !!,"** Note - You are making a ",$PIECE(^SD(409.1,+COLLAT,0),U)," appt.",!
+12 if $DATA(SDAMBAE)
QUIT
+13 IF COLLAT=7
SET SDCOL=$PIECE(^SD(409.1,SDAPTYP,0),U,6)
IF '$DATA(SDMLT)&'$DATA(SDD)
DO ^SDM0
DO END^SDM
+14 QUIT
ELIG SET SDALLE=""
SET SDEMP=$PIECE(VAEL(1),U,2)
WRITE !,"THIS PATIENT HAS OTHER ENTITLED ELIGIBILITIES:"
FOR SDOEL=0:0
SET SDOEL=$ORDER(VAEL(1,SDOEL))
if SDOEL=""
QUIT
WRITE !?5,$PIECE(VAEL(1,SDOEL),U,2)
SET SDALLE=SDALLE_"^"_$PIECE(VAEL(1,SDOEL),U,2)
1 WRITE !,"ENTER THE ELIGIBILITY FOR THIS APPOINTMENT: "_SDEMP_"// "
READ X:DTIME
if "^"[X
QUIT
SET X=$$UPPER^VALM1(X)
if X["?"
GOTO ELIG
if SDALLE'[("^"_X)
GOTO 1
+1 SET SDEMP=X_$PIECE($PIECE(SDALLE,"^"_X,2),"^")
WRITE $PIECE($PIECE(SDALLE,"^"_X,2),"^")
+2 FOR SDOEL=0:0
SET SDOEL=$ORDER(VAEL(1,SDOEL))
if SDOEL=""
QUIT
IF $PIECE(VAEL(1,SDOEL),U,2)=SDEMP
SET SDEMP=SDOEL_"^"_SDEMP
QUIT
+3 QUIT
SC ;SERVICE CONNECTED MESSAGE/IOFO - BAY PINES/TEH
+1 IF $DATA(^DPT(DFN,.3))
SET SDAMSCN=+$PIECE(^(.3),U,2)
IF SDAMSCN>49
Begin DoDot:1
+2 WRITE !,?7,"********** THIS PATIENT IS 50% OR GREATER SERVICE-CONNECTED **********",!
End DoDot:1
+3 ;I $D(SDWLLIST),SDWLLIST D ^SDWLR ;Patch SD*5.3*327
+4 QUIT
+5 ;
GETMAS ;SD*585 get MAS Eligibility Code (file #8.1) for each of patient's
+1 ;eligibilities passed back from Registration API VADPT in array VAEL.
+2 ;Returns array SDVAEL.
+3 SET SDVAEL(1)=""
+4 if '+$GET(VAEL(1))
QUIT
+5 if '$DATA(^DIC(8,+VAEL(1),0))
QUIT
+6 ;pointer to file #8.1
SET MASIEN=0
SET MASIEN=$PIECE(^DIC(8,+VAEL(1),0),U,9)
+7 if 'MASIEN
QUIT
+8 if '$DATA(^DIC(8.1,MASIEN,0))
QUIT
+9 ;primary eligibility
SET SDVAEL(1)=MASIEN_"^"_$PIECE(^DIC(8.1,MASIEN,0),U,1)
+10 ;check for additional eligibilities
+11 SET CT=0
+12 FOR
SET CT=$ORDER(VAEL(1,CT))
if 'CT
QUIT
Begin DoDot:1
+13 if '$DATA(^DIC(8,+VAEL(1,CT),0))
QUIT
+14 ;pointer to file #8.1
SET MASIEN=0
SET MASIEN=$PIECE(^DIC(8,+VAEL(1,CT),0),U,9)
+15 if 'MASIEN
QUIT
+16 if '$DATA(^DIC(8.1,MASIEN,0))
QUIT
+17 SET SDVAEL(1,MASIEN)=MASIEN_"^"_$PIECE(^DIC(8.1,MASIEN,0),U,1)
End DoDot:1
+18 KILL CT,MASIEN
+19 QUIT
+20 ;
SBR SET (ANS,SDANS)=""
+1 IF SDSCFLG
SET ANS="N"
QUIT
+2 IF $DATA(^DPT(DFN,.3))
SET SDANS=$$GET1^DIQ(2,DFN_",",.302)
IF SDANS>49
SET ANS="Y"
QUIT
+3 SET DIR("A")="IS THIS APPOINTMENT FOR A SERVICE CONNECTED CONDITION"
SET DIR(0)="Y^A0"
DO ^DIR
SET ANS=$SELECT(Y=1:"Y",1:"N")
+4 IF ANS'="Y"&(ANS'="N")
WRITE !,*7,"ENTER (Y or N) PLEASE!"
GOTO SBR
+5 KILL DIR
QUIT
