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

SDESMISSIONELG.m

Go to the documentation of this file.
SDESMISSIONELG ;ALB/ANU,MGD,LAB,BWF/BLB,JAS,LAB - VISTA SCHEDULING RPCS GET MISSION ELIGIBILITY ; NOV 3,2023
 ;;5.3;Scheduling;**814,815,818,820,826,835,842,844,845,846,864**;Aug 13, 1993;Build 15
 ;;Per VHA Directive 6402, this routine should not be modified
 ;
 ;External References
 ;-------------------
 ; Reference to $$GETS^DIQ,$$GETS1^DIQ in ICR #2056
 ; Reference to ^%DT in ICR #10003
 ; Reference to $$FIND1^DIC in ICR #2051
 ;
 ; Global References Supported
 ; ----------------- ----------------- ----------
 ; ^TMP($J SACC 2.3.2.5.1
 ;
 Q
GETMISSIONFEDT(ELGRETURN,FILEENTRYDATE,PID,APPTDATE,SDCLNIEN,SDEAS) ; Get Mission Eligibility
 S FILEENTRYDATE=$P($G(FILEENTRYDATE),"T"),PID=$G(PID,"T"),APPTDATE=$G(APPTDATE,"T"),SDCLNIEN=$G(SDCLNIEN),SDEAS=$G(SDEAS)
 D GETMISSIONELG(.ELGRETURN,"",PID,"",SDEAS,APPTDATE,SDCLNIEN,FILEENTRYDATE)
 Q
 ;
GETMISSIONELG(ELGRETURN,APPTREQIEN,PID,APPTREQTYP,SDEAS,APPTDATE,SDCLNIEN,FILEENTRYDATE) ; Get Mission Eligibility
 ; This RPC gets User name, Keys and Scheduling Options for a given User.
 ; Input:
 ; ELGRETURN  - [required] - Success or Error message
 ; APPTREQIEN - [required if file entry date not sent] - The IEN
 ; APPTREQTYP - [required if file entry date not sent] - APPOINTMENT REQUEST type
 ; PID        - [required] - Patient Indicated Date
 ; SDEAS      - [optional] - Enterprise Appointment Scheduling (EAS) Tracking Number associated to an appointment.
 ; APPTDATE   - [required] - Date appointment is being made
 ; SDCLNIEN   - [required] - Clinic IEN
 ; FILEENTRYDATE - [required if APPTREQIEN and APPTREQTYP not sent] - the date the request was entered
 ;
 ;
 N HASVLDERRORS,RETURN,HASFIELDS,ELGFIELDSARRAY,REQDATE,REQENDDT,SDAPPTAVAIL,VLDERRORS,SDSTOPCD,SDSERVICE
 N SDPRIM,SDSTOPCDIEN,SDI,REQDATENET,REQENDDTNET,APPTRETURN,NUMBER
 N SDCLRESIEN,PIDDATE
 N SDSTOPCDTYPE
 S APPTREQIEN=$G(APPTREQIEN),PID=$G(PID),APPTREQTYP=$G(APPTREQTYP),SDEAS=$G(SDEAS),APPTDATE=$G(APPTDATE),SDCLNIEN=$G(SDCLNIEN),FILEENTRYDATE=$G(FILEENTRYDATE)
 S (RETURN,VLDERRORS,ELGFIELDSARRAY,HASFIELDS,SDSTOPCDTYPE)=""
 ;
 S NUMBER=10
 S HASVLDERRORS=$$VALIDATE(.VLDERRORS,APPTREQIEN,PID,APPTREQTYP,SDEAS,.SDAPPTAVAIL,.APPTDATE,.APPTRETURN,SDCLNIEN,.NUMBER,$G(FILEENTRYDATE))
 I HASVLDERRORS M RETURN=VLDERRORS
 I 'HASVLDERRORS S HASFIELDS=$$GETMSNELG(.ELGFIELDSARRAY,REQDATE,REQENDDT,PIDDATE,.SDAPPTAVAIL,APPTDATE,SDCLNIEN)
 I HASFIELDS M RETURN=ELGFIELDSARRAY
 I $D(APPTRETURN) M RETURN=APPTRETURN
 ;
 D BUILDJSON(.ELGRETURN,.RETURN)
 D CLEANUP
 Q
 ;
VALIDATE(ERRORS,APPTREQIEN,PID,APPTREQTYP,SDEAS,SDAPPTAVAIL,APPTDATE,APPTRETURN,SDCLNIEN,NUMBER,FILEENTRYDATE) ; Validate Appointment Request IEN, Request Date, PID Date
 N ERRORFLAG,SDP1,SDP2,SDP3,SDP4,SDSTRTDT,SDENDDT,SDSLOTS,SDSTOPTM,SDSTRTTM,SDTOTAL,II,SDCLNAME,SDERR,CNT,CRSTCODEIEN,CRSTCODE,CLINLIST,SDTMPARY,FEDATEFM
 S (SDAPPTAVAIL,SDSERVICE)=""
 ;
 ; Appointment Request IEN
 I APPTREQIEN="",$G(FILEENTRYDATE)="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,3) Q $D(ERRORFLAG)
 ;
 ; Appointment Request Type
 I $G(FILEENTRYDATE)'="" D
 .S FEDATEFM=$$ISOTFM^SDAMUTDT(FILEENTRYDATE)
 .I FEDATEFM<1 S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,434)
 I $G(ERRORFLAG) Q $D(ERRORFLAG)
 I $G(FEDATEFM) S REQDATE=FEDATEFM
 I '$G(REQDATE) D
 .I APPTREQTYP="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,60) Q
 .I "APPT,RTC,VETERAN,CONSULT,PROCEDURE,PTCSCH"'[APPTREQTYP S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,61) Q
 .I ((APPTREQTYP="APPT")!(APPTREQTYP="RTC")!(APPTREQTYP="VETERAN")) D
 .. I APPTREQIEN'="",'$D(^SDEC(409.85,+APPTREQIEN,0)) S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,4) Q
 .. S REQDATE=$$GET1^DIQ(409.85,APPTREQIEN,1,"I") ;Request Start Date
 .;
 .I ((APPTREQTYP="CONSULT")!(APPTREQTYP="PROCEDURE")) D
 .. I APPTREQIEN'="",'$D(^GMR(123,+APPTREQIEN,0)) S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,4) Q
 .. S REQDATE=$$GET1^DIQ(123,APPTREQIEN,3,"I") ;Request Start Date
 .;
 .I APPTREQTYP="PTCSCH" D
 .. I APPTREQIEN'="",'$D(^SD(403.5,+APPTREQIEN,0)) S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,4) Q
 .. S REQDATE=$$GET1^DIQ(403.5,APPTREQIEN,7.5,"I") ;Request Start Date
 S REQDATE=$P($G(REQDATE),".",1)
 ;
 I $G(ERRORFLAG)=1 Q $D(ERRORFLAG)
 I $G(SDCLNIEN)="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,18) Q $D(ERRORFLAG)
 I +$G(SDCLNIEN)>0 D
 . S SDCLNAME=$$GET1^DIQ(44,SDCLNIEN_",",.01,"I") ;retrieve the clinic name
 . I SDCLNAME="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,80) Q
 . S SDCLRESIEN=$$FIND1^DIC(409.831,"","X",SDCLNAME,"","","SDERR") ;retrieve the resource IEN for the clinic
 . I $D(SDERR) S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,70) Q
 I $G(SDCLRESIEN)="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,70) Q $D(ERRORFLAG)
 I $G(ERRORFLAG)=1 Q $D(ERRORFLAG)
 I $G(REQDATE)="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,157) Q $D(ERRORFLAG)
 S SDSTOPCD=$$GET1^DIQ(44,SDCLNIEN,8,"I") ;Stop code ien
 I $G(SDSTOPCD)'="" S SDSTOPCD=$$GET1^DIQ(40.7,SDSTOPCD,1,"I") ;Stop code
 I $G(SDSTOPCD)="" S SDSTOPCD=0
 ;
 ; Patient Indication Date
 S PID=$G(PID,"")
 I PID="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,159) Q $D(ERRORFLAG)
 S PIDDATE=$$ISOTFM^SDAMUTDT(PID,$G(SDCLNIEN))
 I PIDDATE=-1 S PIDDATE="",ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,160) Q $D(ERRORFLAG)
 ;
 ;Appointment Date
 S APPTDATE=$G(APPTDATE)
 I APPTDATE="" S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,212) Q $D(ERRORFLAG)
 S APPTDATE=$$ISOTFM^SDAMUTDT(APPTDATE,$G(SDCLNIEN))
 I APPTDATE=-1 S APPTDATE="",ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,213) Q $D(ERRORFLAG)
 ;
 S SDPRIM="N"
 S SDSTOPCDIEN=0
 S SDSTOPCDIEN=$$FIND1^DIC(409.89,"","",SDSTOPCD,"C","","SDERR")
 I SDSTOPCDIEN D
 . S SDSTOPCDTYPE=$$GET1^DIQ(409.89,SDSTOPCDIEN,2,"I")
 . I ((SDSTOPCDTYPE="P")!(SDSTOPCDTYPE="M")) S SDPRIM="Y"
 ;
 I SDPRIM="Y" D
 . S REQENDDT=$$FMADD^XLFDT(REQDATE,19)
 . S SDSERVICE="M"
 I SDPRIM'="Y" D
 . S REQENDDT=$$FMADD^XLFDT(REQDATE,27)
 ;
 ; if the PID date is after the WTS (wait time standard), quit here
 I PIDDATE>REQENDDT Q $D(ERRORFLAG) ;ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,432) Q $D(ERRORFLAG)
 ;
 S SDEAS=$G(SDEAS,"")
 I $L(SDEAS) S SDEAS=$$EASVALIDATE^SDESUTIL(SDEAS)
 I SDEAS=-1 S ERRORFLAG=1 D ERRLOG^SDESJSON(.ERRORS,142) Q $D(ERRORFLAG)
 ;
 ; Determine Appointment availability is within Request start date and Request end date
 S SDTMPARY=$NA(^TMP($J,"CLNCAVAIL"))
 K @SDTMPARY
 S REQDATENET=$$FMTONET^SDECDATE(REQDATE,"")
 S REQENDDTNET=$$FMTONET^SDECDATE(REQENDDT,"")
 ; do not check availability if appointment date is within the wait time standard
 I APPTDATE<REQENDDT!(APPTDATE=REQENDDT) Q ""
 D GETSLOTS^SDEC57(SDTMPARY,SDCLRESIEN,REQDATENET,REQENDDTNET)
 S SDTOTAL=$G(@SDTMPARY@("CNT"))
 S (CNT,DONE)=0
 F II=1:1:SDTOTAL D  Q:DONE
 .S SDP1=$P(@SDTMPARY@(II),U,2) ;start date
 .Q:SDP1<$$NOW^XLFDT()
 .S SDP2=$P(@SDTMPARY@(II),U,3) ;end date
 .S SDP3=+$P(@SDTMPARY@(II),U,4) ;open slots available
 .S SDP4=$P(@SDTMPARY@(II),U,5) ;access type  (1=available, 2=not available, 3=cancelled)
 .;
 .S SDSTRTDT=$$FMTISO^SDAMUTDT($P(SDP1,".")) ;start date - remove the time
 .S SDSTRTTM=$E($P(SDP1_"0000",".",2),1,4) ;start time
 .S SDSTOPTM=$E($P(SDP2_"0000",".",2),1,4) ;stop time
 .S SDSLOTS=$P(@SDTMPARY@(II),U,4)
 .Q:SDSLOTS=0!(SDSLOTS="")
 .S SDSLOTS=$S(SDSLOTS=" ":"",1:SDSLOTS)
 .S SDSLOTS=$S(SDP4=2:"",SDP4=3:"X",1:SDSLOTS)
 .I "jklmnopqrstuvwxyz"[SDSLOTS S SDSLOTS=9+($F("jklmnopqrstuvwxyz",SDSLOTS)-1)
 .Q:'SDSLOTS
 .I SDSLOTS>0 S SDAPPTAVAIL="Y"
 .S CNT=CNT+1
 .I NUMBER-SDSLOTS<0 S SDSLOTS=NUMBER
 .S NUMBER=$G(NUMBER)-SDSLOTS
 .S APPTRETURN("MissionActAvailability",CNT,"ClinicID")=SDCLNIEN
 .S APPTRETURN("MissionActAvailability",CNT,"ClinicName")=$$GET1^DIQ(44,SDCLNIEN,.01,"E")
 .S APPTRETURN("MissionActAvailability",CNT,"AppointmentStart")=$$FMTISO^SDAMUTDT(SDP1)
 .S APPTRETURN("MissionActAvailability",CNT,"AppointmentEnd")=$$FMTISO^SDAMUTDT(SDP2)
 .S APPTRETURN("MissionActAvailability",CNT,"AvailableSlots")=SDSLOTS
 .I NUMBER<1 S DONE=1
 K @SDTMPARY
 ; if availability was found in this clinic and at 10 available slots were found, return the results
 I $G(SDAPPTAVAIL)="Y",NUMBER<1 Q ""
 ; no availability, or less than 10 available slots were found in target clinic, check clinics with matching stop codes
 S CRSTCODEIEN=$$GET1^DIQ(44,SDCLNIEN,2503,"I")
 S CRSTCODE=$$GET1^DIQ(40.7,CRSTCODEIEN,1,"E")
 S CLINLIST=$NA(^TMP("SDESMISSIONAVL",$J,"CLINLIST")) K @CLINLIST
 D MATCHCLIN(.CLINLIST,SDCLNIEN,SDSTOPCD,CRSTCODE)
 I $D(@CLINLIST),$G(NUMBER)>0 D GETAVAIL(.APPTRETURN,.CLINLIST,REQDATE,REQENDDT,.NUMBER)
 K @CLINLIST
 I $D(APPTRETURN) S SDAPPTAVAIL="Y"
 Q $D(ERRORFLAG)
 ;
MATCHCLIN(CLINLIST,SDCLNIEN,STCODE,CRSTCODE) ;
 N STOPIEN,CREDSTOPIEN,CREDSTOPIENS,CRSTLOOP,CRSTOPIEN,CLINIEN,DIV,INST,CHKDIV,CHKINST
 S STOPIEN=$$AMISTOSTOPCODE^SDESUTIL(STCODE)
 S DIV=$$GET1^DIQ(44,SDCLNIEN,3.5,"I")
 S INST=$$GET1^DIQ(40.8,DIV,.07,"I")
 I $G(CRSTCODE)'="" S CREDSTOPIEN=$$AMISTOSTOPCODE^SDESUTIL(CRSTCODE)
 S CLINIEN=0 F  S CLINIEN=$O(^SC("AST",STOPIEN,CLINIEN)) Q:'CLINIEN  D
 .Q:CLINIEN=SDCLNIEN
 .S CHKDIV=$$GET1^DIQ(44,CLINIEN,3.5,"I")
 .S CHKINST=$$GET1^DIQ(40.8,CHKDIV,.07,"I")
 .Q:CHKINST'=INST
 .I $G(CREDSTOPIEN) D  Q
 ..I $D(^SC("ACST",CREDSTOPIEN,CLINIEN)) S @CLINLIST@(CLINIEN)="" Q
 .S @CLINLIST@(CLINIEN)=""
 Q
GETAVAIL(RETURN,CLINLIST,START,END,NUMBER) ;
 N CLINNAME,RESOURCEIEN,SDERR,CLIN,GLOB,CNT,DONE,APPTDAT,APPTSTRT,APPTEND,AVAIL,SLOTS,DONE,SDI,SDECEND,BADATE,LOOP
 S (CNT,DONE)=0
 I $D(RETURN) S CNT=$O(RETURN("MissionActAvailability",9999),-1)+1
 S CLIN="" F  S CLIN=$O(@CLINLIST@(CLIN),-1) Q:'CLIN!(DONE)  D
 .S GLOB=$NA(^TMP("SDESMISSIONAVL",$J,CLIN)) K @GLOB
 .S BADATE=0
 .S SDI=$$FMADD^XLFDT(START,-1),SDECEND=END
 .F  S SDI=$$FMADD^XLFDT(SDI,1) Q:SDI>$P(SDECEND,".",1)!(BADATE>0)!(DONE)  D  ;
 ..I SDI<0 S BADATE=1 Q
 ..I ($O(^SC(CLIN,"T",0))="")!($O(^SC(CLIN,"T",0))>SDI) Q
 ..I $$GET1^DIQ(44,CLIN_",",1918.5,"I")'="Y",$D(^HOLIDAY("B",SDI)) Q   ;do not schedule on holidays
 ..Q:$$INACTIVE^SDESUTIL(CLIN,$P(SDI,".",1))   ;don't get availability if clinic inactive on day SDI
 ..D RESAB^SDEC57(GLOB,CLIN,SDI,SDI_"."_2359) Q:'$D(^TMP("SDESMISSIONAVL",$J,CLIN))
 ..S LOOP=0 F  S LOOP=$O(^TMP("SDESMISSIONAVL",$J,CLIN,LOOP)) Q:'LOOP!(DONE)  D
 ...S APPTDAT=$G(^TMP("SDESMISSIONAVL",$J,CLIN,LOOP))
 ...S APPTSTRT=$P(APPTDAT,U,2)
 ...Q:APPTSTRT<$$NOW^XLFDT
 ...S APPTEND=$P(APPTDAT,U,3)
 ...S SLOTS=$P(APPTDAT,U,4)
 ...Q:SLOTS=0!(SLOTS="")
 ...S AVAIL=$P(APPTDAT,U,5)
 ...S SLOTS=$S(SLOTS=" ":"",1:SLOTS)
 ...S SLOTS=$S(AVAIL=2:"",AVAIL=3:"X",1:SLOTS)
 ...I "jklmnopqrstuvwxyz"[SLOTS S SLOTS=9+($F("jklmnopqrstuvwxyz",SLOTS)-1)
 ...Q:'SLOTS
 ...S CNT=CNT+1
 ...I NUMBER-SLOTS<0 S SLOTS=NUMBER
 ...S NUMBER=$G(NUMBER)-SLOTS
 ...S RETURN("MissionActAvailability",CNT,"ClinicID")=CLIN
 ...S RETURN("MissionActAvailability",CNT,"ClinicName")=$$GET1^DIQ(44,CLIN,.01,"E")
 ...S RETURN("MissionActAvailability",CNT,"AppointmentStart")=$$FMTISO^SDAMUTDT($P(APPTDAT,U,2))
 ...S RETURN("MissionActAvailability",CNT,"AppointmentEnd")=$$FMTISO^SDAMUTDT($P(APPTDAT,U,3))
 ...S RETURN("MissionActAvailability",CNT,"AvailableSlots")=SLOTS
 ...I NUMBER<1 S DONE=1
 ..K @GLOB
 Q
 ;
GETMSNELG(ELGARRAY,REQDATE,REQENDDT,PIDDATE,SDAPPTAVAIL,APPTDATE,SDCLNIEN) ; GET Eligibility
 N HASDATA,SDSTOPCD,CRSTCODEIEN
 S ELGARRAY("MissionEligibility","Code")="0"
 S ELGARRAY("MissionEligibility","Message")="Not Eligible-"_$S(SDSERVICE="M":"Primary Care or Mental Health",1:"Special Care")
 S SDSTOPCD=$$GET1^DIQ(44,SDCLNIEN,8,"I") ;Stop code ien
 S CRSTCODEIEN=$$GET1^DIQ(44,SDCLNIEN,2503,"I")
 S ELGARRAY("MissionEligibility","PrimaryStopCodeName")=$$GET1^DIQ(40.7,SDSTOPCD,.01,"E")
 S ELGARRAY("MissionEligibility","PrimaryStopCodeAmis")=$$GET1^DIQ(40.7,SDSTOPCD,1,"E")
 S ELGARRAY("MissionEligibility","SecondaryStopCodeName")=$$GET1^DIQ(40.7,CRSTCODEIEN,.01,"E")
 S ELGARRAY("MissionEligibility","SecondaryStopCodeAmis")=$$GET1^DIQ(40.7,CRSTCODEIEN,1,"E")
 I APPTDATE>REQENDDT D
 .I (SDAPPTAVAIL="") D
 ..I ((PIDDATE>=REQDATE)&(PIDDATE<=REQENDDT)) D
 ...S ELGARRAY("MissionEligibility","Code")="1"
 ...S ELGARRAY("MissionEligibility","Message")="Eligible-"_$S(SDSERVICE="M":"Primary Care or Mental Health",1:"Special Care")
 S HASDATA=($D(ELGARRAY)>1)
 Q HASDATA
 ;
BUILDJSON(JSONRETURN,INPUT) ; Build JSON format
 S JSONERROR=""
 D ENCODE^XLFJSON("INPUT","JSONRETURN","JSONERROR")
 Q
 ;
CLEANUP ; Cleanup
 K HASVLDERRORS,RETURN,HASFIELDS,ELGFIELDSARRAY,REQENDDT,SDAPPTAVAIL,SDSTOPCD,SDTMPARY
 K ERRORFLAG
 K HASDATA
 K JSONERROR
 Q
SETMISSIONELIG(APPTIEN) ;
 N REQPTR,REQFILE,REQIEN,PIDDATE,APPTDATE,ELGRETURN,APPTREQTYPE,ELIG,ELGRETURN,CLINIC,MISSIONELIG,RESOURCE,FDA
 Q:'$G(APPTIEN)
 S APPTDATE=$P($$GET1^DIQ(409.84,APPTIEN,.01,"I"),".")
 S RESOURCE=$$GET1^DIQ(409.84,APPTIEN,.07,"I")
 S CLINIC=$$GET1^DIQ(409.831,RESOURCE,.04,"I")
 S APPTDATE=$$FMTISO^SDAMUTDT(APPTDATE,CLINIC)
 S REQPTR=$$GET1^DIQ(409.84,APPTIEN,.22,"I")
 S REQIEN=$P(REQPTR,";")
 S REQFILE=$P(REQPTR,";",2)
 I REQFILE[409.85 D
 .S APPTREQTYPE=$$GET1^DIQ(409.85,REQIEN,4,"I")
 .S PIDDATE=$$GET1^DIQ(409.85,REQIEN,22,"I")
 I REQFILE[123 D
 .S APPTREQTYPE=$$UP^XLFSTR($$GET1^DIQ(123,REQIEN,13,"E"))
 .S PIDDATE=$$GET1^DIQ(123,REQIEN,17,"I")
 I REQFILE[403.5 D
 .S APPTREQTYPE="PTCSCH"
 .S PIDDATE=$$GET1^DIQ(403.5,REQIEN,5.5,"I")
 .I 'PIDDATE S PIDDATE=$$GET1^DIQ(403.5,REQIEN,5,"I")
 S PIDDATE=$$FMTISO^SDAMUTDT(PIDDATE,CLINIC)
 D GETMISSIONELG^SDESMISSIONELG(.ELGRETURN,REQIEN,PIDDATE,APPTREQTYPE,$G(SDEAS),APPTDATE,CLINIC)
 D DECODE^XLFJSON("ELGRETURN","MISSIONELIG")
 S ELIG=$G(MISSIONELIG("MissionEligibility","Code"))
 I ELIG S FDA(409.84,APPTIEN_",",2.1)=ELIG D FILE^DIE(,"FDA","ERR") K FDA
 Q