- SDMULT ;ALB/TMP - MAKE MULTI-CLINIC APPOINTMENTS ; 02 Jan 2000 6:30 PM
- ;;5.3;Scheduling;**63,168,380,478,1015**;Aug 13, 1993;Build 21
- ;IHS/ANMC/LJF 8/18/2000 added DIC("W") to warn if clinic inactivated
- ; 10/18/2000 added check: user have access to princ clin?
- ;
- I '$D(DT) D DT^SDUTL
- S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K SDNEXT,SDC1,IOP
- 1 K SDAPTYP S SDMLT="",DIC="^DPT(",DIC(0)="AQZME" D ^DIC S DFN=+Y I "^"[X K FND S SDNEXT="" K SDMLT,SDAPTYP G END^SDMULT0
- G:Y<0 1 D 2^VADPT I +VADM(6) W !?10,*7,"PATIENT HAS DIED." G 1
- S SDW=$S('$D(^DPT(DFN,.1)):"",^(.1)]"":^(.1),1:""),(SDMM,COLLAT)=0
- S SDXXX="" D EN^SDM I $D(SDMLT1) K FND G END^SDMULT0
- D:'$D(DT) DT^SDUTL S SDCT=0,SDMAX=DT K SDC W !!,"YOU MAY SELECT FROM 2-4 CLINICS",!
- RD ;S DIC="^SC(",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC: " D ^DIC K DIC("S"),DIC("A") I X="",SDCT>1 G START^SDMULT0 ;IHS/ANMC/LJF 8/18/2000
- S DIC="^SC(",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC: ",DIC("W")=$$INACTMSG^BSDU D ^DIC K DIC("S"),DIC("A") I X="",SDCT>1 G START^SDMULT0 ;IHS/ANMC/LJF 8/18/2000
- I $S(X["^":1,'$D(DTOUT):0,$D(DTOUT)&DTOUT:1,1:0) K FND G END^SDMULT0
- I $D(SDNEXT) S SDMAX=DT G:X]"" C G END^SDMULT0
- I X']"" W !,*7,"MUST HAVE MORE THAN 1 CLINIC" G RD
- N SDRES S SDRES=$$CLNCK^SDUTL2(+Y,1)
- I 'SDRES W !,?5,"Clinic MUST be corrected before continuing." G RD
- G:Y'>0 RD I $D(SDC1(+Y)) W !,*7,"This clinic has already been selected" G RD
- ;IHS/ITSC/WAR 3/4/04 TESTING NEW CODE
- ;I $D(^SC("AIHSPC",+Y)) S SDPC=+Y D EN^BSDPC K SDPC G RD
- I $D(^SC("AIHSPC",+Y)) W !,*7,"This is a PRINCIPLE clinic, please select one of its subordinate clinics" G RD
- ;End of NEW code 3/4/04
- ;
- ;IHS/ANMC/LJF 10/18/2000
- C ;I $D(^SC(+Y,"SDPROT")),$P(^("SDPROT"),"^",1)="Y",'$D(^SC(+Y,"SDPRIV",DUZ)) W !,*7,"Access to ",$$CNAM(+Y)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 G RD
- I $D(^SC(+Y,"SDPROT")),$P(^("SDPROT"),"^",1)="Y",'$D(^SC(+Y,"SDPRIV",DUZ)),'$D(^SC($$PC^BSDU(+Y),"SDPRIV",DUZ)) W !,*7,"Access to ",$$CNAM(+Y)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 G RD
- I '$D(SDNEXT) S SDOK=0,SC=+Y,SDHY=Y,Y=$S($D(^SC(SC,"SL")):$P(^("SL"),"^",5),1:"") K SD S SDMULT=1 D EN2^SDM S Y=SDHY K SDHY I 'SDOK W !,"CLINIC IGNORED!!" G RD ;SD/478
- K SDOK I '$D(^SC(+Y,"SL")) W !,"No appt length specified - cannot book appts" G RD
- S SL=^("SL"),SDL=+SL ;NAKED REFERENCE ^SC(IFN,"SL")
- LEN I $P(SL,"^",2)]"" W !," APPOINTMENT LENGTH DESIRED: ",+SL R "// ",X:DTIME G:$L(X)>3 LEN G:X["^" END^SDMULT0 I X]"" S POP=0,S=X D L^SDM1 G:POP LEN S SDL=S
- S X2=$S($D(^SC(+Y,"SDP")):$P(^("SDP"),"^",2),1:0),X1=DT D C^%DTC S SDMAX=$S('(X-DT):SDMAX,'(SDMAX-DT):X,X<SDMAX:X,1:SDMAX)
- I SDMAX'>DT W !,*7,$P(Y,"^",2)," has max # of days for future booking undef or = 0" G RD
- S SDC1(+Y)=$P(Y,U,2)_"^"_SDL,SDCT=SDCT+1,SDC(SDCT)=Y,X2=$S($D(^SC(+Y,"SDP")):$P(^("SDP"),"^",2),1:0),X1=DT D C^%DTC S SDMAX=$S('(X-DT):SDMAX,'(SDMAX-DT):X,X<SDMAX:X,1:SDMAX)
- G DT^SDNEXT:$D(SDNEXT),START^SDMULT0:'(SDCT#4),RD
- ;
- ;
- CNAM(SDCL) ;Return clinic name
- ;Input: SDCL=clinic ien
- N SDX
- S SDX=$P($G(^SC(+SDCL,0)),U)
- Q $S($L(SDX):SDX,1:"this clinic")
- SDMULT ;ALB/TMP - MAKE MULTI-CLINIC APPOINTMENTS ; 02 Jan 2000 6:30 PM
- +1 ;;5.3;Scheduling;**63,168,380,478,1015**;Aug 13, 1993;Build 21
- +2 ;IHS/ANMC/LJF 8/18/2000 added DIC("W") to warn if clinic inactivated
- +3 ; 10/18/2000 added check: user have access to princ clin?
- +4 ;
- +5 IF '$DATA(DT)
- DO DT^SDUTL
- +6 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
- DO ^%ZIS
- KILL SDNEXT,SDC1,IOP
- 1 KILL SDAPTYP
- SET SDMLT=""
- SET DIC="^DPT("
- SET DIC(0)="AQZME"
- DO ^DIC
- SET DFN=+Y
- IF "^"[X
- KILL FND
- SET SDNEXT=""
- KILL SDMLT,SDAPTYP
- GOTO END^SDMULT0
- +1 IF Y<0
- GOTO 1
- DO 2^VADPT
- IF +VADM(6)
- WRITE !?10,*7,"PATIENT HAS DIED."
- GOTO 1
- +2 SET SDW=$SELECT('$DATA(^DPT(DFN,.1)):"",^(.1)]"":^(.1),1:"")
- SET (SDMM,COLLAT)=0
- +3 SET SDXXX=""
- DO EN^SDM
- IF $DATA(SDMLT1)
- KILL FND
- GOTO END^SDMULT0
- +4 IF '$DATA(DT)
- DO DT^SDUTL
- SET SDCT=0
- SET SDMAX=DT
- KILL SDC
- WRITE !!,"YOU MAY SELECT FROM 2-4 CLINICS",!
- RD ;S DIC="^SC(",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC: " D ^DIC K DIC("S"),DIC("A") I X="",SDCT>1 G START^SDMULT0 ;IHS/ANMC/LJF 8/18/2000
- +1 ;IHS/ANMC/LJF 8/18/2000
- SET DIC="^SC("
- SET DIC(0)="AEMQZ"
- SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
- SET DIC("A")="Select CLINIC: "
- SET DIC("W")=$$INACTMSG^BSDU
- DO ^DIC
- KILL DIC("S"),DIC("A")
- IF X=""
- IF SDCT>1
- GOTO START^SDMULT0
- +2 IF $SELECT(X["^":1,'$DATA(DTOUT):0,$DATA(DTOUT)&DTOUT:1,1:0)
- KILL FND
- GOTO END^SDMULT0
- +3 IF $DATA(SDNEXT)
- SET SDMAX=DT
- IF X]""
- GOTO C
- GOTO END^SDMULT0
- +4 IF X']""
- WRITE !,*7,"MUST HAVE MORE THAN 1 CLINIC"
- GOTO RD
- +5 NEW SDRES
- SET SDRES=$$CLNCK^SDUTL2(+Y,1)
- +6 IF 'SDRES
- WRITE !,?5,"Clinic MUST be corrected before continuing."
- GOTO RD
- +7 IF Y'>0
- GOTO RD
- IF $DATA(SDC1(+Y))
- WRITE !,*7,"This clinic has already been selected"
- GOTO RD
- +8 ;IHS/ITSC/WAR 3/4/04 TESTING NEW CODE
- +9 ;I $D(^SC("AIHSPC",+Y)) S SDPC=+Y D EN^BSDPC K SDPC G RD
- +10 IF $DATA(^SC("AIHSPC",+Y))
- WRITE !,*7,"This is a PRINCIPLE clinic, please select one of its subordinate clinics"
- GOTO RD
- +11 ;End of NEW code 3/4/04
- +12 ;
- +13 ;IHS/ANMC/LJF 10/18/2000
- C ;I $D(^SC(+Y,"SDPROT")),$P(^("SDPROT"),"^",1)="Y",'$D(^SC(+Y,"SDPRIV",DUZ)) W !,*7,"Access to ",$$CNAM(+Y)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 G RD
- +1 IF $DATA(^SC(+Y,"SDPROT"))
- IF $PIECE(^("SDPROT"),"^",1)="Y"
- IF '$DATA(^SC(+Y,"SDPRIV",DUZ))
- IF '$DATA(^SC($$PC^BSDU(+Y),"SDPRIV",DUZ))
- WRITE !,*7,"Access to ",$$CNAM(+Y)," is prohibited!",!,"Only users with a special code may access this clinic.",*7
- GOTO RD
- +2 ;SD/478
- IF '$DATA(SDNEXT)
- SET SDOK=0
- SET SC=+Y
- SET SDHY=Y
- SET Y=$SELECT($DATA(^SC(SC,"SL")):$PIECE(^("SL"),"^",5),1:"")
- KILL SD
- SET SDMULT=1
- DO EN2^SDM
- SET Y=SDHY
- KILL SDHY
- IF 'SDOK
- WRITE !,"CLINIC IGNORED!!"
- GOTO RD
- +3 KILL SDOK
- IF '$DATA(^SC(+Y,"SL"))
- WRITE !,"No appt length specified - cannot book appts"
- GOTO RD
- +4 ;NAKED REFERENCE ^SC(IFN,"SL")
- SET SL=^("SL")
- SET SDL=+SL
- LEN IF $PIECE(SL,"^",2)]""
- WRITE !," APPOINTMENT LENGTH DESIRED: ",+SL
- READ "// ",X:DTIME
- IF $LENGTH(X)>3
- GOTO LEN
- IF X["^"
- GOTO END^SDMULT0
- IF X]""
- SET POP=0
- SET S=X
- DO L^SDM1
- IF POP
- GOTO LEN
- SET SDL=S
- +1 SET X2=$SELECT($DATA(^SC(+Y,"SDP")):$PIECE(^("SDP"),"^",2),1:0)
- SET X1=DT
- DO C^%DTC
- SET SDMAX=$SELECT('(X-DT):SDMAX,'(SDMAX-DT):X,X<SDMAX:X,1:SDMAX)
- +2 IF SDMAX'>DT
- WRITE !,*7,$PIECE(Y,"^",2)," has max # of days for future booking undef or = 0"
- GOTO RD
- +3 SET SDC1(+Y)=$PIECE(Y,U,2)_"^"_SDL
- SET SDCT=SDCT+1
- SET SDC(SDCT)=Y
- SET X2=$SELECT($DATA(^SC(+Y,"SDP")):$PIECE(^("SDP"),"^",2),1:0)
- SET X1=DT
- DO C^%DTC
- SET SDMAX=$SELECT('(X-DT):SDMAX,'(SDMAX-DT):X,X<SDMAX:X,1:SDMAX)
- +4 IF $DATA(SDNEXT)
- GOTO DT^SDNEXT
- IF '(SDCT#4)
- GOTO START^SDMULT0
- GOTO RD
- +5 ;
- +6 ;
- CNAM(SDCL) ;Return clinic name
- +1 ;Input: SDCL=clinic ien
- +2 NEW SDX
- +3 SET SDX=$PIECE($GET(^SC(+SDCL,0)),U)
- +4 QUIT $SELECT($LENGTH(SDX):SDX,1:"this clinic")
