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

SDESCREATEAPPT44.m

Go to the documentation of this file.
SDESCREATEAPPT44 ;ALB/BLB,DJS,BLB,TJB - SDES CREATE APPOINTMENT ;Jun 17, 2024
 ;;5.3;Scheduling;**814,823,827,851,877,881**;Aug 13, 1993;Build 10
 ;;Per VHA Directive 6402, this routine should not be modified
 ;
 Q
 ;
 ; create appt in file 44. Called from wrapper level SDESCRTAPPTWRAP. See SDESCRTAPPTWRAP for required inputs.
 ;
 ;
VALIDATE(ERRORS,ARY44) ;
 ;
 N HAS44APPT,SDDA
 ;
 ; clinic IEN
 S ARY44("CLINICIEN")=$G(ARY44("CLINICIEN"),"")
 I ARY44("CLINICIEN")="" D ERRLOG^SDESJSON(.ERRORS,18) Q
 I '$D(^SC(+ARY44("CLINICIEN"),0)) D ERRLOG^SDESJSON(.ERRORS,19) Q
 I $$INACTIVE^SDEC32(+ARY44("CLINICIEN")) D ERRLOG^SDESJSON(.ERRORS,19) Q
 ;
 ; patient DFN
 S ARY44("DFN")=$G(ARY44("DFN"),"")
 I ARY44("DFN")="" D ERRLOG^SDESJSON(.ERRORS,1) Q
 I ARY44("DFN")'="",'$D(^DPT(+ARY44("DFN"),0)) D ERRLOG^SDESJSON(.ERRORS,2) Q
 ;
 ; desired date/time of appt
 S ARY44("SDAPPTSTARTDTTM")=$G(ARY44("SDAPPTSTARTDTTM"),"")
 I ARY44("SDAPPTSTARTDTTM")="" D ERRLOG^SDESJSON(.ERRORS,57) Q
 S ARY44("SDAPPTSTARTDTTM")=$$ISOTFM^SDAMUTDT(ARY44("SDAPPTSTARTDTTM"),ARY44("CLINICIEN")) ; vse-2397  clinic time zone
 I ARY44("SDAPPTSTARTDTTM")=-1 S ARY44("SDAPPTSTARTDTTM")="" D ERRLOG^SDESJSON(.ERRORS,58) Q
 ;I ARY44("SDAPPTSTARTDTTM")<DT D ERRLOG^SDESJSON(.ERRORS,59) Q  ;Only validate on Create, Allow Appointments made in the Past
 ;
 ; appointment Length in Minutes
 S ARY44("SDAPPTLENGTH")=$G(ARY44("SDAPPTLENGTH"),"")
 I ARY44("SDAPPTLENGTH")="" D ERRLOG^SDESJSON(.ERRORS,115) Q
 I ARY44("SDAPPTLENGTH")'="",((+ARY44("SDAPPTLENGTH")<5)!(+ARY44("SDAPPTLENGTH")>240)) D ERRLOG^SDESJSON(.ERRORS,116) Q
 ;
 ; appointment Reason
 S ARY44("SDAPPTREASON")=$G(ARY44("SDAPPTREASON"),"")
 S ARY44("SDAPPTREASON")=$TR($G(ARY44("SDAPPTREASON")),"^"," ")
 ;
 ; overbook
 S ARY44("SDOVERBOOK")=$G(ARY44("SDOVERBOOK"),"")
 I ARY44("SDOVERBOOK")'="" D
 . I ARY44("SDOVERBOOK")'=1,ARY44("SDOVERBOOK")'=0 D ERRLOG^SDESJSON(.ERRORS,112) Q
 ;
 ; patient Eligibility
 S ARY44("SDPATELIG")=$G(ARY44("SDPATELIG"),"")
 I ARY44("SDPATELIG")'="",'$D(^DIC(8,+ARY44("SDPATELIG"),0)) D ERRLOG^SDESJSON(.ERRORS,143) Q
 ;
 ; check for existing appointment in clinic for same patient/date/time
 S HAS44APPT=$$APPTIN44EXISTS(ARY44("DFN"),ARY44("CLINICIEN"),ARY44("SDAPPTSTARTDTTM"))
 I HAS44APPT D ERRLOG^SDESJSON(.ERRORS,175) Q
 ;
 Q
APPTIN44EXISTS(DFN,CLINIC,DATE) ;
 N SUBIEN,FOUND
 S FOUND=0
 S SUBIEN=0 F  S SUBIEN=$O(^SC(CLINIC,"S",DATE,1,SUBIEN)) Q:'SUBIEN!($G(FOUND)=1)  D
 .I $$GET1^DIQ(44.003,SUBIEN_","_DATE_","_CLINIC_",",310)="CANCELLED" Q  ;cancelled
 .I $$GET1^DIQ(44.003,SUBIEN_","_DATE_","_CLINIC_",",.01,"I")=DFN S FOUND=1 Q  ; record exists
 I $G(FOUND)=1 Q 1
 Q 0
 ;
CREATE(ARRAY44001FDA,ARRAY44003FDA,NEWIEN44001,IENS44,ARY44) ;
 ;
 ; only allow one entry in 44.001 for a single date
 I '$D(^SC($G(ARY44("CLINICIEN")),"S",$G(ARY44("SDAPPTSTARTDTTM")))) D
 .S NEWIEN44001(1)=ARY44("SDAPPTSTARTDTTM")
 .S ARRAY44001FDA(44.001,"+1,"_$G(ARY44("CLINICIEN"))_",",.01)=$G(ARY44("SDAPPTSTARTDTTM"))
 S IENS44(1)=ARY44("SDAPPTSTARTDTTM")_","_ARY44("CLINICIEN")_","
 S ARRAY44003FDA(44.003,"+1,"_IENS44(1),.01)=$G(ARY44("DFN"))
 S ARRAY44003FDA(44.003,"+1,"_IENS44(1),1)=$G(ARY44("SDAPPTLENGTH"))
 S ARRAY44003FDA(44.003,"+1,"_IENS44(1),3)=$E($G(ARY44("SDAPPTREASON")),1,150)
 S ARRAY44003FDA(44.003,"+1,"_IENS44(1),30)=$G(ARY44("SDPATELIG"))
 S ARRAY44003FDA(44.003,"+1,"_IENS44(1),9)=$S(+ARY44("SDOVERBOOK"):"O",1:"")
 S ARRAY44003FDA(44.003,"+1,"_IENS44(1),7)=$G(DUZ)
 S ARRAY44003FDA(44.003,"+1,"_IENS44(1),8)=$$NOW^XLFDT
 Q
CLEANUP44(ARY44,NEWIEN44,SDREQTYPE) ;
 ;add consult link
 I $P(ARY44("SDREQTYPE"),"|",1)="C" D
 .N SDFDA
 .S SDFDA(44.003,NEWIEN44_","_ARY44("SDAPPTSTARTDTTM")_","_ARY44("CLINICIEN")_",",688)=$P(SDREQTYPE,"|",2)
 .D UPDATE^DIE("","SDFDA") K SDFDA
 ;
 ;make appt event #1
 S SDDA=$$SCIEN^SDECU2($G(ARY44("DFN")),$G(ARY44("CLINICIEN")),$G(ARY44("SDAPPTSTARTDTTM")))
 D MAKE^SDAMEVT($G(ARY44("DFN")),$G(ARY44("SDAPPTSTARTDTTM")),$G(ARY44("CLINICIEN")),SDDA,2)
 ;update clinic availability
 D DECREMENTAVAIL1($G(ARY44("CLINICIEN")),$G(ARY44("SDAPPTSTARTDTTM")),$G(ARY44("SDAPPTLENGTH")))
 Q
 ;
DECREMENTAVAIL1(CLINICIEN,APPTSTARTTIME,APPTLENGTH) ;
 N COUNT,CLINICAPPTLENGTH,NUMOFSLOTSINPLAY
 S CLINICAPPTLENGTH=+$E($$GET1^DIQ(44,CLINICIEN,1917,"E"),1,2)
 S NUMOFSLOTSINPLAY=APPTLENGTH/CLINICAPPTLENGTH
 F COUNT=1:1:NUMOFSLOTSINPLAY D
 .I COUNT>1 D
 ..S APPTSTARTTIME=$$FMADD^XLFDT(APPTSTARTTIME,,,CLINICAPPTLENGTH)
 .D DECREMENTAVAIL2(CLINICIEN,APPTSTARTTIME,APPTLENGTH)
 Q
 ;
DECREMENTAVAIL2(CLINICIEN,APPTSTARTTIME,APPTLENGTH) ;decrement availability by one when creating appointment
 N SLOTINCREMENT,SLOTSTATUSSTRING,CURRENTSCHEDULE,NEWSCHEDULE,TIMECLINICOPENS,SLOTLENGTH,NEWAVAILABILITY,SPECIALCHARACTER,AVAILABILITYFDA,CENTEROFSLOT,CHARMULTIPLIER,MAXDAYSINFUTURE
 ;
 S CURRENTSCHEDULE=$$GET1^DIQ(44.005,$P(APPTSTARTTIME,".")_","_CLINICIEN_",",1)
 S TIMECLINICOPENS=$S($L($$GET1^DIQ(44,CLINICIEN,1914,"I")):$$GET1^DIQ(44,CLINICIEN,1914,"I"),1:8)-1/100
 S SLOTLENGTH=$S($$GET1^DIQ(44,CLINICIEN,1917,"I"):$$GET1^DIQ(44,CLINICIEN,1917,"I"),1:4)
 S SLOTINCREMENT=$S('$$GET1^DIQ(44,CLINICIEN,1917,"I"):4,$$GET1^DIQ(44,CLINICIEN,1917,"I")<3:4,$$GET1^DIQ(44,CLINICIEN,1917,"I"):$$GET1^DIQ(44,CLINICIEN,1917,"I"),1:4)
 S CHARMULTIPLIER=$S(SLOTLENGTH<3:8/SLOTLENGTH,1:2)
 S NEWAVAILABILITY=APPTSTARTTIME#1-TIMECLINICOPENS*100
 S CENTEROFSLOT=NEWAVAILABILITY#1*SLOTINCREMENT\.6+(NEWAVAILABILITY\1*SLOTINCREMENT)*2
 S MAXDAYSINFUTURE=$$GET1^DIQ(44,CLINICIEN,2002,"I")
 S SLOTSTATUSSTRING="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
 ;
 I $P(APPTSTARTTIME,".")>$$FMADD^XLFDT(DT,MAXDAYSINFUTURE) D ERRLOG^SDESJSON(.ERRORS,491) Q
 ;
 I '$D(^SC(CLINICIEN,"ST",$P(APPTSTARTTIME,"."),1)) D
 .D ASSEMBLE^SDESCLINDAILYSCH(.ERRORS,CLINICIEN,$P(APPTSTARTTIME,"."),$$GET1^DIQ(44,CLINICIEN,1917,"I"),TIMECLINICOPENS)
 ;
 I $D(^SC(CLINICIEN,"ST",$P(APPTSTARTTIME,"."),"CAN"))!(CURRENTSCHEDULE["CAN") D ERRLOG^SDESJSON(.ERRORS,492)
 ;
 F SPECIALCHARACTER=CENTEROFSLOT:CHARMULTIPLIER  Q:$L($G(NEWSCHEDULE))!($G(NEWAVAILABILITY)="")  D
 .S NEWAVAILABILITY=$E(SLOTSTATUSSTRING,$F(SLOTSTATUSSTRING,$E(CURRENTSCHEDULE,SPECIALCHARACTER+1))-2)
 .S NEWSCHEDULE=$E(CURRENTSCHEDULE,1,SPECIALCHARACTER)_NEWAVAILABILITY_$E(CURRENTSCHEDULE,SPECIALCHARACTER+2,999)
 ;
 S AVAILABILITYFDA(44.005,$P(APPTSTARTTIME,".")_","_CLINICIEN_",",1)=NEWSCHEDULE
 D FILE^DIE(,"AVAILABILITYFDA") K AVAILABILITYFDA
 Q
 ;
AVUPDT(SDECSCD,SDECSTART,SDECLEN) ;
 N HSI,I,S,SB,SD,SDDIF,SI,SL,SS,ST,STARTDAY,STR,X,Y
 S (SD,S)=SDECSTART
 S I=SDECSCD
 Q:'$D(^SC(I,"ST",SD\1,1))
 S SL=^SC(I,"SL"),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2)
 S SL=SDECLEN
 S S=^SC(I,"ST",SD\1,1),Y=SD#1-SB*100,ST=Y#1*SI\.6+(Y\1*SI),SS=SL*HSI/60
 I Y'<1 F I=ST+ST:SDDIF S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y=""  S S=$E(S,1,I)_Y_$E(S,I+2,999),SS=SS-1 Q:SS'>0
 S ^SC(SDECSCD,"ST",SD\1,1)=S
 Q
 ;