SDMM1 ;ALB/GRR - MULTIPLE BOOKINGS ;JUN 21, 2017
;;5.3;Scheduling;**28,206,168,327,622,645,658,665**;Aug 13, 1993;Build 14
MAKE S (SDX3,X,SD)=Y,SM=0 D DOW^SDM0 I $D(^DPT(DFN,"S",X)) S I=^(X,0) I $P(I,"^",2)'["C" W !,"PATIENT ALREADY HAS APPOINTMENT ON ",$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(X,4,5))," ",$E(X,6,7)," AT THAT TIME" Q
S SDX7=X D SDFT^SDMM S X=SDX7 I $P(SDX3,".")'<SDEDT W !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7 Q
S S SDNOT=0 I '$D(^SC(SC,"ST",$P(X,"."),1)) S SS=$O(^SC(+SC,"T"_Y,X)) G X:'SS,X:^(SS,1)="" S ^SC(+SC,"ST",$P(X,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(X,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(X,".")
SC S POP=0,SD=X D SC^SDM1 I SDLOCK W ! D DT W " HAS BEEN LOCKED BY ANOTHER USER - APPT NOT BOOKED" L Q
G X:POP,OK:SM#9=0 S SDY=Y,Y=X
;
D OB I SDNOT=0 Q ; check overbook/keys...quit if not ok
S SM=9 G SC
;
OK S ^SC(SC,"ST",$P(X,"."),1)=S,^SC(SC,"S",X,0)=X S:'$D(^DPT(DFN,"S",0)) ^(0)="^2.98^^" S:'$D(^SC(SC,"S",0)) ^(0)="^44.001DA^^" L
S1 ;alb/sat 658 - needs to be incremental lock - added + 'L +^SC(SC,...'
L +^SC(SC,"S",X,1):5 G:'$T S1 F Y=1:1 I '$D(^SC(SC,"S",X,1,Y)) S:'$D(^(0)) ^(0)="^44.003PA^^" S ^(Y,0)=DFN_U_(+SL)_U_U_D_U_U_$S($D(DUZ):DUZ,1:"")_U_DT_U_U_U_$S(+SDEMP:+SDEMP,1:"") S SDY=Y L Q
I SM S ^("OB")="O" ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,"OB")
I $D(^SC(SC,"RAD")),^("RAD")="Y"!(^("RAD")=1) S ^SC("ARAD",SC,X,DFN)=""
S SDINP=$$INP^SDAM2(DFN,X)
S COV=3,SDYC="",COV=$S(COLLAT=1:1,1:3),SDYC=$S(COLLAT=7:1,1:""),^DPT(DFN,"S",X,0)=SC_"^"_$$STATUS^SDM1A(SC,SDINP,X)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_"^^^"_DT_"^^^^^^M^0",SDMADE=1
; SD*5.3*622 - set desired date for appointment
; SD*5.3*645 - added follow-up indicator, desired date is now also known as CID/Preferred Date
I SDZ>1 S ^DPT(DFN,"S",SD,1)=$P($G(SD),".",1)_U_SDSRFU
E S ^DPT(DFN,"S",SD,1)=SDDATE_U_SDSRFU ; end changes for SD*5.3*645
D XRDT(DFN,X) ;xref DATE APPT. MADE field
K:$D(^DPT("ASDCN",SC,X,DFN)) ^(DFN) K:$D(^DPT(DFN,"S",X,"R")) ^("R")
S SDRT="A",SDTTM=X,SDPL=SDY,SDSC=SC D RT^SDUTL
;update SDEC APPOINTMENT file 409.84 ;alb/sat 658
N SDECAR,SDREC,SDECR
S SDREC=""
I $G(CNSLTLNK)="",$G(SDWL)="" S SDREC=$$RECALL^SDECUTL(DFN,SD,SDSC) ;check if recall appt
I $G(SDWL)="",$G(CNSLTLNK)="",SDREC="" S SDECAR=$$SDWLA^SDM1A(DFN,SDTTM,SC,SDDATE,$G(SDAPTYP),$G(SDECANS)) ;alb/sat 665 add SDECANS
K SDECANS ;alb/sat 665
S SDECR=$$GETRES^SDECUTL(SC)
S SDAPTYP=$G(SDAPTYP) S:SDAPTYP="" SDAPTYP=$$GET1^DIQ(44,SC_",",2507,"I")
D SDECADD^SDEC07(SDTTM,$$FMADD^XLFDT(SDTTM,,,+SL),DFN,SDECR,0,SDDATE,"",$S(+$G(SDWL):"E|"_SDWL,+$G(CNSLTLNK):"C|"_CNSLTLNK,+SDREC:"R|"_SDREC,+SDECAR:"A|"_SDECAR,1:""),,SC,$G(D),,SDECR,SDAPTYP) ;ADD SDEC APPOINTMENT ENTRY ;alb/sat 658
;alb/sat 658 end modification
L W !,"APPOINTMENT MADE ON " S Y=X D DT^DIQ
;check for open EWL entries and create TMP($J,"APPT";SD/327
N SDEV,SD D EN^SDWLEVAL(DFN,.SDEV) S SD=X I SDEV D APPT^SDWLEVAL(DFN,SD,SC)
D EVT
Q
;
XRDT(DFN,X) ;cross reference DATE APPT. MADE field
;Input: DFN=patient ifn
;Input: X=appointment date
N DIK,DA,DIV S DA=X,DA(1)=DFN
S DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
Q
;
NOOB S SDMES="NO OPEN SLOTS ON "
WRTER W !,SDMES D DT W:SDNOT " AT THAT TIME" S SDNOT=0 Q
DT W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(X,4,5))," ",$E(X,6,7) Q
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
X L I SDZ=1 W !,*7,"CLINIC DOES NOT MEET THEN!!" S SDERRFT=1 Q
S SDMES="CLINIC DOES NOT MEET ON " G WRTER
;
EVT ; -- separate tag if need to NEW vars
N D,SI,SC,SL,COLLAT D MAKE^SDAMEVT(DFN,SDTTM,SDSC,SDPL,0)
Q
;
OB ; check for overbook keys
N %,D,I,S,ST
S SDNOT=1
I '$D(^XUSEC("SDOB",DUZ)),'$D(^XUSEC("SDMOB",DUZ)) D NOOB G OBQ ; user has neither key
S I=$P(SD,".",1),(S,ST)=$P(SL,U,7) ; counter of OBs for day = ST
I ST F D=I-.01:0 S D=$O(^SC(SC,"S",D)) Q:$P(D,".",1)-I F %=0:0 S %=$O(^SC(SC,"S",D,1,%)) Q:'% I $P(^(%,0),"^",9)'["C",$D(^("OB")) S ST=ST-1
I ST<1 D G OBQ
. I '$D(^XUSEC("SDMOB",DUZ)) W !,*7,"ONLY "_S_" OVERBOOK"_$E("S",S>1)_" ALLOWED PER DAY!!" D NOOB Q
. S MXOK=$$DIR("WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS FOR "_$$FMTE^XLFDT(Y)_", OK","YES")
. I 'MXOK S SM=9,SDNOT=0 Q
. I MXOK S S=^SC(SC,"ST",I,1),SM=9,MXOK=""
I '$D(^XUSEC("SDOB",DUZ)) D NOOB G OBQ
I '$$DIR($$FMTE^XLFDT(Y)_" WILL BE AN OVERBOOK, OK","NO") S SM=9,SDNOT=0
OBQ Q
;
DIR(TEXT,DEF) ; reader processor
; Input: TEXT as text of read
; DEF as default response (if any)
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="Y",DIR("A")=TEXT
I $G(DEF)]"" S DIR("B")=DEF
D ^DIR
W:'Y !
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDMM1 4663 printed Apr 09, 2024@21:54:21 Page 2
SDMM1 ;ALB/GRR - MULTIPLE BOOKINGS ;JUN 21, 2017
+1 ;;5.3;Scheduling;**28,206,168,327,622,645,658,665**;Aug 13, 1993;Build 14
MAKE SET (SDX3,X,SD)=Y
SET SM=0
DO DOW^SDM0
IF $DATA(^DPT(DFN,"S",X))
SET I=^(X,0)
IF $PIECE(I,"^",2)'["C"
WRITE !,"PATIENT ALREADY HAS APPOINTMENT ON ",$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$EXTRACT(X,4,5))," ",$EXTRACT(X,6,7)," AT THAT TIME"
QUIT
+1 SET SDX7=X
DO SDFT^SDMM
SET X=SDX7
IF $PIECE(SDX3,".")'<SDEDT
WRITE !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7
QUIT
S SET SDNOT=0
IF '$DATA(^SC(SC,"ST",$PIECE(X,"."),1))
SET SS=$ORDER(^SC(+SC,"T"_Y,X))
if 'SS
GOTO X
if ^(SS,1)=""
GOTO X
SET ^SC(+SC,"ST",$PIECE(X,"."),1)=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(X,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
SET ^(0)=$PIECE(X,".")
SC SET POP=0
SET SD=X
DO SC^SDM1
IF SDLOCK
WRITE !
DO DT
WRITE " HAS BEEN LOCKED BY ANOTHER USER - APPT NOT BOOKED"
LOCK
QUIT
+1 if POP
GOTO X
if SM#9=0
GOTO OK
SET SDY=Y
SET Y=X
+2 ;
+3 ; check overbook/keys...quit if not ok
DO OB
IF SDNOT=0
QUIT
+4 SET SM=9
GOTO SC
+5 ;
OK SET ^SC(SC,"ST",$PIECE(X,"."),1)=S
SET ^SC(SC,"S",X,0)=X
if '$DATA(^DPT(DFN,"S",0))
SET ^(0)="^2.98^^"
if '$DATA(^SC(SC,"S",0))
SET ^(0)="^44.001DA^^"
LOCK
S1 ;alb/sat 658 - needs to be incremental lock - added + 'L +^SC(SC,...'
+1 LOCK +^SC(SC,"S",X,1):5
if '$TEST
GOTO S1
FOR Y=1:1
IF '$DATA(^SC(SC,"S",X,1,Y))
if '$DATA(^(0))
SET ^(0)="^44.003PA^^"
SET ^(Y,0)=DFN_U_(+SL)_U_U_D_U_U_$SELECT($DATA(DUZ):DUZ,1:"")_U_DT_U_U_U_$SELECT(+SDEMP:+SDEMP,1:"")
SET SDY=Y
LOCK
QUIT
+2 ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,"OB")
IF SM
SET ^("OB")="O"
+3 IF $DATA(^SC(SC,"RAD"))
IF ^("RAD")="Y"!(^("RAD")=1)
SET ^SC("ARAD",SC,X,DFN)=""
+4 SET SDINP=$$INP^SDAM2(DFN,X)
+5 SET COV=3
SET SDYC=""
SET COV=$SELECT(COLLAT=1:1,1:3)
SET SDYC=$SELECT(COLLAT=7:1,1:"")
SET ^DPT(DFN,"S",X,0)=SC_"^"_$$STATUS^SDM1A(SC,SDINP,X)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_"^^^"_DT_"^^^^^^M^0"
SET SDMADE=1
+6 ; SD*5.3*622 - set desired date for appointment
+7 ; SD*5.3*645 - added follow-up indicator, desired date is now also known as CID/Preferred Date
+8 IF SDZ>1
SET ^DPT(DFN,"S",SD,1)=$PIECE($GET(SD),".",1)_U_SDSRFU
+9 ; end changes for SD*5.3*645
IF '$TEST
SET ^DPT(DFN,"S",SD,1)=SDDATE_U_SDSRFU
+10 ;xref DATE APPT. MADE field
DO XRDT(DFN,X)
+11 if $DATA(^DPT("ASDCN",SC,X,DFN))
KILL ^(DFN)
if $DATA(^DPT(DFN,"S",X,"R"))
KILL ^("R")
+12 SET SDRT="A"
SET SDTTM=X
SET SDPL=SDY
SET SDSC=SC
DO RT^SDUTL
+13 ;update SDEC APPOINTMENT file 409.84 ;alb/sat 658
+14 NEW SDECAR,SDREC,SDECR
+15 SET SDREC=""
+16 ;check if recall appt
IF $GET(CNSLTLNK)=""
IF $GET(SDWL)=""
SET SDREC=$$RECALL^SDECUTL(DFN,SD,SDSC)
+17 ;alb/sat 665 add SDECANS
IF $GET(SDWL)=""
IF $GET(CNSLTLNK)=""
IF SDREC=""
SET SDECAR=$$SDWLA^SDM1A(DFN,SDTTM,SC,SDDATE,$GET(SDAPTYP),$GET(SDECANS))
+18 ;alb/sat 665
KILL SDECANS
+19 SET SDECR=$$GETRES^SDECUTL(SC)
+20 SET SDAPTYP=$GET(SDAPTYP)
if SDAPTYP=""
SET SDAPTYP=$$GET1^DIQ(44,SC_",",2507,"I")
+21 ;ADD SDEC APPOINTMENT ENTRY ;alb/sat 658
DO SDECADD^SDEC07(SDTTM,$$FMADD^XLFDT(SDTTM,,,+SL),DFN,SDECR,0,SDDATE,"",$SELECT(+$GET(SDWL):"E|"_SDWL,+$GET(CNSLTLNK):"C|"_CNSLTLNK,+SDREC:"R|"_SDREC,+SDECAR:"A|"_SDECAR,1:""),,SC,$GET(D),,SDECR,SDAPTYP)
+22 ;alb/sat 658 end modification
+23 LOCK
WRITE !,"APPOINTMENT MADE ON "
SET Y=X
DO DT^DIQ
+24 ;check for open EWL entries and create TMP($J,"APPT";SD/327
+25 NEW SDEV,SD
DO EN^SDWLEVAL(DFN,.SDEV)
SET SD=X
IF SDEV
DO APPT^SDWLEVAL(DFN,SD,SC)
+26 DO EVT
+27 QUIT
+28 ;
XRDT(DFN,X) ;cross reference DATE APPT. MADE field
+1 ;Input: DFN=patient ifn
+2 ;Input: X=appointment date
+3 NEW DIK,DA,DIV
SET DA=X
SET DA(1)=DFN
+4 SET DIK="^DPT(DA(1),""S"","
SET DIK(1)=20
DO EN1^DIK
+5 QUIT
+6 ;
NOOB SET SDMES="NO OPEN SLOTS ON "
WRTER WRITE !,SDMES
DO DT
if SDNOT
WRITE " AT THAT TIME"
SET SDNOT=0
QUIT
DT WRITE $PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$EXTRACT(X,4,5))," ",$EXTRACT(X,6,7)
QUIT
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
X LOCK
IF SDZ=1
WRITE !,*7,"CLINIC DOES NOT MEET THEN!!"
SET SDERRFT=1
QUIT
+1 SET SDMES="CLINIC DOES NOT MEET ON "
GOTO WRTER
+2 ;
EVT ; -- separate tag if need to NEW vars
+1 NEW D,SI,SC,SL,COLLAT
DO MAKE^SDAMEVT(DFN,SDTTM,SDSC,SDPL,0)
+2 QUIT
+3 ;
OB ; check for overbook keys
+1 NEW %,D,I,S,ST
+2 SET SDNOT=1
+3 ; user has neither key
IF '$DATA(^XUSEC("SDOB",DUZ))
IF '$DATA(^XUSEC("SDMOB",DUZ))
DO NOOB
GOTO OBQ
+4 ; counter of OBs for day = ST
SET I=$PIECE(SD,".",1)
SET (S,ST)=$PIECE(SL,U,7)
+5 IF ST
FOR D=I-.01:0
SET D=$ORDER(^SC(SC,"S",D))
if $PIECE(D,".",1)-I
QUIT
FOR %=0:0
SET %=$ORDER(^SC(SC,"S",D,1,%))
if '%
QUIT
IF $PIECE(^(%,0),"^",9)'["C"
IF $DATA(^("OB"))
SET ST=ST-1
+6 IF ST<1
Begin DoDot:1
+7 IF '$DATA(^XUSEC("SDMOB",DUZ))
WRITE !,*7,"ONLY "_S_" OVERBOOK"_$EXTRACT("S",S>1)_" ALLOWED PER DAY!!"
DO NOOB
QUIT
+8 SET MXOK=$$DIR("WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS FOR "_$$FMTE^XLFDT(Y)_", OK","YES")
+9 IF 'MXOK
SET SM=9
SET SDNOT=0
QUIT
+10 IF MXOK
SET S=^SC(SC,"ST",I,1)
SET SM=9
SET MXOK=""
End DoDot:1
GOTO OBQ
+11 IF '$DATA(^XUSEC("SDOB",DUZ))
DO NOOB
GOTO OBQ
+12 IF '$$DIR($$FMTE^XLFDT(Y)_" WILL BE AN OVERBOOK, OK","NO")
SET SM=9
SET SDNOT=0
OBQ QUIT
+1 ;
DIR(TEXT,DEF) ; reader processor
+1 ; Input: TEXT as text of read
+2 ; DEF as default response (if any)
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 SET DIR(0)="Y"
SET DIR("A")=TEXT
+6 IF $GET(DEF)]""
SET DIR("B")=DEF
+7 DO ^DIR
+8 if 'Y
WRITE !
+9 QUIT Y
