SDMM1.m

SDMM1 ;ALB/GRR - MULTIPLE BOOKINGS ; 2/7/05 8:16am

 ;;5.3;Scheduling;**28,206,168,327,1001,1014,1015**;Aug 13, 1993;Build 21

 ;IHS/ANMC/LJF 7/06/2000 hard set of date appt made now includes time

 ;            12/13/2000 added check for overbook access by clinic

 ;             6/22/2001 added call to create xref on date appt made

 ;ihs/cmi/maw 02/02/2012 patch 1014, changed set of appointment mode to silent fileman call

 ;

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

 ;IHS/ANMC/LJF 7/06/2000;6/22/2001

S1 ;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

 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_$$NOW^XLFDT_U_U_U_$S(+SDEMP:+SDEMP,1:"") D XREFC^BSDDAM(SC,X,Y) 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

 ;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_"^^^"_$$NOW^XLFDT_"^^^^^^M^0",SDMADE=1   ;IHS/ANMC/LJF 7/06/2000

 S COV=3,SDYC="",COV=$S(COLLAT=1:1,1:3),SDYC=$S(COLLAT=7:1,1:"")  ;ihs/cmi/maw 2/2/2012 moved to itself patch 1014

 D SDM^BSDMMU(COV,SDYC,DFN,X,SC,SDINP,SDAPTYP,"","","M",0,"","",.BSDER)  ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling

 I $G(BSDER)]"" W !,"Error making appointment in file 2.98" Q  ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling

 ;D XRDT(DFN,X)  ;xref DATE APPT. MADE field  ihs/cmi/maw 2/2/2012 patch 1014 not used after 1013

 S SDMADE=1  ;ihs/cmi/maw 05/14/2012 fix for multiple appt bookings

 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

 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  ;IHS/ANMC/LJF 12/13/2000

 . I '$$MOVBKUSR^BSDU(DUZ,+SC) W !,*7,"ONLY "_S_" OVERBOOK"_$E("S",S>1)_" ALLOWED PER DAY!!" D NOOB Q  ;IHS/ANMC/LJF 12/13/2000

 . 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

SDMM1     ;ALB/GRR - MULTIPLE BOOKINGS ; 2/7/05 8:16am

 +1       ;;5.3;Scheduling;**28,206,168,327,1001,1014,1015**;Aug 13, 1993;Build 21

 +2       ;IHS/ANMC/LJF 7/06/2000 hard set of date appt made now includes time

 +3       ;            12/13/2000 added check for overbook access by clinic

 +4       ;             6/22/2001 added call to create xref on date appt made

 +5       ;ihs/cmi/maw 02/02/2012 patch 1014, changed set of appointment mode to silent fileman call

 +6       ;

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 

 +1       ;IHS/ANMC/LJF 7/06/2000;6/22/2001

S1        ;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

 +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_$$NOW^XLFDT_U_U_U_$S(+SDEMP:+SDEMP,1:"")

                   DO XREFC^BSDDAM(SC,X,Y)

                   SET SDY=Y

                   LOCK 

                   QUIT 

 +2       ;

 +3       ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,"OB")

           IF SM

               SET ^("OB")="O"

 +4        IF $DATA(^SC(SC,"RAD"))

               IF ^("RAD")="Y"!(^("RAD")=1)

                   SET ^SC("ARAD",SC,X,DFN)=""

 +5        SET SDINP=$$INP^SDAM2(DFN,X)

 +6       ;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

 +7       ;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_"^^^"_$$NOW^XLFDT_"^^^^^^M^0",SDMADE=1   ;IHS/ANMC/LJF 7/06/2000

 +8       ;ihs/cmi/maw 2/2/2012 moved to itself patch 1014

           SET COV=3

           SET SDYC=""

           SET COV=$SELECT(COLLAT=1:1,1:3)

           SET SDYC=$SELECT(COLLAT=7:1,1:"")

 +9       ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling

           DO SDM^BSDMMU(COV,SDYC,DFN,X,SC,SDINP,SDAPTYP,"","","M",0,"","",.BSDER)

 +10      ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling

           IF $GET(BSDER)]""

               WRITE !,"Error making appointment in file 2.98"

               QUIT 

 +11      ;D XRDT(DFN,X)  ;xref DATE APPT. MADE field  ihs/cmi/maw 2/2/2012 patch 1014 not used after 1013

 +12      ;ihs/cmi/maw 05/14/2012 fix for multiple appt bookings

           SET SDMADE=1

 +13       IF $DATA(^DPT("ASDCN",SC,X,DFN))

               KILL ^(DFN)

           IF $DATA(^DPT(DFN,"S",X,"R"))

               KILL ^("R")

 +14       SET SDRT="A"

           SET SDTTM=X

           SET SDPL=SDY

           SET SDSC=SC

           DO RT^SDUTL

 +15       LOCK 

           WRITE !,"APPOINTMENT MADE ON "

           SET Y=X

           DO DT^DIQ

 +16      ;check for open EWL entries and create TMP($J,"APPT";SD/327

 +17       NEW SDEV,SD

           DO EN^SDWLEVAL(DFN,.SDEV)

           SET SD=X

           IF SDEV

               DO APPT^SDWLEVAL(DFN,SD,SC)

 +18       DO EVT

 +19       QUIT 

 +20      ;

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       ;I '$D(^XUSEC("SDMOB",DUZ)) W !,*7,"ONLY "_S_" OVERBOOK"_$E("S",S>1)_" ALLOWED PER DAY!!" D NOOB Q  ;IHS/ANMC/LJF 12/13/2000

 +8       ;IHS/ANMC/LJF 12/13/2000

                   IF '$$MOVBKUSR^BSDU(DUZ,+SC)

                       WRITE !,*7,"ONLY "_S_" OVERBOOK"_$EXTRACT("S",S>1)_" ALLOWED PER DAY!!"

                       DO NOOB

                       QUIT 

 +9                SET MXOK=$$DIR("WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS FOR "_$$FMTE^XLFDT(Y)_", OK","YES")

 +10               IF 'MXOK

                       SET SM=9

                       SET SDNOT=0

                       QUIT 

 +11               IF MXOK

                       SET S=^SC(SC,"ST",I,1)

                       SET SM=9

                       SET MXOK=""

               End DoDot:1

               GOTO OBQ

 +12       IF '$DATA(^XUSEC("SDOB",DUZ))

               DO NOOB

               GOTO OBQ

 +13       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