SDCD ;BSN/GRR - DISCHARGE PATIENT FROM CLINIC ;3/15/91 11:24 ;
;;5.3;Scheduling;**41,148**;AUG 13, 1993
15 D:'$D(DT) DT^SDUTL I '$G(SDFN) S DIC="^DPT(",DIC(0)="AEQM" D ^DIC G:Y=-1 QUIT
S:$G(SDFN) Y=+SDFN S DA(2)=+Y
I '$G(SDCLN) G:'$D(^DPT(+Y,"DE")) NOPE S DIC="^DPT("_DA(2)_",""DE"",",DIC("S")="I $P(^(0),""^"",2)']""""",VAUTSTR="clinic",VAUTNI=2,VAUTVB="VAUTC" D FIRST^VAUTOMA K DIC("S") Q:Y<0
I $G(SDCLN) D G QUIT:'$O(VAUTC(0))
.S VAUTC=0,VAUTC(+$O(^DPT(DA(2),"DE","B",+SDCLN,99999),-1))=+SDCLN
.I '$O(VAUTC(0)) W !!,*7,">>> Patient not enrolled in '",$S($D(^SC(+SDCLN,0)):$P(^(0),"^"),1:"Unknown"),"' clinic." S SDAMERR=1
I VAUTC=1 F I=0:0 S I=$O(^DPT(DA(2),"DE",I)) Q:'I S CLINIC=^DPT(DA(2),"DE",I,0) I $P(CLINIC,U,2)']"" S VAUTC(I)=+CLINIC
D BEFORE^SCMCEV3(DA(2)) ;setup before values
F I=0:0 S I=$O(VAUTC(I)) Q:'I S DA(1)=I,SC=VAUTC(I) D DIS
I '$O(VAUTC(0)) W !!,*7,">>> Patient is not actively enrolled in any clinics." S SDAMERR=1
I '$D(SDAMERR) D AFTER^SCMCEV3(DA(2)) ;setup after values
;call team event driver
I '$D(SDAMERR) D INVOKE^SCMCEV3(DA(2))
G 15:'$G(SDFN)
QUIT ;
K CLINIC,DFN,SC,SDF,SDST,VAUTC,VAUTD,VAUTNI,VAUSTR,VAUTVB,DIC
Q
DIS ;
S SDF=0
I $P(^DPT(DA(2),"DE",DA(1),0),"^",2)]"" W *7,*7,!,"PATIENT ALREADY DISCHARGED FROM '",$S($D(^SC(SC,0)):$P(^(0),U),1:"UNKNOWN"),"' CLINIC",*7,*7 S SDAMERR=1 Q
W !!,"***Discharging patient from ",$S($D(^SC(SC,0)):$P(^(0),U),1:"UNKNOWN")," Clinic***",!
F XX=DT_.2359:0 S XX=$O(^DPT(DA(2),"S",XX)) Q:XX'>0 I $P(^(XX,0),"^",1)=SC,$P(^(0),"^",2)=""!($P(^(0),"^",2)="I") W !?10,*7,"PATIENT HAS FUTURE APPOINTMENT(S) IN THIS CLINIC" S SDF=1
I 'SDF F XX=0:0 S XX=$O(^DPT(DA(2),"DE",DA(1),1,XX)) Q:XX="" D STAT I SDST']"" S DIE="^DPT("_DA(2)_",""DE"","_DA(1)_",1,",DA=XX,DR="3"_$S($G(SCDISCH):"///"_SCDISCH,1:"")_";I 'X S Y=0;I X S XD=1;4" D ^DIE
W !,*7,"Patient ",$S('$D(XD):"NOT ",XD=2:"ALREADY ",1:""),"Discharged from clinic !!",! S:SDF SDF=0,SDAMERR=1 K XD
Q
NOPE W !,*7,"PATIENT NOT ENROLLED IN ANY CLINICS!!" G QUIT:$G(SDFN),15
STAT ;ck if already discharged
S SDST=$P(^DPT(DA(2),"DE",DA(1),1,XX,0),U,3) Q:SDST']""
S DIE="^DPT("_DA(2)_",""DE"","_DA(1)_",1,",DA=XX,DR="3////^S X=SDST"
L @(DIE_XX_")"):2 G:'$T STAT D ^DIE L S:'$D(XD) XD=2 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCD 2261 printed Oct 16, 2024@18:49:30 Page 2
SDCD ;BSN/GRR - DISCHARGE PATIENT FROM CLINIC ;3/15/91 11:24 ;
+1 ;;5.3;Scheduling;**41,148**;AUG 13, 1993
15 if '$DATA(DT)
DO DT^SDUTL
IF '$GET(SDFN)
SET DIC="^DPT("
SET DIC(0)="AEQM"
DO ^DIC
if Y=-1
GOTO QUIT
+1 if $GET(SDFN)
SET Y=+SDFN
SET DA(2)=+Y
+2 IF '$GET(SDCLN)
if '$DATA(^DPT(+Y,"DE"))
GOTO NOPE
SET DIC="^DPT("_DA(2)_",""DE"","
SET DIC("S")="I $P(^(0),""^"",2)']"""""
SET VAUTSTR="clinic"
SET VAUTNI=2
SET VAUTVB="VAUTC"
DO FIRST^VAUTOMA
KILL DIC("S")
if Y<0
QUIT
+3 IF $GET(SDCLN)
Begin DoDot:1
+4 SET VAUTC=0
SET VAUTC(+$ORDER(^DPT(DA(2),"DE","B",+SDCLN,99999),-1))=+SDCLN
+5 IF '$ORDER(VAUTC(0))
WRITE !!,*7,">>> Patient not enrolled in '",$SELECT($DATA(^SC(+SDCLN,0)):$PIECE(^(0),"^"),1:"Unknown"),"' clinic."
SET SDAMERR=1
End DoDot:1
if '$ORDER(VAUTC(0))
GOTO QUIT
+6 IF VAUTC=1
FOR I=0:0
SET I=$ORDER(^DPT(DA(2),"DE",I))
if 'I
QUIT
SET CLINIC=^DPT(DA(2),"DE",I,0)
IF $PIECE(CLINIC,U,2)']""
SET VAUTC(I)=+CLINIC
+7 ;setup before values
DO BEFORE^SCMCEV3(DA(2))
+8 FOR I=0:0
SET I=$ORDER(VAUTC(I))
if 'I
QUIT
SET DA(1)=I
SET SC=VAUTC(I)
DO DIS
+9 IF '$ORDER(VAUTC(0))
WRITE !!,*7,">>> Patient is not actively enrolled in any clinics."
SET SDAMERR=1
+10 ;setup after values
IF '$DATA(SDAMERR)
DO AFTER^SCMCEV3(DA(2))
+11 ;call team event driver
+12 IF '$DATA(SDAMERR)
DO INVOKE^SCMCEV3(DA(2))
+13 if '$GET(SDFN)
GOTO 15
QUIT ;
+1 KILL CLINIC,DFN,SC,SDF,SDST,VAUTC,VAUTD,VAUTNI,VAUSTR,VAUTVB,DIC
+2 QUIT
DIS ;
+1 SET SDF=0
+2 IF $PIECE(^DPT(DA(2),"DE",DA(1),0),"^",2)]""
WRITE *7,*7,!,"PATIENT ALREADY DISCHARGED FROM '",$SELECT($DATA(^SC(SC,0)):$PIECE(^(0),U),1:"UNKNOWN"),"' CLINIC",*7,*7
SET SDAMERR=1
QUIT
+3 WRITE !!,"***Discharging patient from ",$SELECT($DATA(^SC(SC,0)):$PIECE(^(0),U),1:"UNKNOWN")," Clinic***",!
+4 FOR XX=DT_.2359:0
SET XX=$ORDER(^DPT(DA(2),"S",XX))
if XX'>0
QUIT
IF $PIECE(^(XX,0),"^",1)=SC
IF $PIECE(^(0),"^",2)=""!($PIECE(^(0),"^",2)="I")
WRITE !?10,*7,"PATIENT HAS FUTURE APPOINTMENT(S) IN THIS CLINIC"
SET SDF=1
+5 IF 'SDF
FOR XX=0:0
SET XX=$ORDER(^DPT(DA(2),"DE",DA(1),1,XX))
if XX=""
QUIT
DO STAT
IF SDST']""
SET DIE="^DPT("_DA(2)_",""DE"","_DA(1)_",1,"
SET DA=XX
SET DR="3"_$SELECT($GET(SCDISCH):"///"_SCDISCH,1:"")_";I 'X S Y=0;I X S XD=1;4"
DO ^DIE
+6 WRITE !,*7,"Patient ",$SELECT('$DATA(XD):"NOT ",XD=2:"ALREADY ",1:""),"Discharged from clinic !!",!
if SDF
SET SDF=0
SET SDAMERR=1
KILL XD
+7 QUIT
NOPE WRITE !,*7,"PATIENT NOT ENROLLED IN ANY CLINICS!!"
if $GET(SDFN)
GOTO QUIT
GOTO 15
STAT ;ck if already discharged
+1 SET SDST=$PIECE(^DPT(DA(2),"DE",DA(1),1,XX,0),U,3)
if SDST']""
QUIT
+2 SET DIE="^DPT("_DA(2)_",""DE"","_DA(1)_",1,"
SET DA=XX
SET DR="3////^S X=SDST"
+3 LOCK @(DIE_XX_")"):2
if '$TEST
GOTO STAT
DO ^DIE
LOCK
if '$DATA(XD)
SET XD=2
QUIT
