- 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 Feb 19, 2025@00:25:03 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