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

SDMM1.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/ANMC/LJF 7/06/2000 hard set of date appt made now includes time
  1.  ;            12/13/2000 added check for overbook access by clinic
  1.  ;             6/22/2001 added call to create xref on date appt made
  1.  ;ihs/cmi/maw 02/02/2012 patch 1014, changed set of appointment mode to silent fileman call
  1.  ;
  1. 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
  1.  S SDX7=X D SDFT^SDMM S X=SDX7 I $P(SDX3,".")'<SDEDT W !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7 Q
  1. 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,".")
  1. 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
  1.  G X:POP,OK:SM#9=0 S SDY=Y,Y=X
  1.  ;
  1.  D OB I SDNOT=0 Q  ; check overbook/keys...quit if not ok
  1.  S SM=9 G SC
  1.  ;
  1. 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
  1.  ;IHS/ANMC/LJF 7/06/2000;6/22/2001
  1. 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.  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
  1.  ;
  1.  I SM S ^("OB")="O" ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,"OB")
  1.  I $D(^SC(SC,"RAD")),^("RAD")="Y"!(^("RAD")=1) S ^SC("ARAD",SC,X,DFN)=""
  1.  S SDINP=$$INP^SDAM2(DFN,X)
  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_"^^^"_DT_"^^^^^^M^0",SDMADE=1
  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
  1.  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
  1.  D SDM^BSDMMU(COV,SDYC,DFN,X,SC,SDINP,SDAPTYP,"","","M",0,"","",.BSDER)  ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling
  1.  I $G(BSDER)]"" W !,"Error making appointment in file 2.98" Q  ;ihs/cmi/maw 2/2/2012 patch 1014 for GUI Scheduling
  1.  ;D XRDT(DFN,X)  ;xref DATE APPT. MADE field  ihs/cmi/maw 2/2/2012 patch 1014 not used after 1013
  1.  S SDMADE=1  ;ihs/cmi/maw 05/14/2012 fix for multiple appt bookings
  1.  K:$D(^DPT("ASDCN",SC,X,DFN)) ^(DFN) K:$D(^DPT(DFN,"S",X,"R")) ^("R")
  1.  S SDRT="A",SDTTM=X,SDPL=SDY,SDSC=SC D RT^SDUTL
  1.  L  W !,"APPOINTMENT MADE ON " S Y=X D DT^DIQ
  1.  ;check for open EWL entries and create TMP($J,"APPT";SD/327
  1.  N SDEV,SD D EN^SDWLEVAL(DFN,.SDEV) S SD=X I SDEV D APPT^SDWLEVAL(DFN,SD,SC)
  1.  D EVT
  1.  Q
  1.  ;
  1. XRDT(DFN,X) ;cross reference DATE APPT. MADE field
  1.  ;Input: DFN=patient ifn
  1.  ;Input: X=appointment date
  1.  N DIK,DA,DIV S DA=X,DA(1)=DFN
  1.  S DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
  1.  Q
  1.  ;
  1. NOOB S SDMES="NO OPEN SLOTS ON "
  1. WRTER W !,SDMES D DT W:SDNOT " AT THAT TIME" S SDNOT=0 Q
  1. DT W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(X,4,5))," ",$E(X,6,7) Q
  1. DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
  1.  ;
  1. X L  I SDZ=1 W !,*7,"CLINIC DOES NOT MEET THEN!!" S SDERRFT=1 Q
  1.  S SDMES="CLINIC DOES NOT MEET ON " G WRTER
  1.  ;
  1. EVT ; -- separate tag if need to NEW vars
  1.  N D,SI,SC,SL,COLLAT D MAKE^SDAMEVT(DFN,SDTTM,SDSC,SDPL,0)
  1.  Q
  1.  ;
  1. OB ; check for overbook keys
  1.  N %,D,I,S,ST
  1.  S SDNOT=1
  1.  I '$D(^XUSEC("SDOB",DUZ)),'$D(^XUSEC("SDMOB",DUZ)) D NOOB G OBQ ; user has neither key
  1.  S I=$P(SD,".",1),(S,ST)=$P(SL,U,7) ; counter of OBs for day = ST
  1.  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
  1.  I ST<1 D  G OBQ
  1.  . ;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
  1.  . 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
  1.  . S MXOK=$$DIR("WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS FOR "_$$FMTE^XLFDT(Y)_", OK","YES")
  1.  . I 'MXOK S SM=9,SDNOT=0 Q
  1.  . I MXOK S S=^SC(SC,"ST",I,1),SM=9,MXOK=""
  1.  I '$D(^XUSEC("SDOB",DUZ)) D NOOB G OBQ
  1.  I '$$DIR($$FMTE^XLFDT(Y)_" WILL BE AN OVERBOOK, OK","NO") S SM=9,SDNOT=0
  1. OBQ Q
  1.  ;
  1. DIR(TEXT,DEF) ; reader processor
  1.  ; Input:  TEXT as text of read
  1.  ;         DEF as default response (if any)
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="Y",DIR("A")=TEXT
  1.  I $G(DEF)]"" S DIR("B")=DEF
  1.  D ^DIR
  1.  W:'Y !
  1.  Q Y