SDAPP ;ALB/TMP - SCHEDULING CHART REQUEST ; 07 SEP 84 4:17 pm
;;5.3;Scheduling;**21,32,41,79**;AUG 13, 1993
4 ;;Chart Request
S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL
S (DIC,DIE)="^SC(",DIC(0)="AQME",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="SELECT CLINIC NAME: " D ^DIC K DIC("A"),DIC("S") Q:+Y<0 S SDIN=$S($D(^SC(+Y,"I")):1,1:""),SDRE="" I SDIN S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2)
I SDIN,SDIN'>DT,'SDRE S D0=+Y D WRT1 Q
S DA=+Y,DR=1906,DR(2,44.006)=".01;S Y=2 I $S('$D(^SC(D0,""I"")):0,+^(""I"")'>0:0,+^(""I"")>X:0,+$P(^(""I""),U,2)'>X&(+$P(^(""I""),U,2)'=0):0,1:1) K ^SC(D0,""C"",D1) S Y="""" D WRT1^SDAPP;2" G ^DIE
Q
19 ;;Edit Clinic Enrollment Data
; SCRESTA = Array of pt's teams causing restricted consults
N SCRESTA,SCABORT
S DIC="^DPT(",DIC(0)="AEMQF" D ^DIC Q:"^"[X G:Y<0 19
S DFN=+Y
S SCREST=$$RESTPT^SCAPMCU4(.DFN,DT,"SCRESTA")
IF SCREST D Q:$G(SCABORT)
.N SCTM
. W !,?5,"Patient has restricted consults due to the following team assignment(s):"
.S SCTM=0
.F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM)
.IF $D(^XUSEC("SC CONSULT",DUZ)) D
..W !!,?10,"Team Members will be notified of new enrollments"
.ELSE D
..W !!,?10,"You need the SC CONSULT key to do enrollments for this patient"
..S SCABORT=1
D BEFORE^SCMCEV3(DFN)
S DA=+Y,DIE=DIC,DR="3",DR(2,2.001)="1",DR(3,2.011)=".01;1;5;3;4" D ^DIE
D AFTER^SCMCEV3(DFN)
D INVOKE^SCMCEV3(DFN)
G 19
20 ;;Additional Non-Vet Elig Status
S DIC="^DPT(",DIC(0)="AEMQF" D ^DIC Q:"^"[X G:Y'>0 20
I $S('$D(^DPT(+Y,"VET")):1,^("VET")'="Y":1,1:0) W !,*7,"Patient must be a veteran!!" G 20
S DIE=DIC,DA=+Y,DR=".099" D ^DIE K DIE,DIC,DR
G 20
WRT1 S SDY=Y,SDI=+^SC(D0,"I"),SDI1=+$P(^("I"),U,2) W *7,!,"Clinic is inactive ",$S(SDI1'=0:"from ",1:"as of ") S Y=SDI D DTS^SDUTL W Y S Y=SDI1 D:Y DTS^SDUTL W $S(SDI1=0:"",1:" to "_Y) S Y=SDY K SDY,SDI,SDI1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAPP 1903 printed Oct 16, 2024@18:49:05 Page 2
SDAPP ;ALB/TMP - SCHEDULING CHART REQUEST ; 07 SEP 84 4:17 pm
+1 ;;5.3;Scheduling;**21,32,41,79**;AUG 13, 1993
4 ;;Chart Request
+1 if '$DATA(DTIME)
SET DTIME=300
IF '$DATA(DT)
DO DT^SDUTL
+2 SET (DIC,DIE)="^SC("
SET DIC(0)="AQME"
SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
SET DIC("A")="SELECT CLINIC NAME: "
DO ^DIC
KILL DIC("A"),DIC("S")
if +Y<0
QUIT
SET SDIN=$SELECT($DATA(^SC(+Y,"I")):1,1:"")
SET SDRE=""
IF SDIN
SET SDIN=+^("I")
SET SDRE=+$PIECE(^("I"),"^",2)
+3 IF SDIN
IF SDIN'>DT
IF 'SDRE
SET D0=+Y
DO WRT1
QUIT
+4 SET DA=+Y
SET DR=1906
SET DR(2,44.006)=".01;S Y=2 I $S('$D(^SC(D0,""I"")):0,+^(""I"")'>0:0,+^(""I"")>X:0,+$P(^(""I""),U,2)'>X&(+$P(^(""I""),U,2)'=0):0,1:1) K ^SC(D0,""C"",D1) S Y="""" D WRT1^SDAPP;2"
GOTO ^DIE
+5 QUIT
19 ;;Edit Clinic Enrollment Data
+1 ; SCRESTA = Array of pt's teams causing restricted consults
+2 NEW SCRESTA,SCABORT
+3 SET DIC="^DPT("
SET DIC(0)="AEMQF"
DO ^DIC
if "^"[X
QUIT
if Y<0
GOTO 19
+4 SET DFN=+Y
+5 SET SCREST=$$RESTPT^SCAPMCU4(.DFN,DT,"SCRESTA")
+6 IF SCREST
Begin DoDot:1
+7 NEW SCTM
+8 WRITE !,?5,"Patient has restricted consults due to the following team assignment(s):"
+9 SET SCTM=0
+10 FOR
SET SCTM=$ORDER(SCRESTA(SCTM))
if 'SCTM
QUIT
WRITE !,?10,SCRESTA(SCTM)
+11 IF $DATA(^XUSEC("SC CONSULT",DUZ))
Begin DoDot:2
+12 WRITE !!,?10,"Team Members will be notified of new enrollments"
End DoDot:2
+13 IF '$TEST
Begin DoDot:2
+14 WRITE !!,?10,"You need the SC CONSULT key to do enrollments for this patient"
+15 SET SCABORT=1
End DoDot:2
End DoDot:1
if $GET(SCABORT)
QUIT
+16 DO BEFORE^SCMCEV3(DFN)
+17 SET DA=+Y
SET DIE=DIC
SET DR="3"
SET DR(2,2.001)="1"
SET DR(3,2.011)=".01;1;5;3;4"
DO ^DIE
+18 DO AFTER^SCMCEV3(DFN)
+19 DO INVOKE^SCMCEV3(DFN)
+20 GOTO 19
20 ;;Additional Non-Vet Elig Status
+1 SET DIC="^DPT("
SET DIC(0)="AEMQF"
DO ^DIC
if "^"[X
QUIT
if Y'>0
GOTO 20
+2 IF $SELECT('$DATA(^DPT(+Y,"VET")):1,^("VET")'="Y":1,1:0)
WRITE !,*7,"Patient must be a veteran!!"
GOTO 20
+3 SET DIE=DIC
SET DA=+Y
SET DR=".099"
DO ^DIE
KILL DIE,DIC,DR
+4 GOTO 20
WRT1 SET SDY=Y
SET SDI=+^SC(D0,"I")
SET SDI1=+$PIECE(^("I"),U,2)
WRITE *7,!,"Clinic is inactive ",$SELECT(SDI1'=0:"from ",1:"as of ")
SET Y=SDI
DO DTS^SDUTL
WRITE Y
SET Y=SDI1
if Y
DO DTS^SDUTL
WRITE $SELECT(SDI1=0:"",1:" to "_Y)
SET Y=SDY
KILL SDY,SDI,SDI1
QUIT
