MBAAMAP2 ;OIT-PD/VSL - APPOINTMENT API ;FEB 23, 2017
;;1.0;Scheduling Calendar View;**1,4,5,7**;May 5, 2015;Build 16
;
;Associated ICRs
; ICR#
; 5838 SDAMEVT
; 6048 SDAMEVT
; 6054 MBAA USE OF SDAM2 API get inpatient data
; 6049 MBAA SDMANA API USE
; 5838 SDAMEVT
;
CHKAPP(RETURN,SC,DFN,SD,LEN,LVL) ; Check make appointment Called by RPC MBAA APPOINTMENT MAKE
N PAT,CLN,VAL,PATT,HOL,TXT,X1,X2,APT,CAPT,FRSTA,SDEDT,SDSOH,%
K RETURN
S RETURN=1
S:'$G(LVL) LVL=7
D GETPAT^MBAAMDA3(.PAT,DFN,1) ; get patient data
D GETCLN^MBAAMDA1(.CLN,SC,1) ; get clinic data
;check patient, stop code and inactive
S %=$$CHKAPTU(.RETURN,SC,DFN,SD,.CLN,.PAT) Q:RETURN=0 0
;check user permissions
S VAL=$$CLNRGHT^MBAAMAP1(.RETURN,SC) Q:VAL=0 VAL
S %=$$SETST^MBAAMAP4(.RETURN,SC,SD) Q:RETURN=0 0
;verify that day hasn't been canceled via "SET UP A CLINIC"
D GETPATT^MBAAMDA1(.PATT,SC,SD) I $G(PATT(0))'["[" S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTCLUV") Q 0
;check if schedule on holiday is permited
D GETHOL^MBAAMDA1(.HOL,$P(SD,"."))
S SDSOH=$S('$D(CLN(1918.5)):0,CLN(1918.5)']"":0,1:1)
I $D(HOL(0)),'SDSOH S TXT(1)=$P(HOL(0),U,2) S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTSHOL",.TXT) Q 0
;check if exceed max days for future appointment
S X1=DT,SDEDT=$G(CLN(2002))
S:SDEDT'>0 SDEDT=365
S X2=SDEDT D C^%DTC S SDEDT=X
I $P(SD,".")'<SDEDT S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTEXCD") Q 0
;
;check if patient has an active appointment on the same time
;
;WCJ;MBAA*1*7;Need to expand to check for overlaps beyond starting at the exact same time
;check if new appointment + LEN crosses an appointment on file (that isn't cancelled) and
;check if appointments on file (that isn't cancelled) + duration crosses the appointment we are trying to book
;
; first, get the appointments for the day
D GETAPTS^MBAAMDA2(.APT,DFN,$P(SD,"."))
;
; Then check if new one plus its length crosses another appointment already scheduled.
; Add LENgth of new appointment to the starting time of new appoinment to get the appointment end time.
; can they have an 60 minute at 8 and another appt at 9 ???
; assuming they can for now and subtracting a second will allow that.
N LOOPSD,APPTEND
S APPTEND=$$FMADD^XLFDT(SD,0,0,LEN,-1)
;
; Loop thru appointments on file starting with the start time of the new appointment (minus a second)
; Quit when the start time of existing appointment > end time of new one since more overlaps not possible
; If there is an appointment in between which is not cancelled, we (royal one) have an issue
S LOOPSD=$$FMADD^XLFDT(SD,0,0,0,-1) ; subtract a second to catch ones with exact same start time
F S LOOPSD=$O(APT("APT",LOOPSD)) Q:LOOPSD>APPTEND!('+LOOPSD) I APT("APT",LOOPSD,"STATUS")'["C" D Q
. ;MBAA*1*5 - use clinic of existing appointment
. N SC1 S SC1=$P($G(APT("APT",LOOPSD,"CLINIC")),U) Q:'SC1
. S %=$$GETSCAP^MBAAMAP1(.CAPT,SC1,DFN,LOOPSD) Q:'$D(CAPT)
. S TXT(1)="("_CAPT("LENGTH")_" MINUTES)"
. S RETURN=0
. D ERRX^MBAAAPIE(.RETURN,"APTPAHA",.TXT,2)
Q:RETURN=0 0
;
; Now check if an existing appointment plus its length crosses this new one.
; going back 1 day to start. probably overkill - if max length of an appointment is a thing, we could go back that far.
S LOOPSD=$$FMADD^XLFDT(SD,-1,0,0,0)
F S LOOPSD=$O(APT("APT",LOOPSD)) Q:LOOPSD>APPTEND!('+LOOPSD) I APT("APT",LOOPSD,"STATUS")'["C" D Q:RETURN=0
. ;MBAA*1*5 - use clinic of existing appointment
. N SC1 S SC1=$P($G(APT("APT",LOOPSD,"CLINIC")),U) Q:'SC1
. S %=$$GETSCAP^MBAAMAP1(.CAPT,SC1,DFN,LOOPSD)
. Q:'+$G(CAPT("LENGTH")) ; can't check for overlaps without length so assume it's cool
. Q:'($$FMADD^XLFDT(LOOPSD,0,0,+$G(CAPT("LENGTH")),-1)>SD) ; check if existing start + length - 1 sec > new appt start
. S TXT(1)="("_CAPT("LENGTH")_" MINUTES)"
. S RETURN=0
. D ERRX^MBAAAPIE(.RETURN,"APTPAHA",.TXT,2)
Q:RETURN=0 0
;
; left the old check for now, just in case
; Check if patient has an appointment that starts exactly at the same time that hasn't been cancelled
;I $D(APT),APT("APT",SD,"STATUS")'["C" D
;. ;MBAA*1*5 - use clinic of existing appointment
;. N SC1 S SC1=$P($G(APT("APT",SD,"CLINIC")),U) Q:'SC1
;. S %=$$GETSCAP^MBAAMAP1(.CAPT,SC1,DFN,SD) Q:'$D(CAPT)
;. S TXT(1)="("_CAPT("LENGTH")_" MINUTES)"
;. S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTPAHA",.TXT,2)
;Q:RETURN=0 0
;
;check if patient has an active appointment on the same day
I LVL>2 D
. K APT N IDX S IDX=""
. D GETDAPTS^MBAAMDA2(.APT,DFN,$P(SD,"."))
. F S IDX=$O(APT(IDX)) Q:IDX="" I APT(IDX,2)'["C" D Q
. . K TXT S TXT(1)="(AT "_$E(IDX_0,9,10)_":"_$E(IDX_"000",11,12)_")"
. . S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTPHSD",.TXT,3)
Q:RETURN=0 0
;
;check if patient has an canceled appointment on the same time
I LVL'<2 D
. K APT
. D GETAPTS^MBAAMDA2(.APT,DFN,SD)
. I $D(APT),APT("APT",SD,"STATUS")["P" D
. . S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTPPCP",,2)
Q:RETURN=0 0
;
;check if date is prior to patient birth date
I $P(SD,".",1)<$P(PAT(.03),U,1) S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTPPAB") Q RETURN
;
;check if date is prior to clinic availability
S FRSTA=$$GETFSTA^MBAAMDA1(SC) I FRSTA,$P(SD,".",1)<FRSTA S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTPCLA") Q 0
;
;check overbook
S %=$$CHKOVB(.RETURN,.CLN,SC,SD,LEN,LVL) Q:RETURN=0 RETURN
S RETURN=1
Q RETURN
;
CHKOVB(RETURN,CLN,SC,SD,LEN,LVL) ; Check overbook Called by RPC MBAA APPOINTMENT MAKE
N TXT,ACC,SM,MAXOB,OBNO,PP,KEYS
S RETURN=1 S:'$G(LVL) LVL=7
S SM=$$DECAVA(.CLN,SC,SD,LEN,.PP)
Q:'SM 0
S KEYS("SDOB")="",KEYS("SDMOB")=""
D GETXUS^MBAAMDA3(.ACC,.KEYS,DUZ)
I '$D(ACC("SDOB")) S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTNOST") Q 0
S MAXOB=CLN(1918)
S OBNO=$$GETOBNO(SC,SD)
S TXT(1)=MAXOB,TXT(2)=$S(OBNO>1:"S",1:"")
I OBNO>MAXOB,'$D(ACC("SDMOB")) S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTOAPD",.TXT) Q 0
I OBNO>MAXOB,LVL>1 S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTEXOB",,2) Q 0
I SM=6,LVL>1 S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTOVBK",,2) Q 0
I SM=7 S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTOVOS",,2) Q 0
I SM=1 S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTCBCP") Q 0
Q RETURN
;
GETOBNO(SC,SD) ; Called by RPC MBAA APPOINTMENT MAKE
N IND,CNT,APTS
S IND="",CNT=0
D GETDAYA^MBAAMDA1(.APTS,SC,SD)
F S IND=$O(APTS(IND)) Q:IND="" S:APTS(IND,"OB")>0 CNT=CNT+1
Q CNT
;
CHKAPTU(RETURN,SC,DFN,SD,CLN,PAT,UNS) ; Check make unscheduled appointment MBAA RPC: MBAA APPOINTMENT MAKE
N PAPT,CLN,TXT
D:'$D(PAT) GETPAT^MBAAMDA3(.PAT,DFN,1) ; get patient data
D:'$D(CLN) GETCLN^MBAAMDA1(.CLN,SC,1) ; get clinic data
;check if patient already has appointment
S PAPT(.01)="" D GETPAPT^MBAAMDA2(.PAPT,DFN,SD)
S TXT(1)=$$FTIME^VALM1(SD) ;ICR#: 10116 VALM1
I PAPT(.01)>0,$D(UNS) S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTPAHU",.TXT) Q RETURN
;check if patient is dead
I +$G(PAT(.351))>0 S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"PATDIED") Q RETURN
;check if clinic is valid (stop code)
S VAL=$$CLNCK^MBAAMAP1(.RETURN,SC) Q:VAL=0 VAL
;check inactive clinic period
I CLN(2505),$P(SD,".")'<CLN(2505),$S('CLN(2506):1,CLN(2506)>$P(SD,".")!('CLN(2506)):1,1:0) D Q 0
. S TXT(1)=$$DTS^MBAAMAPI(CLN(2505))
. S:CLN(2506) TXT(2)=" and reactivated on "_$$DTS^MBAAMAPI(CLN(2506))
. S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTCINV",.TXT)
Q 1
;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
;MAKEUS(RETURN,DFN,SC,SD,TYP,STYP) ; Make unscheduled appointment
; N SCAP,STAT,CHKIN,%
; S RETURN=0
; S %=$$CHKAPTU(.RETURN,SC,DFN,SD,,,1) Q:RETURN=0 0
; S STAT=$$INP^SDAM2(DFN,SD)
; D GETCLN^MBAAMDA1(.CLN,SC,1)
; D MAKE^MBAAMDA3(DFN,SD,SC,TYP,.STYP,STAT,4,DUZ,DT,"W",0)
; D MAKE^MBAAMDA1(SC,SD,DFN,CLN(1912),,DUZ)
; S %=$$LOCKST^MBAAMDA1(SC,SD) I '% S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTLOCK") Q 0
; S SM=$$DECAVA(.CLN,SC,SD,CLN(1912),.S)
; D SETST^MBAAMDA1(SC,SD,S)
; D UNLCKST^MBAAMDA1(SC,SD)
; S %=$$GETSCAP^MBAAMAP1(.SCAP,SC,DFN,SD)
; D MAKE^SDAMEVT(DFN,SD,SC,SCAP("IFN"))
; Q 1
; ;
MAKE(RETURN,DFN,SC,SD,TYPE,STYP,LEN,SRT,OTHR,CIO,LAB,XRAY,EKG,RQXRAY,CONS,LVL,DESDT) ; Make appointment Called by RPC MBAA APPOINTMENT MAKE
N %
;IF WE NEED TO CHECK FOR DEPARTMENT OF DEFENSE PUT IN THE CODE TO DO THE TASKS BELOW
;I DUZ="" THEN SET DUZ FOR DEPARTMENT OF DEFENSE
;S REC=$O(^VA(200,"B","DEPARTMENT OF DEFENSE,USER",""))
;I REC'>0 SEND ERROR MESSAGE THAT THE DEPARTMENT OF DEFENSE,USER DOESN'T EXIST ON THE SYSTEM
;I REC>0 S DUZ=REC D CLNRGHT^MBAAMRP1(.RETURN,SC) I RETURN(0)=1 S RETURN="0^RESTRICED CLINIC, USER NOT ALLOWED TO BOOK APPTS IN THIS CLINIC" Q
;CALL VERIFY CLINIC ACCESS
;Q:IF NOT ACCESS
S:'$G(LVL) LVL=7
S RETURN=1
F I="SC","DFN","SD","LEN" I '$D(@I) S RETURN=0,TXT(1)=I D ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
I RETURN=0 Q 0
S %=$$CHKAPP(.RETURN,SC,DFN,SD,LEN,LVL)
I RETURN=0,$P(RETURN(0),U,3)'>LVL Q RETURN(0)
I RETURN=0,$P(RETURN(0),U)="PATDIED" Q RETURN(0)
;MBAA*1*5 - RETURN ERROR ON DUPLICATE DATE/TIME - REMOVE CANCEL AND REMAKE
;I RETURN=0,$P(RETURN(0),U)="APTPAHA" D
;. S %=$$CANCEL(.RETURN,DFN,SC,SD,"C",13,"")
I RETURN=0,$P(RETURN(0),U)="APTPAHA" Q RETURN(0)
E Q:'$G(RETURN)&('$G(LVL)) 0
N CLN,S,SM,SDY,SCAP,SRT0
S %=$$LOCKST^MBAAMDA1(SC,SD) I '% S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTLOCK") Q 0
S %=$$LOCKS^MBAAMDA1(SC,SD) I '% S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTLOCK") Q 0
D GETCLN^MBAAMDA1(.CLN,SC,1)
S SM=$$DECAVA(.CLN,SC,SD,+LEN,.S)
D SETST^MBAAMDA1(SC,SD,S)
D MAKE^MBAAMDA1(SC,SD,DFN,+LEN,SM,DUZ,$G(OTHR),.RQXRAY)
D UNLCKS^MBAAMDA1(SC,SD)
D UNLCKST^MBAAMDA1(SC,SD)
S STAT=$$INP^SDAM2(DFN,SD) ;ICR#: 6054 MBAA USE OF SDAM2 API get inpatient data
S:SD<DT SRT="W"
S SRT0=$$NAVA^SDMANA(SC,SD,.SRT) ;ICR#: 6049 MBAA SDMANA API USE
D MAKE^MBAAMDA3(DFN,SD,SC,.TYPE,.STYP,STAT,3,DUZ,DT,SRT,SRT0,.LAB,.XRAY,.EKG,$G(DESDT))
;
;WCJ;MBAA*1*7;This has previously been commented out. Took out the set of field 27 (it was set in line above)
;and sped up the call to get encounters to make below function useable
N DATA ; S DATA(27)=DT,
S DATA(28)=$$PTFU^MBAAMAP1(,DFN,SC)
D UPDPAPT^MBAAMDA4(.DATA,DFN,SD)
;
S %=$$GETSCAP^MBAAMAP1(.SCAP,SC,DFN,SD)
I $G(CONS)>0 S DATA(688)=CONS
D UPDCAPT^MBAAMDA4(.DATA,SC,SD,$G(SCAP("IFN")))
S:$G(CONS)>0 %=$$EDITCS^MBAAAPI1(.RETURN,CONS,SD,.OTHR,$G(CLN("NAME"))) ;SD/478
D MAKE^SDAMEVT(DFN,SD,SC,$G(SCAP("IFN")),2) ;ICR#: 6048 SDAMEVT
;alb/sat 4 - begin mod to update SDEC files
N SDAPTYP,SDECAR,SDECR,SDRES,SDRQTYP,SDSTAT
S CONS=$G(CONS)
S:'CONS SDECAR=$$SDWLA^SDM1A(DFN,SD,SC,DESDT,TYPE) ;build SDEC APPT REQUEST entry
S SDAPTYP=$S(+CONS:"C|"_CONS,1:"A|"_SDECAR)
S SDRES=$$GETRES^SDECUTL(SC)
D PCSTGET^SDEC(.SDECR,DFN,SC) S SDSTAT=$P(@SDECR@(1),$C(30,31),1),SDECR=$S($P(SDSTAT,U,2)="YES":"E",1:"N")
D SDECADD^SDEC07(SD,,DFN,SDRES,0,$G(DESDT),"",SDAPTYP,,SC,$G(OTHR),,SDRES,TYPE,SDECR) ;add SDEC APPOINTMENT entry
;alb/sat 4 - end mod
I $D(CIO),CIO="CI" S %=$$CHECKIN^MBAAMAP2(.CHKIN,DFN,SD,SC,SD)
K CHKIN,DATA,STAT
Q 1
;
DECAVA(CLN,SC,SD,LEN,PATT) ; Decrease availability Called by RPC MBAA APPOINTMENT MAKE
N AV,S,SB,X,Y,I,SS,ST,STR,STARTDAY,HSI,SI,SDDIF,SM,CAN,SDNOT
S SM=0,CAN=0
D GETPATT^MBAAMDA1(.AV,SC,SD)
S S=$G(AV(0)),SB=CLN(1914)
S STARTDAY=$S($L(SB):SB,1:8),SB=STARTDAY-1/100
S X=CLN(1917),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4)
S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2)
S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=LEN*HSI/60*SDDIF+ST+ST
I SM<7 S %=$F(S,"[",SS-1) S:'%!(CLN(1917)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
I ST+ST>$L(S),$L(S)<80 S S=S_" "
S SDNOT=1 ;SD*5.3*490 naked Do added below
F I=ST+ST:SDDIF:SS-SDDIF S ST=$E(S,I+1) S:ST="" ST=" " S Y=$E(STR,$F(STR,ST)-2) S:S["CAN"!(ST="X"&($D(AV(1)))) CAN=1 Q:CAN S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) D S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
.Q:ST'=""
.Q:+LEN'>CLN(1912)
.S ST=" "
.Q
S PATT=S
Q:CAN CAN
Q SM
;
CANCEL(RETURN,DFN,SC,SD,TYP,RSN,RMK) ; Cancel appointment Called by RPC MBAA APPOINTMENT MAKE
N CDATE,CDT,ERR,ODT,OIFN,OUSR,%
S RETURN=0
S %=$$CHKCAN^MBAAMAP3(.RETURN,DFN,SC,SD) Q:RETURN=0 0
S CDATE=$$NOW^XLFDT ;ICR#: 10103 XLFDT
S %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
S CIFN=CAPT("IFN")
S OUSR=CAPT("USER"),ODT=CAPT("DATE")
N SDATA,SDCPHDL
S SDCPHDL=$$HANDLE^SDAMEVT(1) ;ICR#: 5838 SDAMEVT
D BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCPHDL) ;ICR#: 5835 SDAMEVT
S CDT=$$NOW^XLFDT() ;ICR#: 10103 XLFDT
D CANCEL^MBAAMDA3(.ERR,DFN,SD,TYP,RSN,RMK,$E(CDT,1,12),DUZ,OUSR,ODT)
S OIFN=$$COVERB^MBAAMDA1(SC,SD,CIFN)
S %=$$CANCEL^MBAAAPI1(RETURN,CAPT("CONSULT"),SC,SD,CIFN,RMK,TYP)
D CANCEL^MBAAMDA1(SC,SD,DFN,CIFN)
D CANCEL^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,0,SDCPHDL) ;ICR#: 6048 MBAA SDAMEVT API CALLS
S RETURN=1 K CIFN
Q RETURN
;
CHECKIN(RETURN,DFN,SD,SC,CIDT) ; Check in appointment Called by RPC MBAA APPOINTMENT MAKE
N CAPT,CI,%
S CI=DT
S:$D(CIDT) CI=CIDT
S %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
I $G(CAPT(0))="" D ERRX^MBAAAPIE(.RETURN,"APTWHEN") Q 0
S CIFN=$G(CAPT("IFN"))
I 'CIFN D ERRX^MBAAAPIE(.RETURN,"APTWHEN") Q 0
N SDATA,SDCIHDL,X
S SDATA=CIFN_U_DFN_U_SD_U_SC,SDCIHDL=$$HANDLE^SDAMEVT(1) ;ICR#: 5835 SDAMEVT
D BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCIHDL) ;ICR#: 5838 SDAMEVT
S %=$$CHKCIN^MBAAMAP3(.RETURN,DFN,SD,+SDATA("BEFORE","STATUS")) Q:'% 0
S CD(302)=DUZ,CD(309)=CI
D UPDCAPT^MBAAMDA4(.CD,SC,SD,CAPT("IFN"))
D AFTER^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCIHDL) ;ICR#: 5838 SDAMEVT
M RETURN=SDATA
I SDATA("BEFORE","STATUS")'=SDATA("AFTER","STATUS") D
. D EVT^SDAMEVT(.SDATA,4,0,SDCIHDL) ; 4 := ci evt , 0 := interactive mode ;ICR#: 5838 SDAMEVT
K CD,CIFN
Q 1
;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
;Linetag NOSHOW is not needed until the next enhancement of MBAA
;NOSHOW(RETURN,DFN,SC,SD,LVL) ; No-show appointment
;N APT0,STATUS,APTSTAT,AUTO,CNSTLNK,NSDA,NSDIE,%
;S:'$D(LVL) LVL=7
;S APT0=$$GETAPT0^MBAAMDA2(DFN,SD)
;S APTSTAT=$P(APT0,U,2)
;S STATUS=$$STATUS^SDAM1(DFN,SD,+$G(APT0),$G(APT0))
;S RETURN=0
;S %=$$CHKNS^MBAAMAP3(.RETURN,APT0,+STATUS,LVL)
;I RETURN=0,$P(RETURN(0),U,3)'>LVL Q RETURN
;N FDA,CIFN,CAPT
;S %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
;S CIFN=CAPT("IFN")
;S CNSTLNK=$G(CAPT("CONSULT"))
;S RETURN("BEFORE")=STATUS
;N SDNSHDL S SDNSHDL=$$HANDLE^SDAMEVT(1)
;D BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDNSHDL)
;I APTSTAT=""!(APTSTAT="NT") D
;. S FDA(3)="N",FDA(14)=DUZ,FDA(15)=$$NOW^XLFDT()
;E D
;. S FDA(3)="@",FDA(14)="@",FDA(15)="@"
;D UPDPAPT^MBAAMDA4(.FDA,DFN,SD)
;D NOSHOW^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,2,SDNSHDL)
;S:+$G(CNSTLNK) %=$$NOSHOW^MBAAAPI1(.RETURN,SC,SD,DFN,CNSTLNK,CIFN)
;S APT0=$$GETAPT0^MBAAMDA2(DFN,SD)
;S APTSTAT=$P(APT0,U,2)
;S STATUS=$$STATUS^SDAM1(DFN,SD,+$G(APT0),$G(APT0))
;S RETURN("AFTER")=STATUS
;Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMBAAMAP2 15123 printed Dec 13, 2024@02:14:49 Page 2
MBAAMAP2 ;OIT-PD/VSL - APPOINTMENT API ;FEB 23, 2017
+1 ;;1.0;Scheduling Calendar View;**1,4,5,7**;May 5, 2015;Build 16
+2 ;
+3 ;Associated ICRs
+4 ; ICR#
+5 ; 5838 SDAMEVT
+6 ; 6048 SDAMEVT
+7 ; 6054 MBAA USE OF SDAM2 API get inpatient data
+8 ; 6049 MBAA SDMANA API USE
+9 ; 5838 SDAMEVT
+10 ;
CHKAPP(RETURN,SC,DFN,SD,LEN,LVL) ; Check make appointment Called by RPC MBAA APPOINTMENT MAKE
+1 NEW PAT,CLN,VAL,PATT,HOL,TXT,X1,X2,APT,CAPT,FRSTA,SDEDT,SDSOH,%
+2 KILL RETURN
+3 SET RETURN=1
+4 if '$GET(LVL)
SET LVL=7
+5 ; get patient data
DO GETPAT^MBAAMDA3(.PAT,DFN,1)
+6 ; get clinic data
DO GETCLN^MBAAMDA1(.CLN,SC,1)
+7 ;check patient, stop code and inactive
+8 SET %=$$CHKAPTU(.RETURN,SC,DFN,SD,.CLN,.PAT)
if RETURN=0
QUIT 0
+9 ;check user permissions
+10 SET VAL=$$CLNRGHT^MBAAMAP1(.RETURN,SC)
if VAL=0
QUIT VAL
+11 SET %=$$SETST^MBAAMAP4(.RETURN,SC,SD)
if RETURN=0
QUIT 0
+12 ;verify that day hasn't been canceled via "SET UP A CLINIC"
+13 DO GETPATT^MBAAMDA1(.PATT,SC,SD)
IF $GET(PATT(0))'["["
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTCLUV")
QUIT 0
+14 ;check if schedule on holiday is permited
+15 DO GETHOL^MBAAMDA1(.HOL,$PIECE(SD,"."))
+16 SET SDSOH=$SELECT('$DATA(CLN(1918.5)):0,CLN(1918.5)']"":0,1:1)
+17 IF $DATA(HOL(0))
IF 'SDSOH
SET TXT(1)=$PIECE(HOL(0),U,2)
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTSHOL",.TXT)
QUIT 0
+18 ;check if exceed max days for future appointment
+19 SET X1=DT
SET SDEDT=$GET(CLN(2002))
+20 if SDEDT'>0
SET SDEDT=365
+21 SET X2=SDEDT
DO C^%DTC
SET SDEDT=X
+22 IF $PIECE(SD,".")'<SDEDT
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTEXCD")
QUIT 0
+23 ;
+24 ;check if patient has an active appointment on the same time
+25 ;
+26 ;WCJ;MBAA*1*7;Need to expand to check for overlaps beyond starting at the exact same time
+27 ;check if new appointment + LEN crosses an appointment on file (that isn't cancelled) and
+28 ;check if appointments on file (that isn't cancelled) + duration crosses the appointment we are trying to book
+29 ;
+30 ; first, get the appointments for the day
+31 DO GETAPTS^MBAAMDA2(.APT,DFN,$PIECE(SD,"."))
+32 ;
+33 ; Then check if new one plus its length crosses another appointment already scheduled.
+34 ; Add LENgth of new appointment to the starting time of new appoinment to get the appointment end time.
+35 ; can they have an 60 minute at 8 and another appt at 9 ???
+36 ; assuming they can for now and subtracting a second will allow that.
+37 NEW LOOPSD,APPTEND
+38 SET APPTEND=$$FMADD^XLFDT(SD,0,0,LEN,-1)
+39 ;
+40 ; Loop thru appointments on file starting with the start time of the new appointment (minus a second)
+41 ; Quit when the start time of existing appointment > end time of new one since more overlaps not possible
+42 ; If there is an appointment in between which is not cancelled, we (royal one) have an issue
+43 ; subtract a second to catch ones with exact same start time
SET LOOPSD=$$FMADD^XLFDT(SD,0,0,0,-1)
+44 FOR
SET LOOPSD=$ORDER(APT("APT",LOOPSD))
if LOOPSD>APPTEND!('+LOOPSD)
QUIT
IF APT("APT",LOOPSD,"STATUS")'["C"
Begin DoDot:1
+45 ;MBAA*1*5 - use clinic of existing appointment
+46 NEW SC1
SET SC1=$PIECE($GET(APT("APT",LOOPSD,"CLINIC")),U)
if 'SC1
QUIT
+47 SET %=$$GETSCAP^MBAAMAP1(.CAPT,SC1,DFN,LOOPSD)
if '$DATA(CAPT)
QUIT
+48 SET TXT(1)="("_CAPT("LENGTH")_" MINUTES)"
+49 SET RETURN=0
+50 DO ERRX^MBAAAPIE(.RETURN,"APTPAHA",.TXT,2)
End DoDot:1
QUIT
+51 if RETURN=0
QUIT 0
+52 ;
+53 ; Now check if an existing appointment plus its length crosses this new one.
+54 ; going back 1 day to start. probably overkill - if max length of an appointment is a thing, we could go back that far.
+55 SET LOOPSD=$$FMADD^XLFDT(SD,-1,0,0,0)
+56 FOR
SET LOOPSD=$ORDER(APT("APT",LOOPSD))
if LOOPSD>APPTEND!('+LOOPSD)
QUIT
IF APT("APT",LOOPSD,"STATUS")'["C"
Begin DoDot:1
+57 ;MBAA*1*5 - use clinic of existing appointment
+58 NEW SC1
SET SC1=$PIECE($GET(APT("APT",LOOPSD,"CLINIC")),U)
if 'SC1
QUIT
+59 SET %=$$GETSCAP^MBAAMAP1(.CAPT,SC1,DFN,LOOPSD)
+60 ; can't check for overlaps without length so assume it's cool
if '+$GET(CAPT("LENGTH"))
QUIT
+61 ; check if existing start + length - 1 sec > new appt start
if '($$FMADD^XLFDT(LOOPSD,0,0,+$GET(CAPT("LENGTH")),-1)>SD)
QUIT
+62 SET TXT(1)="("_CAPT("LENGTH")_" MINUTES)"
+63 SET RETURN=0
+64 DO ERRX^MBAAAPIE(.RETURN,"APTPAHA",.TXT,2)
End DoDot:1
if RETURN=0
QUIT
+65 if RETURN=0
QUIT 0
+66 ;
+67 ; left the old check for now, just in case
+68 ; Check if patient has an appointment that starts exactly at the same time that hasn't been cancelled
+69 ;I $D(APT),APT("APT",SD,"STATUS")'["C" D
+70 ;. ;MBAA*1*5 - use clinic of existing appointment
+71 ;. N SC1 S SC1=$P($G(APT("APT",SD,"CLINIC")),U) Q:'SC1
+72 ;. S %=$$GETSCAP^MBAAMAP1(.CAPT,SC1,DFN,SD) Q:'$D(CAPT)
+73 ;. S TXT(1)="("_CAPT("LENGTH")_" MINUTES)"
+74 ;. S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTPAHA",.TXT,2)
+75 ;Q:RETURN=0 0
+76 ;
+77 ;check if patient has an active appointment on the same day
+78 IF LVL>2
Begin DoDot:1
+79 KILL APT
NEW IDX
SET IDX=""
+80 DO GETDAPTS^MBAAMDA2(.APT,DFN,$PIECE(SD,"."))
+81 FOR
SET IDX=$ORDER(APT(IDX))
if IDX=""
QUIT
IF APT(IDX,2)'["C"
Begin DoDot:2
+82 KILL TXT
SET TXT(1)="(AT "_$EXTRACT(IDX_0,9,10)_":"_$EXTRACT(IDX_"000",11,12)_")"
+83 SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTPHSD",.TXT,3)
End DoDot:2
QUIT
End DoDot:1
+84 if RETURN=0
QUIT 0
+85 ;
+86 ;check if patient has an canceled appointment on the same time
+87 IF LVL'<2
Begin DoDot:1
+88 KILL APT
+89 DO GETAPTS^MBAAMDA2(.APT,DFN,SD)
+90 IF $DATA(APT)
IF APT("APT",SD,"STATUS")["P"
Begin DoDot:2
+91 SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTPPCP",,2)
End DoDot:2
End DoDot:1
+92 if RETURN=0
QUIT 0
+93 ;
+94 ;check if date is prior to patient birth date
+95 IF $PIECE(SD,".",1)<$PIECE(PAT(.03),U,1)
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTPPAB")
QUIT RETURN
+96 ;
+97 ;check if date is prior to clinic availability
+98 SET FRSTA=$$GETFSTA^MBAAMDA1(SC)
IF FRSTA
IF $PIECE(SD,".",1)<FRSTA
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTPCLA")
QUIT 0
+99 ;
+100 ;check overbook
+101 SET %=$$CHKOVB(.RETURN,.CLN,SC,SD,LEN,LVL)
if RETURN=0
QUIT RETURN
+102 SET RETURN=1
+103 QUIT RETURN
+104 ;
CHKOVB(RETURN,CLN,SC,SD,LEN,LVL) ; Check overbook Called by RPC MBAA APPOINTMENT MAKE
+1 NEW TXT,ACC,SM,MAXOB,OBNO,PP,KEYS
+2 SET RETURN=1
if '$GET(LVL)
SET LVL=7
+3 SET SM=$$DECAVA(.CLN,SC,SD,LEN,.PP)
+4 if 'SM
QUIT 0
+5 SET KEYS("SDOB")=""
SET KEYS("SDMOB")=""
+6 DO GETXUS^MBAAMDA3(.ACC,.KEYS,DUZ)
+7 IF '$DATA(ACC("SDOB"))
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTNOST")
QUIT 0
+8 SET MAXOB=CLN(1918)
+9 SET OBNO=$$GETOBNO(SC,SD)
+10 SET TXT(1)=MAXOB
SET TXT(2)=$SELECT(OBNO>1:"S",1:"")
+11 IF OBNO>MAXOB
IF '$DATA(ACC("SDMOB"))
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTOAPD",.TXT)
QUIT 0
+12 IF OBNO>MAXOB
IF LVL>1
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTEXOB",,2)
QUIT 0
+13 IF SM=6
IF LVL>1
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTOVBK",,2)
QUIT 0
+14 IF SM=7
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTOVOS",,2)
QUIT 0
+15 IF SM=1
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTCBCP")
QUIT 0
+16 QUIT RETURN
+17 ;
GETOBNO(SC,SD) ; Called by RPC MBAA APPOINTMENT MAKE
+1 NEW IND,CNT,APTS
+2 SET IND=""
SET CNT=0
+3 DO GETDAYA^MBAAMDA1(.APTS,SC,SD)
+4 FOR
SET IND=$ORDER(APTS(IND))
if IND=""
QUIT
if APTS(IND,"OB")>0
SET CNT=CNT+1
+5 QUIT CNT
+6 ;
CHKAPTU(RETURN,SC,DFN,SD,CLN,PAT,UNS) ; Check make unscheduled appointment MBAA RPC: MBAA APPOINTMENT MAKE
+1 NEW PAPT,CLN,TXT
+2 ; get patient data
if '$DATA(PAT)
DO GETPAT^MBAAMDA3(.PAT,DFN,1)
+3 ; get clinic data
if '$DATA(CLN)
DO GETCLN^MBAAMDA1(.CLN,SC,1)
+4 ;check if patient already has appointment
+5 SET PAPT(.01)=""
DO GETPAPT^MBAAMDA2(.PAPT,DFN,SD)
+6 ;ICR#: 10116 VALM1
SET TXT(1)=$$FTIME^VALM1(SD)
+7 IF PAPT(.01)>0
IF $DATA(UNS)
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTPAHU",.TXT)
QUIT RETURN
+8 ;check if patient is dead
+9 IF +$GET(PAT(.351))>0
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"PATDIED")
QUIT RETURN
+10 ;check if clinic is valid (stop code)
+11 SET VAL=$$CLNCK^MBAAMAP1(.RETURN,SC)
if VAL=0
QUIT VAL
+12 ;check inactive clinic period
+13 IF CLN(2505)
IF $PIECE(SD,".")'<CLN(2505)
IF $SELECT('CLN(2506):1,CLN(2506)>$PIECE(SD,".")!('CLN(2506)):1,1:0)
Begin DoDot:1
+14 SET TXT(1)=$$DTS^MBAAMAPI(CLN(2505))
+15 if CLN(2506)
SET TXT(2)=" and reactivated on "_$$DTS^MBAAMAPI(CLN(2506))
+16 SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTCINV",.TXT)
End DoDot:1
QUIT 0
+17 QUIT 1
+18 ;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
+19 ;MAKEUS(RETURN,DFN,SC,SD,TYP,STYP) ; Make unscheduled appointment
+20 ; N SCAP,STAT,CHKIN,%
+21 ; S RETURN=0
+22 ; S %=$$CHKAPTU(.RETURN,SC,DFN,SD,,,1) Q:RETURN=0 0
+23 ; S STAT=$$INP^SDAM2(DFN,SD)
+24 ; D GETCLN^MBAAMDA1(.CLN,SC,1)
+25 ; D MAKE^MBAAMDA3(DFN,SD,SC,TYP,.STYP,STAT,4,DUZ,DT,"W",0)
+26 ; D MAKE^MBAAMDA1(SC,SD,DFN,CLN(1912),,DUZ)
+27 ; S %=$$LOCKST^MBAAMDA1(SC,SD) I '% S RETURN=0 D ERRX^MBAAAPIE(.RETURN,"APTLOCK") Q 0
+28 ; S SM=$$DECAVA(.CLN,SC,SD,CLN(1912),.S)
+29 ; D SETST^MBAAMDA1(SC,SD,S)
+30 ; D UNLCKST^MBAAMDA1(SC,SD)
+31 ; S %=$$GETSCAP^MBAAMAP1(.SCAP,SC,DFN,SD)
+32 ; D MAKE^SDAMEVT(DFN,SD,SC,SCAP("IFN"))
+33 ; Q 1
+34 ; ;
MAKE(RETURN,DFN,SC,SD,TYPE,STYP,LEN,SRT,OTHR,CIO,LAB,XRAY,EKG,RQXRAY,CONS,LVL,DESDT) ; Make appointment Called by RPC MBAA APPOINTMENT MAKE
+1 NEW %
+2 ;IF WE NEED TO CHECK FOR DEPARTMENT OF DEFENSE PUT IN THE CODE TO DO THE TASKS BELOW
+3 ;I DUZ="" THEN SET DUZ FOR DEPARTMENT OF DEFENSE
+4 ;S REC=$O(^VA(200,"B","DEPARTMENT OF DEFENSE,USER",""))
+5 ;I REC'>0 SEND ERROR MESSAGE THAT THE DEPARTMENT OF DEFENSE,USER DOESN'T EXIST ON THE SYSTEM
+6 ;I REC>0 S DUZ=REC D CLNRGHT^MBAAMRP1(.RETURN,SC) I RETURN(0)=1 S RETURN="0^RESTRICED CLINIC, USER NOT ALLOWED TO BOOK APPTS IN THIS CLINIC" Q
+7 ;CALL VERIFY CLINIC ACCESS
+8 ;Q:IF NOT ACCESS
+9 if '$GET(LVL)
SET LVL=7
+10 SET RETURN=1
+11 FOR I="SC","DFN","SD","LEN"
IF '$DATA(@I)
SET RETURN=0
SET TXT(1)=I
DO ERRX^MBAAAPIE(.RETURN,"INVPARAM",.TXT)
+12 IF RETURN=0
QUIT 0
+13 SET %=$$CHKAPP(.RETURN,SC,DFN,SD,LEN,LVL)
+14 IF RETURN=0
IF $PIECE(RETURN(0),U,3)'>LVL
QUIT RETURN(0)
+15 IF RETURN=0
IF $PIECE(RETURN(0),U)="PATDIED"
QUIT RETURN(0)
+16 ;MBAA*1*5 - RETURN ERROR ON DUPLICATE DATE/TIME - REMOVE CANCEL AND REMAKE
+17 ;I RETURN=0,$P(RETURN(0),U)="APTPAHA" D
+18 ;. S %=$$CANCEL(.RETURN,DFN,SC,SD,"C",13,"")
+19 IF RETURN=0
IF $PIECE(RETURN(0),U)="APTPAHA"
QUIT RETURN(0)
+20 IF '$TEST
if '$GET(RETURN)&('$GET(LVL))
QUIT 0
+21 NEW CLN,S,SM,SDY,SCAP,SRT0
+22 SET %=$$LOCKST^MBAAMDA1(SC,SD)
IF '%
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTLOCK")
QUIT 0
+23 SET %=$$LOCKS^MBAAMDA1(SC,SD)
IF '%
SET RETURN=0
DO ERRX^MBAAAPIE(.RETURN,"APTLOCK")
QUIT 0
+24 DO GETCLN^MBAAMDA1(.CLN,SC,1)
+25 SET SM=$$DECAVA(.CLN,SC,SD,+LEN,.S)
+26 DO SETST^MBAAMDA1(SC,SD,S)
+27 DO MAKE^MBAAMDA1(SC,SD,DFN,+LEN,SM,DUZ,$GET(OTHR),.RQXRAY)
+28 DO UNLCKS^MBAAMDA1(SC,SD)
+29 DO UNLCKST^MBAAMDA1(SC,SD)
+30 ;ICR#: 6054 MBAA USE OF SDAM2 API get inpatient data
SET STAT=$$INP^SDAM2(DFN,SD)
+31 if SD<DT
SET SRT="W"
+32 ;ICR#: 6049 MBAA SDMANA API USE
SET SRT0=$$NAVA^SDMANA(SC,SD,.SRT)
+33 DO MAKE^MBAAMDA3(DFN,SD,SC,.TYPE,.STYP,STAT,3,DUZ,DT,SRT,SRT0,.LAB,.XRAY,.EKG,$GET(DESDT))
+34 ;
+35 ;WCJ;MBAA*1*7;This has previously been commented out. Took out the set of field 27 (it was set in line above)
+36 ;and sped up the call to get encounters to make below function useable
+37 ; S DATA(27)=DT,
NEW DATA
+38 SET DATA(28)=$$PTFU^MBAAMAP1(,DFN,SC)
+39 DO UPDPAPT^MBAAMDA4(.DATA,DFN,SD)
+40 ;
+41 SET %=$$GETSCAP^MBAAMAP1(.SCAP,SC,DFN,SD)
+42 IF $GET(CONS)>0
SET DATA(688)=CONS
+43 DO UPDCAPT^MBAAMDA4(.DATA,SC,SD,$GET(SCAP("IFN")))
+44 ;SD/478
if $GET(CONS)>0
SET %=$$EDITCS^MBAAAPI1(.RETURN,CONS,SD,.OTHR,$GET(CLN("NAME")))
+45 ;ICR#: 6048 SDAMEVT
DO MAKE^SDAMEVT(DFN,SD,SC,$GET(SCAP("IFN")),2)
+46 ;alb/sat 4 - begin mod to update SDEC files
+47 NEW SDAPTYP,SDECAR,SDECR,SDRES,SDRQTYP,SDSTAT
+48 SET CONS=$GET(CONS)
+49 ;build SDEC APPT REQUEST entry
if 'CONS
SET SDECAR=$$SDWLA^SDM1A(DFN,SD,SC,DESDT,TYPE)
+50 SET SDAPTYP=$SELECT(+CONS:"C|"_CONS,1:"A|"_SDECAR)
+51 SET SDRES=$$GETRES^SDECUTL(SC)
+52 DO PCSTGET^SDEC(.SDECR,DFN,SC)
SET SDSTAT=$PIECE(@SDECR@(1),$CHAR(30,31),1)
SET SDECR=$SELECT($PIECE(SDSTAT,U,2)="YES":"E",1:"N")
+53 ;add SDEC APPOINTMENT entry
DO SDECADD^SDEC07(SD,,DFN,SDRES,0,$GET(DESDT),"",SDAPTYP,,SC,$GET(OTHR),,SDRES,TYPE,SDECR)
+54 ;alb/sat 4 - end mod
+55 IF $DATA(CIO)
IF CIO="CI"
SET %=$$CHECKIN^MBAAMAP2(.CHKIN,DFN,SD,SC,SD)
+56 KILL CHKIN,DATA,STAT
+57 QUIT 1
+58 ;
DECAVA(CLN,SC,SD,LEN,PATT) ; Decrease availability Called by RPC MBAA APPOINTMENT MAKE
+1 NEW AV,S,SB,X,Y,I,SS,ST,STR,STARTDAY,HSI,SI,SDDIF,SM,CAN,SDNOT
+2 SET SM=0
SET CAN=0
+3 DO GETPATT^MBAAMDA1(.AV,SC,SD)
+4 SET S=$GET(AV(0))
SET SB=CLN(1914)
+5 SET STARTDAY=$SELECT($LENGTH(SB):SB,1:8)
SET SB=STARTDAY-1/100
+6 SET X=CLN(1917)
SET HSI=$SELECT(X=1:X,X:X,1:4)
SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
+7 SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
+8 SET I=SD#1-SB*100
SET ST=I#1*SI\.6+($PIECE(I,".")*SI)
SET SS=LEN*HSI/60*SDDIF+ST+ST
+9 IF SM<7
SET %=$FIND(S,"[",SS-1)
if '%!(CLN(1917)<3)
SET %=999
IF $FIND(S,"]",SS)'<%!(SDDIF=2&$EXTRACT(S,ST+ST+1,SS-1)["[")
SET SM=7
+10 IF ST+ST>$LENGTH(S)
IF $LENGTH(S)<80
SET S=S_" "
+11 ;SD*5.3*490 naked Do added below
SET SDNOT=1
+12 FOR I=ST+ST:SDDIF:SS-SDDIF
SET ST=$EXTRACT(S,I+1)
if ST=""
SET ST=" "
SET Y=$EXTRACT(STR,$FIND(STR,ST)-2)
if S["CAN"!(ST="X"&($DATA(AV(1))))
SET CAN=1
if CAN
QUIT
if Y'?1NL&(SM<6)
SET SM=6
SET ST=$EXTRACT(S,I+2,999)
Begin DoDot:1
+13 if ST'=""
QUIT
+14 if +LEN'>CLN(1912)
QUIT
+15 SET ST=" "
+16 QUIT
End DoDot:1
if ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I)_Y_ST
+17 SET PATT=S
+18 if CAN
QUIT CAN
+19 QUIT SM
+20 ;
CANCEL(RETURN,DFN,SC,SD,TYP,RSN,RMK) ; Cancel appointment Called by RPC MBAA APPOINTMENT MAKE
+1 NEW CDATE,CDT,ERR,ODT,OIFN,OUSR,%
+2 SET RETURN=0
+3 SET %=$$CHKCAN^MBAAMAP3(.RETURN,DFN,SC,SD)
if RETURN=0
QUIT 0
+4 ;ICR#: 10103 XLFDT
SET CDATE=$$NOW^XLFDT
+5 SET %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
+6 SET CIFN=CAPT("IFN")
+7 SET OUSR=CAPT("USER")
SET ODT=CAPT("DATE")
+8 NEW SDATA,SDCPHDL
+9 ;ICR#: 5838 SDAMEVT
SET SDCPHDL=$$HANDLE^SDAMEVT(1)
+10 ;ICR#: 5835 SDAMEVT
DO BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCPHDL)
+11 ;ICR#: 10103 XLFDT
SET CDT=$$NOW^XLFDT()
+12 DO CANCEL^MBAAMDA3(.ERR,DFN,SD,TYP,RSN,RMK,$EXTRACT(CDT,1,12),DUZ,OUSR,ODT)
+13 SET OIFN=$$COVERB^MBAAMDA1(SC,SD,CIFN)
+14 SET %=$$CANCEL^MBAAAPI1(RETURN,CAPT("CONSULT"),SC,SD,CIFN,RMK,TYP)
+15 DO CANCEL^MBAAMDA1(SC,SD,DFN,CIFN)
+16 ;ICR#: 6048 MBAA SDAMEVT API CALLS
DO CANCEL^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,0,SDCPHDL)
+17 SET RETURN=1
KILL CIFN
+18 QUIT RETURN
+19 ;
CHECKIN(RETURN,DFN,SD,SC,CIDT) ; Check in appointment Called by RPC MBAA APPOINTMENT MAKE
+1 NEW CAPT,CI,%
+2 SET CI=DT
+3 if $DATA(CIDT)
SET CI=CIDT
+4 SET %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
+5 IF $GET(CAPT(0))=""
DO ERRX^MBAAAPIE(.RETURN,"APTWHEN")
QUIT 0
+6 SET CIFN=$GET(CAPT("IFN"))
+7 IF 'CIFN
DO ERRX^MBAAAPIE(.RETURN,"APTWHEN")
QUIT 0
+8 NEW SDATA,SDCIHDL,X
+9 ;ICR#: 5835 SDAMEVT
SET SDATA=CIFN_U_DFN_U_SD_U_SC
SET SDCIHDL=$$HANDLE^SDAMEVT(1)
+10 ;ICR#: 5838 SDAMEVT
DO BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCIHDL)
+11 SET %=$$CHKCIN^MBAAMAP3(.RETURN,DFN,SD,+SDATA("BEFORE","STATUS"))
if '%
QUIT 0
+12 SET CD(302)=DUZ
SET CD(309)=CI
+13 DO UPDCAPT^MBAAMDA4(.CD,SC,SD,CAPT("IFN"))
+14 ;ICR#: 5838 SDAMEVT
DO AFTER^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDCIHDL)
+15 MERGE RETURN=SDATA
+16 IF SDATA("BEFORE","STATUS")'=SDATA("AFTER","STATUS")
Begin DoDot:1
+17 ; 4 := ci evt , 0 := interactive mode ;ICR#: 5838 SDAMEVT
DO EVT^SDAMEVT(.SDATA,4,0,SDCIHDL)
End DoDot:1
+18 KILL CD,CIFN
+19 QUIT 1
+20 ;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
+21 ;Linetag NOSHOW is not needed until the next enhancement of MBAA
+22 ;NOSHOW(RETURN,DFN,SC,SD,LVL) ; No-show appointment
+23 ;N APT0,STATUS,APTSTAT,AUTO,CNSTLNK,NSDA,NSDIE,%
+24 ;S:'$D(LVL) LVL=7
+25 ;S APT0=$$GETAPT0^MBAAMDA2(DFN,SD)
+26 ;S APTSTAT=$P(APT0,U,2)
+27 ;S STATUS=$$STATUS^SDAM1(DFN,SD,+$G(APT0),$G(APT0))
+28 ;S RETURN=0
+29 ;S %=$$CHKNS^MBAAMAP3(.RETURN,APT0,+STATUS,LVL)
+30 ;I RETURN=0,$P(RETURN(0),U,3)'>LVL Q RETURN
+31 ;N FDA,CIFN,CAPT
+32 ;S %=$$GETSCAP^MBAAMAP1(.CAPT,SC,DFN,SD)
+33 ;S CIFN=CAPT("IFN")
+34 ;S CNSTLNK=$G(CAPT("CONSULT"))
+35 ;S RETURN("BEFORE")=STATUS
+36 ;N SDNSHDL S SDNSHDL=$$HANDLE^SDAMEVT(1)
+37 ;D BEFORE^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,SDNSHDL)
+38 ;I APTSTAT=""!(APTSTAT="NT") D
+39 ;. S FDA(3)="N",FDA(14)=DUZ,FDA(15)=$$NOW^XLFDT()
+40 ;E D
+41 ;. S FDA(3)="@",FDA(14)="@",FDA(15)="@"
+42 ;D UPDPAPT^MBAAMDA4(.FDA,DFN,SD)
+43 ;D NOSHOW^SDAMEVT(.SDATA,DFN,SD,SC,CIFN,2,SDNSHDL)
+44 ;S:+$G(CNSTLNK) %=$$NOSHOW^MBAAAPI1(.RETURN,SC,SD,DFN,CNSTLNK,CIFN)
+45 ;S APT0=$$GETAPT0^MBAAMDA2(DFN,SD)
+46 ;S APTSTAT=$P(APT0,U,2)
+47 ;S STATUS=$$STATUS^SDAM1(DFN,SD,+$G(APT0),$G(APT0))
+48 ;S RETURN("AFTER")=STATUS
+49 ;Q 1
