SDM ;SF/GFT,ALB/BOK - MAKE AN APPOINTMENT ; 4/21/05 10:22pm
;;5.3;Scheduling;**15,32,38,41,44,79,94,167,168,218,223,250,254,296,380,478,441,1005,1015**;AUG 13, 1993;Build 21
; If defined...
; appt mgt vars: SDFN := DFN of patient....will not be asked
; SDCLN := ifn of clinic.....will not be asked
; SDAMERR := returned if error occurs
;
;IHS/ANMC/LJF 6/29/2000 removed display of enrollment status
; added prin clinic availability display
; 7/05/2000 bypassed pend appt display, race question
; and address update; added noshow display
; 8/18/2000 added DIC("W") to warn if clinic inactivated
; 9/29/2000 added call to select by provider, PCP or PCT
; 10/18/2000 added check:user have access to princ clinic?
;IHS/OIT/LJF 12/30/2005 PATCH 1005 added call to display pending appts when in clinic mode
;
S:'$D(SDMM) SDMM=0
EN1 ;L W !! D I^SDUTL I '$D(SDCLN) S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))" D ^DIC K DIC G:Y<0!'$D(^("SL")) END ;IHS/ANMC/LJF 8/18/2000
L W !! D I^SDUTL I '$D(SDCLN) S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))",DIC("W")=$$INACTMSG^BSDU D ^DIC K DIC ;IHS/ANMC/LJF 8/18/2000
I '$D(SDCLN),Y<0 NEW BSDQUIT D ^BSDPRV S X=$S($G(BSDQUIT):"END",1:"EN1") D @X Q ;IHS/ANMC/LJF 9/29/2000 provider or PCP
I '$D(SDCLN),$D(^SC("AIHSPC",+Y)) S SDPC=+Y D EN^BSDPC K SDPC G EN1 ;IHS/ANMC/LJF 6/29/2000 principal clinic
I '$D(SDCLN),'$D(^SC(+Y,"SL")) G END ;IHS/ANMC/LJF 6/29/2000 rest of original line
;
K SDAPTYP,SDIN,SDRE,SDXXX S:$D(SDCLN) Y=+SDCLN
S TMPYCLNC=Y,STPCOD=$P($G(^SC(+TMPYCLNC,0)),U,7) ;SD/478
I $D(^SC(+Y,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),U,2)
K SDINA I $D(SDIN),SDIN S SDINA=SDIN K SDIN
I $D(SD),$D(SC),+Y'=+SC K SD
S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
;
;IHS/ANMC/LJF 10/18/2000
;I $D(^SC(+SC,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(+SC,"SDPRIV",DUZ)) W !,*7,"Access to ",$$CNAM(+SC)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 S:$D(SDCLN) SDAMERR="" G END:$D(SDCLN),SDM
I $D(^SC(+SC,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(+SC,"SDPRIV",DUZ)),'$D(^SC($$PC^BSDU(+SC),"SDPRIV",DUZ)) D G END:$D(SDCLN),SDM
. W !,*7,"Access to ",$$CNAM(+SC)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 S:$D(SDCLN) SDAMERR=""
;
D CS^SDM1A S SDW="",WY="Y"
;
;IHS/OIT/LJF 12/30/2005 PATCH 1005 added call to display pending appts
;I '$D(ORACTION),'$D(SDFN) S (DIC,DIE)="^DPT(",DIC(0)="AQZME" D ^DIC S DFN=+Y G:Y<0 END:$D(SDCLN),^SDM0:X[U,SDM
I '$D(ORACTION),'$D(SDFN) S (DIC,DIE)="^DPT(",DIC(0)="AQZME" D ^DIC S DFN=+Y G:Y<0 END:$D(SDCLN),^SDM0:X[U,SDM D PTAPPT^BSDAM(DFN)
;
S:$D(SDFN) DFN=SDFN
I $D(^DPT(DFN,.35)),$P(^(.35),U)]"" W !?10,*7,"PATIENT HAS DIED." S:$D(SDFN) SDAMERR="" G END:$D(SDFN),SDM
D ^SDM4 I $S('$D(COLLAT):1,COLLAT=7:1,1:0) G:$D(SDCLN) END G SDM
;-- get sub-category for appointment type
S SDXSCAT=$$SUB^DGSAUTL(SDAPTYP,2,"")
K SDXXX D EN G END:$D(SDCLN),SDM
EN K SDMLT1 W:$P(VAEL(9),U,2)]"" !!,?15,"MEANS TEST STATUS: ",$P(VAEL(9),U,2),!
; *** sck, mt blocking removed
;S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$$MT^EASMTCHK(DFN,+$G(SDAPTYP),"M") S SDAMERR="" Q
S Y=DFN,Y(0)=^DPT(DFN,0) I VADM(7)]"" W !?3,*7,VADM(7)
;
Q:$D(SDXXX) D NOSHOW^BSDU2(DFN,+SC) G E ;IHS/ANMC/LJF 7/05/2000 no-show display; bypass pending appt & race
;
I $D(^DGS(41.1,"B",DFN)) F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) Q:I'>0 I $P(^DGS(41.1,I,0),U,2)'<DT&('$P(^DGS(41.1,I,0),U,13)) W !,"SCHEDULED FOR ADMISSION ON " S Y=$P(^(0),U,2) D DT^SDM0
PEND S %="" W:$O(^DPT(DFN,"S",DT))'>DT !,"NO PENDING APPOINTMENTS"
I $O(^DPT(DFN,"S",DT))>DT D G END:%<0,HELP:'%
.S %=1 W !,"DISPLAY PENDING APPOINTMENTS:"
.D YN^DICN
.I %Y["^" S SDMLT1=1
D:%=1
.N DX,DY,SDXY,SDEND S SDXY="S DX=$X,DY=0"_$S($L($G(^%ZOSF("XY"))):" "_^("XY"),1:"") X SDXY
.S CN=1
.F Y=DT:0 S Y=$O(^DPT(DFN,"S",Y)) Q:Y'>0 I "I"[$P(^(Y,0),U,2) X:(($Y+4)>IOSL) "D OUT^SDUTL X SDXY" Q:$G(SDEND) D CHKSO W:$X>9 ! W CN,".",?4 D DT^SDM0 W ?23 S DA=+SSC W SDLN,$S($D(^SC(DA,0)):$P(^(0),U),1:"DELETED CLINIC "),COV," ",SDAT16 D
..S CNIEN=0 F S CNIEN=$O(^SC(+SSC,"S",HY,1,CNIEN)) Q:'+CNIEN S CNPAT=$P($G(^SC(+SSC,"S",HY,1,CNIEN,0)),U) I CNPAT=DFN W:+$G(^SC(+SSC,"S",HY,1,CNIEN,"CONS")) " Consult Appt." S CN=CN+1 Q ;SD/478
;Prompt for ETHNICITY if no value on file
I '$O(^DPT(DFN,.06,0)) D
.S DA=DFN,DR="6ETHNICITY",DIE="^DPT("
.S DR(2,2.06)=".01ETHNICITY"
.D ^DIE K DR
;Prompt for RACE if no value on file
I '$O(^DPT(DFN,.02,0)) D
.S DA=DFN,DR="2RACE",DIE="^DPT("
.S DR(2,2.02)=".01RACE"
.D ^DIE K DR
I $S('$D(^DPT(DFN,.11)):1,$P(^(.11),U)="":1,1:0) N FLG S FLG(1)=1 D EN^DGREGAED(DFN,.FLG)
Q:$D(SDXXX)
E S Y=$P(SL,U,5)
S SDW="" I $D(^DPT(DFN,.1)) S SDW=^(.1) W !,"NOTE - PATIENT IS NOW IN WARD "_SDW
Q:$D(SDXXX)
EN2 F X=0:0 S X=$O(^DPT(DFN,"DE",X)) Q:'$D(^(+X,0)) I ^(0)-SC=0!'(^(0)-Y) F XX=0:0 S XX=$O(^DPT(DFN,"DE",X,1,XX)) Q:XX<1 S SDDIS=$P(^(XX,0),U,3) I 'SDDIS D:'$D(SDMULT) A^SDCNSLT G ^SDM0
I '$D(^SC(+Y,0)) S Y=+SC
S Y=$P(^SC(Y,0),U)
; SCRESTA = Array of pt's teams causing restricted consults
N SCRESTA
S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
IF SCREST D
.N SCTM
. S SCCLNM=Y
. W !,?5,"Patient has restricted consults due to team assignment(s):"
.S SCTM=0
.F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM)
IF SCREST&'$G(SCOKCONS) D Q
.W !,?5,"This patient may only be given appointments and enrolled in clinics via"
.W !,?15,"Make Consult Appointment Option, and"
.W !,?15,"Edit Clinic Enrollment Data option"
D:$G(SCREST) MAIL^SCMCCON(DFN,.SCCLNM,2,DT,"SCRESTA")
K DR,SCREST,SCCLNM
D:'$D(SDMULT) ^SDCNSLT ;SD/478
G ^SDM0
;
CHKSO S COV=$S($P(^DPT(DFN,"S",Y,0),U,11)=1:" (COLLATERAL)",1:""),HY=Y,SSC=^(0),SDAT16=$S($D(^SD(409.1,+$P(SSC,U,16),0)):$P(^(0),U),1:"")
F SDJ=3,4,5 I $P(^DPT(DFN,"S",HY,0),U,SDJ)]"" S Y=$P(^(0),U,SDJ) W:$X>9 ! W ?10,"*" D DT^SDM0 W ?32,$S(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")
S SDLN="" F J=0:0 S J=$O(^SC(+SSC,"S",HY,1,J)) Q:'J I $D(^(J,0)),+^(0)=DFN S SDLN="("_$P(^(0),U,2)_" MIN) " Q
S Y=HY Q
;
END D KVAR^VADPT K SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR,HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL,SSC,STARTDAY,STR
K WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM,SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS I $D(SDMM) K:'SDMM SDMM
K A,CC,CLNIEN,CN,CNIEN,CNPAT,CNSLTLNK,CNSULT,CNT,CONS,CPRSTAT,CW,DSH,DTENTR,DTIN,DTLMT,DTR,ND,P8,PROC,PT,PTIEN,PTNM,RTMP,NOSHOW,SCPTTM,SD1,SDAMSCN,SDATE,SDDOT,SDII,SDINC,SDINCM,SDLEN,SDNS,SDSI,SDST,SDSTR,SDSTRTDT
K SDXSCAT,SENDER,SERVICE,SRV,STATUS,STPCOD,TMP,TMPYCLNC,TYPE
I '$D(SDMLT) K SDMLT1
Q
;
OERR S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP G SDM
;
HELP W !,"YES - TO DISPLAY FUTURE APPOINTMENTS",!,"NO - FUTURE APPOINTMENTS NOT DISPLAYED" G PEND
;
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")
SDM ;SF/GFT,ALB/BOK - MAKE AN APPOINTMENT ; 4/21/05 10:22pm
+1 ;;5.3;Scheduling;**15,32,38,41,44,79,94,167,168,218,223,250,254,296,380,478,441,1005,1015**;AUG 13, 1993;Build 21
+2 ; If defined...
+3 ; appt mgt vars: SDFN := DFN of patient....will not be asked
+4 ; SDCLN := ifn of clinic.....will not be asked
+5 ; SDAMERR := returned if error occurs
+6 ;
+7 ;IHS/ANMC/LJF 6/29/2000 removed display of enrollment status
+8 ; added prin clinic availability display
+9 ; 7/05/2000 bypassed pend appt display, race question
+10 ; and address update; added noshow display
+11 ; 8/18/2000 added DIC("W") to warn if clinic inactivated
+12 ; 9/29/2000 added call to select by provider, PCP or PCT
+13 ; 10/18/2000 added check:user have access to princ clinic?
+14 ;IHS/OIT/LJF 12/30/2005 PATCH 1005 added call to display pending appts when in clinic mode
+15 ;
+16 IF '$DATA(SDMM)
SET SDMM=0
EN1 ;L W !! D I^SDUTL I '$D(SDCLN) S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))" D ^DIC K DIC G:Y<0!'$D(^("SL")) END ;IHS/ANMC/LJF 8/18/2000
+1 ;IHS/ANMC/LJF 8/18/2000
LOCK
WRITE !!
DO I^SDUTL
IF '$DATA(SDCLN)
SET DIC="^SC("
SET DIC(0)="AEMZQ"
SET DIC("A")="Select CLINIC: "
SET DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))"
SET DIC("W")=$$INACTMSG^BSDU
DO ^DIC
KILL DIC
+2 ;IHS/ANMC/LJF 9/29/2000 provider or PCP
IF '$DATA(SDCLN)
IF Y<0
NEW BSDQUIT
DO ^BSDPRV
SET X=$SELECT($GET(BSDQUIT):"END",1:"EN1")
DO @X
QUIT
+3 ;IHS/ANMC/LJF 6/29/2000 principal clinic
IF '$DATA(SDCLN)
IF $DATA(^SC("AIHSPC",+Y))
SET SDPC=+Y
DO EN^BSDPC
KILL SDPC
GOTO EN1
+4 ;IHS/ANMC/LJF 6/29/2000 rest of original line
IF '$DATA(SDCLN)
IF '$DATA(^SC(+Y,"SL"))
GOTO END
+5 ;
+6 KILL SDAPTYP,SDIN,SDRE,SDXXX
IF $DATA(SDCLN)
SET Y=+SDCLN
+7 ;SD/478
SET TMPYCLNC=Y
SET STPCOD=$PIECE($GET(^SC(+TMPYCLNC,0)),U,7)
+8 IF $DATA(^SC(+Y,"I"))
SET SDIN=+^("I")
SET SDRE=+$PIECE(^("I"),U,2)
+9 KILL SDINA
IF $DATA(SDIN)
IF SDIN
SET SDINA=SDIN
KILL SDIN
+10 IF $DATA(SD)
IF $DATA(SC)
IF +Y'=+SC
KILL SD
+11 SET SL=$GET(^SC(+Y,"SL"))
SET X=$PIECE(SL,U,3)
SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
SET SC=Y
SET SB=STARTDAY-1/100
SET X=$PIECE(SL,U,6)
SET HSI=$SELECT(X=1:X,X:X,1:4)
SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
KILL Y
+12 ;
+13 ;IHS/ANMC/LJF 10/18/2000
+14 ;I $D(^SC(+SC,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(+SC,"SDPRIV",DUZ)) W !,*7,"Access to ",$$CNAM(+SC)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 S:$D(SDCLN) SDAMERR="" G END:$D(SDCLN),SDM
+15 IF $DATA(^SC(+SC,"SDPROT"))
IF $PIECE(^("SDPROT"),U)="Y"
IF '$DATA(^SC(+SC,"SDPRIV",DUZ))
IF '$DATA(^SC($$PC^BSDU(+SC),"SDPRIV",DUZ))
Begin DoDot:1
+16 WRITE !,*7,"Access to ",$$CNAM(+SC)," is prohibited!",!,"Only users with a special code may access this clinic.",*7
IF $DATA(SDCLN)
SET SDAMERR=""
End DoDot:1
IF $DATA(SDCLN)
GOTO END
GOTO SDM
+17 ;
+18 DO CS^SDM1A
SET SDW=""
SET WY="Y"
+19 ;
+20 ;IHS/OIT/LJF 12/30/2005 PATCH 1005 added call to display pending appts
+21 ;I '$D(ORACTION),'$D(SDFN) S (DIC,DIE)="^DPT(",DIC(0)="AQZME" D ^DIC S DFN=+Y G:Y<0 END:$D(SDCLN),^SDM0:X[U,SDM
+22 IF '$DATA(ORACTION)
IF '$DATA(SDFN)
SET (DIC,DIE)="^DPT("
SET DIC(0)="AQZME"
DO ^DIC
SET DFN=+Y
IF Y<0
IF $DATA(SDCLN)
GOTO END
IF X[U
GOTO ^SDM0
GOTO SDM
DO PTAPPT^BSDAM(DFN)
+23 ;
+24 IF $DATA(SDFN)
SET DFN=SDFN
+25 IF $DATA(^DPT(DFN,.35))
IF $PIECE(^(.35),U)]""
WRITE !?10,*7,"PATIENT HAS DIED."
IF $DATA(SDFN)
SET SDAMERR=""
IF $DATA(SDFN)
GOTO END
GOTO SDM
+26 DO ^SDM4
IF $SELECT('$DATA(COLLAT):1,COLLAT=7:1,1:0)
IF $DATA(SDCLN)
GOTO END
GOTO SDM
+27 ;-- get sub-category for appointment type
+28 SET SDXSCAT=$$SUB^DGSAUTL(SDAPTYP,2,"")
+29 KILL SDXXX
DO EN
IF $DATA(SDCLN)
GOTO END
GOTO SDM
EN KILL SDMLT1
IF $PIECE(VAEL(9),U,2)]""
WRITE !!,?15,"MEANS TEST STATUS: ",$PIECE(VAEL(9),U,2),!
+1 ; *** sck, mt blocking removed
+2 ;S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$$MT^EASMTCHK(DFN,+$G(SDAPTYP),"M") S SDAMERR="" Q
+3 SET Y=DFN
SET Y(0)=^DPT(DFN,0)
IF VADM(7)]""
WRITE !?3,*7,VADM(7)
+4 ;
+5 ;IHS/ANMC/LJF 7/05/2000 no-show display; bypass pending appt & race
IF $DATA(SDXXX)
QUIT
DO NOSHOW^BSDU2(DFN,+SC)
GOTO E
+6 ;
+7 IF $DATA(^DGS(41.1,"B",DFN))
FOR I=0:0
SET I=$ORDER(^DGS(41.1,"B",DFN,I))
IF I'>0
QUIT
IF $PIECE(^DGS(41.1,I,0),U,2)'<DT&('$PIECE(^DGS(41.1,I,0),U,13))
WRITE !,"SCHEDULED FOR ADMISSION ON "
SET Y=$PIECE(^(0),U,2)
DO DT^SDM0
PEND SET %=""
IF $ORDER(^DPT(DFN,"S",DT))'>DT
WRITE !,"NO PENDING APPOINTMENTS"
+1 IF $ORDER(^DPT(DFN,"S",DT))>DT
Begin DoDot:1
+2 SET %=1
WRITE !,"DISPLAY PENDING APPOINTMENTS:"
+3 DO YN^DICN
+4 IF %Y["^"
SET SDMLT1=1
End DoDot:1
IF %<0
GOTO END
IF '%
GOTO HELP
+5 IF %=1
Begin DoDot:1
+6 NEW DX,DY,SDXY,SDEND
SET SDXY="S DX=$X,DY=0"_$SELECT($LENGTH($GET(^%ZOSF("XY"))):" "_^("XY"),1:"")
XECUTE SDXY
+7 SET CN=1
+8 FOR Y=DT:0
SET Y=$ORDER(^DPT(DFN,"S",Y))
IF Y'>0
QUIT
IF "I"[$PIECE(^(Y,0),U,2)
IF (($Y+4)>IOSL)
XECUTE "D OUT^SDUTL X SDXY"
IF $GET(SDEND)
QUIT
DO CHKSO
IF $X>9
WRITE !
WRITE CN,".",?4
DO DT^SDM0
WRITE ?23
SET DA=+SSC
WRITE SDLN,$SELECT($DATA(^SC(DA,0)):$PIECE(^(0),U),1:"DELETED CLINIC "),COV," ",SDAT16
Begin DoDot:2
+9 ;SD/478
SET CNIEN=0
FOR
SET CNIEN=$ORDER(^SC(+SSC,"S",HY,1,CNIEN))
IF '+CNIEN
QUIT
SET CNPAT=$PIECE($GET(^SC(+SSC,"S",HY,1,CNIEN,0)),U)
IF CNPAT=DFN
IF +$GET(^SC(+SSC,"S",HY,1,CNIEN,"CONS"))
WRITE " Consult Appt."
SET CN=CN+1
QUIT
End DoDot:2
End DoDot:1
+10 ;Prompt for ETHNICITY if no value on file
+11 IF '$ORDER(^DPT(DFN,.06,0))
Begin DoDot:1
+12 SET DA=DFN
SET DR="6ETHNICITY"
SET DIE="^DPT("
+13 SET DR(2,2.06)=".01ETHNICITY"
+14 DO ^DIE
KILL DR
End DoDot:1
+15 ;Prompt for RACE if no value on file
+16 IF '$ORDER(^DPT(DFN,.02,0))
Begin DoDot:1
+17 SET DA=DFN
SET DR="2RACE"
SET DIE="^DPT("
+18 SET DR(2,2.02)=".01RACE"
+19 DO ^DIE
KILL DR
End DoDot:1
+20 IF $SELECT('$DATA(^DPT(DFN,.11)):1,$PIECE(^(.11),U)="":1,1:0)
NEW FLG
SET FLG(1)=1
DO EN^DGREGAED(DFN,.FLG)
+21 IF $DATA(SDXXX)
QUIT
E SET Y=$PIECE(SL,U,5)
+1 SET SDW=""
IF $DATA(^DPT(DFN,.1))
SET SDW=^(.1)
WRITE !,"NOTE - PATIENT IS NOW IN WARD "_SDW
+2 IF $DATA(SDXXX)
QUIT
EN2 FOR X=0:0
SET X=$ORDER(^DPT(DFN,"DE",X))
IF '$DATA(^(+X,0))
QUIT
IF ^(0)-SC=0!'(^(0)-Y)
FOR XX=0:0
SET XX=$ORDER(^DPT(DFN,"DE",X,1,XX))
IF XX<1
QUIT
SET SDDIS=$PIECE(^(XX,0),U,3)
IF 'SDDIS
IF '$DATA(SDMULT)
DO A^SDCNSLT
GOTO ^SDM0
+1 IF '$DATA(^SC(+Y,0))
SET Y=+SC
+2 SET Y=$PIECE(^SC(Y,0),U)
+3 ; SCRESTA = Array of pt's teams causing restricted consults
+4 NEW SCRESTA
+5 SET SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
+6 IF SCREST
Begin DoDot:1
+7 NEW SCTM
+8 SET SCCLNM=Y
+9 WRITE !,?5,"Patient has restricted consults due to team assignment(s):"
+10 SET SCTM=0
+11 FOR
SET SCTM=$ORDER(SCRESTA(SCTM))
IF 'SCTM
QUIT
WRITE !,?10,SCRESTA(SCTM)
End DoDot:1
+12 IF SCREST&'$GET(SCOKCONS)
Begin DoDot:1
+13 WRITE !,?5,"This patient may only be given appointments and enrolled in clinics via"
+14 WRITE !,?15,"Make Consult Appointment Option, and"
+15 WRITE !,?15,"Edit Clinic Enrollment Data option"
End DoDot:1
QUIT
+16 IF $GET(SCREST)
DO MAIL^SCMCCON(DFN,.SCCLNM,2,DT,"SCRESTA")
+17 KILL DR,SCREST,SCCLNM
+18 ;SD/478
IF '$DATA(SDMULT)
DO ^SDCNSLT
+19 GOTO ^SDM0
+20 ;
CHKSO SET COV=$SELECT($PIECE(^DPT(DFN,"S",Y,0),U,11)=1:" (COLLATERAL)",1:"")
SET HY=Y
SET SSC=^(0)
SET SDAT16=$SELECT($DATA(^SD(409.1,+$PIECE(SSC,U,16),0)):$PIECE(^(0),U),1:"")
+1 FOR SDJ=3,4,5
IF $PIECE(^DPT(DFN,"S",HY,0),U,SDJ)]""
SET Y=$PIECE(^(0),U,SDJ)
IF $X>9
WRITE !
WRITE ?10,"*"
DO DT^SDM0
WRITE ?32,$SELECT(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")
+2 SET SDLN=""
FOR J=0:0
SET J=$ORDER(^SC(+SSC,"S",HY,1,J))
IF 'J
QUIT
IF $DATA(^(J,0))
IF +^(0)=DFN
SET SDLN="("_$PIECE(^(0),U,2)_" MIN) "
QUIT
+3 SET Y=HY
QUIT
+4 ;
END DO KVAR^VADPT
KILL SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR,HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL,SSC,STARTDAY,STR
+1 KILL WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM,SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS
IF $DATA(SDMM)
IF 'SDMM
KILL SDMM
+2 KILL A,CC,CLNIEN,CN,CNIEN,CNPAT,CNSLTLNK,CNSULT,CNT,CONS,CPRSTAT,CW,DSH,DTENTR,DTIN,DTLMT,DTR,ND,P8,PROC,PT,PTIEN,PTNM,RTMP,NOSHOW,SCPTTM,SD1,SDAMSCN,SDATE,SDDOT,SDII,SDINC,SDINCM,SDLEN,SDNS,SDSI,SDST,SDSTR,SDSTRTDT
+3 KILL SDXSCAT,SENDER,SERVICE,SRV,STATUS,STPCOD,TMP,TMPYCLNC,TYPE
+4 IF '$DATA(SDMLT)
KILL SDMLT1
+5 QUIT
+6 ;
OERR SET XQORQUIT=1
IF '$DATA(ORVP)
QUIT
SET DFN=+ORVP
GOTO SDM
+1 ;
HELP WRITE !,"YES - TO DISPLAY FUTURE APPOINTMENTS",!,"NO - FUTURE APPOINTMENTS NOT DISPLAYED"
GOTO PEND
+1 ;
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")
