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

SDM4.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;09/15/2002 $N FUNCTION REMOVED AND REPLACED WITH $O - IOFO - BAY PINES - TEH
  1. ;
  1. ;ICR Agreements:
  1. ;
  1. ; Reference to ^DPT(IEN,.372) in ICR #1476
  1. ; Reference to ^DIC(8) in ICR #427
  1. ; Reference to ^DIC(8.1 in ICR #2516
  1. ; Reference to ^$$ELIG^DGCOMPACTELIG in ICR #7462
  1. ;
  1. ;09/23/2005 Patch SD*5.3*417 Upper/Lower case usage.
  1. ;04/09/2007 Patch SD*5.3*496 Accept entry in file 44 without STOP CODE
  1. ;
  1. ;
  1. TYPE ;
  1. D SC
  1. RAT ;Display rated service connected disabilities patch SD*5.3*394
  1. W !!,"COMPACT Act Administrative Eligibility:"
  1. W !," COMPACT Act: ",$$ELIG^DGCOMPACTELIG(DFN,"SDM4")
  1. ;
  1. D 2^VADPT
  1. W !!,"PATIENT'S SERVICE CONNECTION AND RATED DISABILITIES:"
  1. IF $$GET1^DIQ(2,DFN_",",.301,"E")="YES"&($P(VAEL(3),"^",2)'="") D
  1. .W !,"SC Percent: "_$P(VAEL(3),"^",2)_"%"
  1. IF $$GET1^DIQ(2,DFN_",",.301,"E")="NO"&($P(VAEL(3),"^",2)="") D
  1. .W !,"Service Connected: No"
  1. ;Rated Disabilities
  1. N SDSER,SDRAT,SDPER,SDREC,NN,NUM,ANS,SDELIG,SDATD,SDSCFLG,SDVAEL S (ANS,NN,NUM)=0
  1. F S NN=$O(^DPT(DFN,.372,NN)) Q:'NN D
  1. .S SDREC=$G(^DPT(DFN,.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 !,"Primary Eligibility Code: "_$P(VAEL(1),"^",2)
  1. IF $P($G(^DPT(DFN,.372,0)),"^",4)<1 W !,"No Service Connected Disabilities Listed"
  1. W !
  1. S SDELIG=$$GET1^DIQ(2,DFN_",",.301,"E"),SDSCFLG=0
  1. IF SDELIG="" W !,"'SERVICE CONNECTED?' field is blank please update patient record." S SDSCFLG=1
  1. IF $P(VAEL(1),U,2)="" W !,"'PRIMARY ELIGIBILITY CODE' field is blank please update patient record." S SDSCFLG=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 MAS Eligibility Code file (#8.1) - in array SDVAEL
  1. 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
  1. .W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLG=1
  1. IF SDELIG="YES",($P(VAEL(3),"^",2)<50),($P(SDVAEL(1),U,2)'="SC LESS THAN 50%") D ;SD*585
  1. .W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLG=1
  1. IF SDELIG="YES",($P(VAEL(3),"^",2)>49),($P(SDVAEL(1),U,2)'="SERVICE CONNECTED 50% to 100%") D ;SD*585
  1. .W !,"The 'SC Percent','Service Connected' and 'Primary Eligibility Codes' are OUT OF SYNC, Please CORRECT the problem." S SDSCFLG=1
  1. W !
  1. ;Ask about service connected appointment
  1. N STOP,STOPN,SIEN S (ACT,IENACT)="" S STOP=$$GET1^DIQ(44,+SC_",",8,"I")
  1. I +STOP>0 S STOPN=$$GET1^DIQ(40.7,+STOP_",",1),IENACT=$O(^SD(409.45,"B",STOPN,IENACT))
  1. E W "***NO STOP CODE ASSIGNED***" S SDATD="REGULAR" D APT Q
  1. IF IENACT'="" S SDATD=99999999999,SDATD=$O(^SD(409.45,IENACT,"E",SDATD),-1) D
  1. .IF SDATD>0 S ACT=$P(^SD(409.45,IENACT,"E",SDATD,0),"^",2)
  1. IF ACT=1 S SDATD=$$GET1^DIQ(44,+SC_",",2507) GOTO APT
  1. S SDATD="",SDATD=$$GET1^DIQ(44,+SC_",",2502) IF SDATD="YES" S SDATD=$$GET1^DIQ(44,+SC_",",2507) W " ***NON-COUNT CLINIC***" GOTO APT
  1. 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
  1. ;STOP EXCEPTION CODES
  1. S SDATD="",SDATD=$P(SDVAEL(1),U,2) ;SD*585
  1. 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
  1. .IF SDSCFLG&(SDATD="SERVICE CONNECTED") S SDATD="REGULAR"
  1. IF SDATD="SC LESS THAN 50%"!(SDATD="SERVICE CONNECTED 50% to 100%") D
  1. .D SBR K SDANS,SDECANS S SDECANS=ANS ;alb/sat 665 - add SDECANS
  1. .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")
  1. .IF ANS="Y" D
  1. ..S ANS="" S ANS=$$GET1^DIQ(44,+SC_",",2507) IF ANS="REGULAR"!(ANS="") D
  1. ...S NN=$O(^SD(409.1,"B","SERVICE CONNECTED",NN)),SDATD=$$GET1^DIQ(409.1,NN_",",.01)
  1. ..IF ANS'="REGULAR"&(ANS'="") S SDATD=ANS
  1. APT W !,"APPOINTMENT TYPE: "_SDATD_"//" R X:DTIME I X']"" S X=SDATD
  1. I X["^" W !,"APPOINTMENT TYPE IS REQUIRED" G APT
  1. I X="S" W !,"PLEASE ENTER MORE THAN ONE CHARACTER" G APT
  1. I SDSCFLG D
  1. .S DIC("S")="I $D(X),$E(X,1,2)'[""SE"""
  1. .S DIC(0)="QEMNZ",DIC=409.1 D ^DIC I Y<0 Q
  1. .S SDSCFLG=0
  1. G APT:SDSCFLG
  1. S SDEC=$S($D(^DIC(8,+VAEL(1),0)):$P(^(0),U,5),1:"")
  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
  1. 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
  1. 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.",!
  1. Q:$D(SDAMBAE)
  1. I COLLAT=7 S SDCOL=$P(^SD(409.1,SDAPTYP,0),U,6) I '$D(SDMLT)&'$D(SDD) D ^SDM0,END^SDM
  1. Q
  1. 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. 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)
  1. S SDEMP=X_$P($P(SDALLE,"^"_X,2),"^") W $P($P(SDALLE,"^"_X,2),"^")
  1. 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
  1. Q
  1. SC ;SERVICE CONNECTED MESSAGE/IOFO - BAY PINES/TEH
  1. I $D(^DPT(DFN,.3)) S SDAMSCN=+$P(^(.3),U,2) I SDAMSCN>49 D
  1. .W !,?7,"********** THIS PATIENT IS 50% OR GREATER SERVICE-CONNECTED **********",!
  1. ;I $D(SDWLLIST),SDWLLIST D ^SDWLR ;Patch SD*5.3*327
  1. Q
  1. ;
  1. 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.
  1. ;Returns 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
  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)
  1. K CT,MASIEN
  1. Q
  1. ;
  1. SBR S (ANS,SDANS)=""
  1. IF SDSCFLG S ANS="N" Q
  1. IF $D(^DPT(DFN,.3)) S SDANS=$$GET1^DIQ(2,DFN_",",.302) IF SDANS>49 S ANS="Y" Q
  1. 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")
  1. I ANS'="Y"&(ANS'="N") W !,*7,"ENTER (Y or N) PLEASE!" G SBR
  1. K DIR Q