SDM3 ;SF/GFT - MAKE APPOINTMENT ; 14 SEP 84 11:33 am
;;5.3;Scheduling;**32,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 11/30/2000 changed $N to $O
; 12/13/2000 added master overbook access by clinic check
;
;S I=$P(SD,".",1),(S,ST)=$P(SL,U,7) I ST F D=I-.01:0 S D=$N(^SC(SC,"S",D)) Q:$P(D,".",1)-I F %=0:0 S %=$N(^SC(SC,"S",D,1,%)) Q:%'>0 I $P(^(%,0),"^",9)'["C",$D(^("OB")) S ST=ST-1 ;IHS/ANMC/LJF 11/30/2000
S I=$P(SD,".",1),(S,ST)=$P(SL,U,7) 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:%'>0 I $P(^(%,0),"^",9)'["C",$D(^("OB")) S ST=ST-1 ;IHS/ANMC/LJF 11/30/2000 $N->$O
;I ST<1,'$D(^XUSEC("SDMOB",DUZ)) W !,*7,"ONLY "_S_" OVERBOOK"_$E("S",S>1)_" ALLOWED PER DAY!!",! G ^SDM1 ;IHS/ANMC/LJF 12/13/2000
I ST<1,'$$MOVBKUSR^BSDU(DUZ,+SC) W !,*7,"ONLY "_S_" OVERBOOK"_$E("S",S>1)_" ALLOWED PER DAY!!",! G ^SDM1 ;IHS/ANMC/LJF 12/13/2000
I ST<1 R !,"WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS, OK? YES// ",MXO:DTIME S:MXO="" MXO="Y" S MXO=$$UP^XLFSTR(MXO) G:MXO'["Y" ^SDM1 S S=^SC(SC,"ST",I,1),SM=9,MXOK="" G SC^SDM1
S S=^SC(SC,"ST",I,1) G E^SDM1
ORDY S Y=SD D DTS^SDUTL S SODT=Y,(LAB,XRAY,EKG)="",SDWR=0
ORD R !,"ENTER TYPE AND TIME (I.E. 'LAB@8:30'): ",ORD:DTIME G:ORD=""!(ORD="^") END
S ORD=$$UP^XLFSTR(ORD)
I ORD'["LAB"&(ORD'["XRAY")&(ORD'["X-RAY")&(ORD'["EKG") W !,"ENTER EITHER 'LAB', 'XRAY', OR 'EKG' FOLLOWED BY THE '@' AND THE TIME" G ORD
I '$F(ORD,"@") W !,"MUST ENTER THE '@' AFTER THE TYPE AND BEFORE THE TIME",*7 G ORD
S SDDT=SODT_"@"_$P(ORD,"@",2),X=SDDT,%DT="XT" D ^%DT G:Y<0 ERR
I $D(^DPT(DFN,"S",Y,0)),"I"[$P(^(0),U,2) S HSC=+^(0) W !,*7,"PATIENT ALREADY HAS APPOINTMENT AT THAT TIME IN ",$P(^SC(HSC,0),"^",1) G ORD
S:ORD["LAB" LAB=Y S:ORD["EKG" EKG=Y S:ORD["XRAY"!(ORD["X-RAY") XRAY=Y S SDWR=1 W " SCHEDULED" G ORD
ERR W !,"ENTER EITHER 'LAB', 'XRAY', OR 'EKG' FOLLOWED BY AN '@' AND THE TIME" G ORD
END I 'SDWR K SDWR,LAB,ORD,SDDT,SODT,XRAY,EKG D CLEAN Q
F SDTY="LAB","XRAY","EKG" I @SDTY="" K @SDTY
S SDIE=$S($D(LAB):LAB,$P(^DPT(DFN,"S",SD,0),U,3)]"":$P(^(0),U,3),1:"")_"^"_$S($D(XRAY):XRAY,$P(^DPT(DFN,"S",SD,0),U,4)]"":$P(^(0),U,4),1:"")_"^"_$S($D(EKG):EKG,$P(^DPT(DFN,"S",SD,0),U,5)]"":$P(^(0),U,5),1:""),$P(^DPT(DFN,"S",SD,0),"^",3,5)=SDIE
K SDIE,SDWR,LAB,ORD,SDDT,SODT,XRAY,EKG,SDDISP
CLEAN K A,CKDATE,CNT,COV,DISBEG,ENDATE,FND,GOT,HNDATE,HSI,HSTM,HY,I,INC,INCM,J,K,LEN,MIN,NDATE,NS,NSTM,REM,SB,SD1,SDATE,SDCT,SDDIF,SDDOT,SDDT,SDHX,SDJ,SDLN,SDMAX,SDSOH,SI,SL,SM,SS,SSC,ST,SDSTRTDT,STARTDAY,STIME,STM,STR
K WY,XX,Z Q
EN1 S SDDISP="" I $D(^DPT(DFN,.321)) F SDI=1:1:3 I $P(^DPT(DFN,.321),"^",SDI)["Y" S SDDISP=1 Q
S DIV=1 I $S($D(^DIC(4,+$$SITE^VASITE,"DIV")):1,1:0),^("DIV")="Y",$P(^SC(SC,0),"^",15)]"" S DIV=$P(^(0),"^",15)
;I SDDISP W:'$D(SDAUTO) !,*7,"This appointment needs special survey dispositioning" S:'$D(^DPT("ASDPSD","B"," "_DIV,$P(SD,"."),DFN)) ^(DFN)=0 S:'$D(^DPT("ASDPSD","C"," "_DIV,SC,SD,DFN)) ^(DFN)=$S($P(SD,".")-DT:"",1:"E")
I SDDISP S:'$D(^DPT("ASDPSD","B"," "_DIV,$P(SD,"."),DFN)) ^(DFN)=0 S:'$D(^DPT("ASDPSD","C"," "_DIV,SC,SD,DFN)) ^(DFN)=$S($P(SD,".")-DT:"",1:"E")
K SDI,SDDISP,SDAUTO Q
EN1K Q:$S('$D(^DPT(X,.321)):1,^(.321)'["Y":1,1:0)
S SDIV=1 I $S($D(^DIC(4,+$$SITE^VASITE,"DIV")):1,1:0),^("DIV")="Y",$P(^SC(DA(2),0),"^",15)]"" S SDIV=$P(^(0),"^",15)
S SDDISP="" F I=1:1:3 I $P(^DPT(X,.321),"^",I)["Y" S SDDISP=1 Q
Q:'SDDISP S DFN=X,S=DA(1) S:$D(DIV) DIV1=DIV S DIV=SDIV K ^DPT("ASDPSD","C"," "_DIV,DA(2),DA(1),X) D CK1^SDM2 S:$D(DIV1) DIV=DIV1 Q
SDM3 ;SF/GFT - MAKE APPOINTMENT ; 14 SEP 84 11:33 am
+1 ;;5.3;Scheduling;**32,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/30/2000 changed $N to $O
+3 ; 12/13/2000 added master overbook access by clinic check
+4 ;
+5 ;S I=$P(SD,".",1),(S,ST)=$P(SL,U,7) I ST F D=I-.01:0 S D=$N(^SC(SC,"S",D)) Q:$P(D,".",1)-I F %=0:0 S %=$N(^SC(SC,"S",D,1,%)) Q:%'>0 I $P(^(%,0),"^",9)'["C",$D(^("OB")) S ST=ST-1 ;IHS/ANMC/LJF 11/30/2000
+6 ;IHS/ANMC/LJF 11/30/2000 $N->$O
SET I=$PIECE(SD,".",1)
SET (S,ST)=$PIECE(SL,U,7)
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 %'>0
QUIT
IF $PIECE(^(%,0),"^",9)'["C"
IF $DATA(^("OB"))
SET ST=ST-1
+7 ;I ST<1,'$D(^XUSEC("SDMOB",DUZ)) W !,*7,"ONLY "_S_" OVERBOOK"_$E("S",S>1)_" ALLOWED PER DAY!!",! G ^SDM1 ;IHS/ANMC/LJF 12/13/2000
+8 ;IHS/ANMC/LJF 12/13/2000
IF ST<1
IF '$$MOVBKUSR^BSDU(DUZ,+SC)
WRITE !,*7,"ONLY "_S_" OVERBOOK"_$EXTRACT("S",S>1)_" ALLOWED PER DAY!!",!
GOTO ^SDM1
+9 IF ST<1
READ !,"WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS, OK? YES// ",MXO:DTIME
IF MXO=""
SET MXO="Y"
SET MXO=$$UP^XLFSTR(MXO)
IF MXO'["Y"
GOTO ^SDM1
SET S=^SC(SC,"ST",I,1)
SET SM=9
SET MXOK=""
GOTO SC^SDM1
+10 SET S=^SC(SC,"ST",I,1)
GOTO E^SDM1
ORDY SET Y=SD
DO DTS^SDUTL
SET SODT=Y
SET (LAB,XRAY,EKG)=""
SET SDWR=0
ORD READ !,"ENTER TYPE AND TIME (I.E. 'LAB@8:30'): ",ORD:DTIME
IF ORD=""!(ORD="^")
GOTO END
+1 SET ORD=$$UP^XLFSTR(ORD)
+2 IF ORD'["LAB"&(ORD'["XRAY")&(ORD'["X-RAY")&(ORD'["EKG")
WRITE !,"ENTER EITHER 'LAB', 'XRAY', OR 'EKG' FOLLOWED BY THE '@' AND THE TIME"
GOTO ORD
+3 IF '$FIND(ORD,"@")
WRITE !,"MUST ENTER THE '@' AFTER THE TYPE AND BEFORE THE TIME",*7
GOTO ORD
+4 SET SDDT=SODT_"@"_$PIECE(ORD,"@",2)
SET X=SDDT
SET %DT="XT"
DO ^%DT
IF Y<0
GOTO ERR
+5 IF $DATA(^DPT(DFN,"S",Y,0))
IF "I"[$PIECE(^(0),U,2)
SET HSC=+^(0)
WRITE !,*7,"PATIENT ALREADY HAS APPOINTMENT AT THAT TIME IN ",$PIECE(^SC(HSC,0),"^",1)
GOTO ORD
+6 IF ORD["LAB"
SET LAB=Y
IF ORD["EKG"
SET EKG=Y
IF ORD["XRAY"!(ORD["X-RAY")
SET XRAY=Y
SET SDWR=1
WRITE " SCHEDULED"
GOTO ORD
ERR WRITE !,"ENTER EITHER 'LAB', 'XRAY', OR 'EKG' FOLLOWED BY AN '@' AND THE TIME"
GOTO ORD
END IF 'SDWR
KILL SDWR,LAB,ORD,SDDT,SODT,XRAY,EKG
DO CLEAN
QUIT
+1 FOR SDTY="LAB","XRAY","EKG"
IF @SDTY=""
KILL @SDTY
+2 SET SDIE=$SELECT($DATA(LAB):LAB,$PIECE(^DPT(DFN,"S",SD,0),U,3)]"":$PIECE(^(0),U,3),1:"")_"^"_$SELECT($DATA(XRAY):XRAY,$PIECE(^DPT(DFN,"S",SD,0),U,4)]"":$PIECE(^(0),U,4),1:"")_"^"_$SELECT($DATA(EKG):EKG,...
... $PIECE(^DPT(DFN,"S",SD,0),U,5)]"":$PIECE(^(0),U,5),1:"")
SET $PIECE(^DPT(DFN,"S",SD,0),"^",3,5)=SDIE
+3 KILL SDIE,SDWR,LAB,ORD,SDDT,SODT,XRAY,EKG,SDDISP
CLEAN KILL A,CKDATE,CNT,COV,DISBEG,ENDATE,FND,GOT,HNDATE,HSI,HSTM,HY,I,INC,INCM,J,K,LEN,MIN,NDATE,NS,NSTM,REM,SB,SD1,SDATE,SDCT,SDDIF,SDDOT,SDDT,SDHX,SDJ,SDLN,SDMAX,SDSOH,SI,SL,SM,SS,SSC,ST,SDSTRTDT,STARTDAY,STIME,STM,STR
+1 KILL WY,XX,Z
QUIT
EN1 SET SDDISP=""
IF $DATA(^DPT(DFN,.321))
FOR SDI=1:1:3
IF $PIECE(^DPT(DFN,.321),"^",SDI)["Y"
SET SDDISP=1
QUIT
+1 SET DIV=1
IF $SELECT($DATA(^DIC(4,+$$SITE^VASITE,"DIV")):1,1:0)
IF ^("DIV")="Y"
IF $PIECE(^SC(SC,0),"^",15)]""
SET DIV=$PIECE(^(0),"^",15)
+2 ;I SDDISP W:'$D(SDAUTO) !,*7,"This appointment needs special survey dispositioning" S:'$D(^DPT("ASDPSD","B"," "_DIV,$P(SD,"."),DFN)) ^(DFN)=0 S:'$D(^DPT("ASDPSD","C"," "_DIV,SC,SD,DFN)) ^(DFN)=$S($P(SD,".")-DT:"",1:"E")
+3 IF SDDISP
IF '$DATA(^DPT("ASDPSD","B"," "_DIV,$PIECE(SD,"."),DFN))
SET ^(DFN)=0
IF '$DATA(^DPT("ASDPSD","C"," "_DIV,SC,SD,DFN))
SET ^(DFN)=$SELECT($PIECE(SD,".")-DT:"",1:"E")
+4 KILL SDI,SDDISP,SDAUTO
QUIT
EN1K IF $SELECT('$DATA(^DPT(X,.321))
QUIT
+1 SET SDIV=1
IF $SELECT($DATA(^DIC(4,+$$SITE^VASITE,"DIV")):1,1:0)
IF ^("DIV")="Y"
IF $PIECE(^SC(DA(2),0),"^",15)]""
SET SDIV=$PIECE(^(0),"^",15)
+2 SET SDDISP=""
FOR I=1:1:3
IF $PIECE(^DPT(X,.321),"^",I)["Y"
SET SDDISP=1
QUIT
+3 IF 'SDDISP
QUIT
SET DFN=X
SET S=DA(1)
IF $DATA(DIV)
SET DIV1=DIV
SET DIV=SDIV
KILL ^DPT("ASDPSD","C"," "_DIV,DA(2),DA(1),X)
DO CK1^SDM2
IF $DATA(DIV1)
SET DIV=DIV1
QUIT
