source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDAPP.m@ 1742

Last change on this file since 1742 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.8 KB
Line 
1SDAPP ;ALB/TMP - SCHEDULING CHART REQUEST ; 07 SEP 84 4:17 pm
2 ;;5.3;Scheduling;**21,32,41,79**;AUG 13, 1993
34 ;;Chart Request
4 S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL
5 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)
6 I SDIN,SDIN'>DT,'SDRE S D0=+Y D WRT1 Q
7 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
8 Q
919 ;;Edit Clinic Enrollment Data
10 ; SCRESTA = Array of pt's teams causing restricted consults
11 N SCRESTA,SCABORT
12 S DIC="^DPT(",DIC(0)="AEMQF" D ^DIC Q:"^"[X G:Y<0 19
13 S DFN=+Y
14 S SCREST=$$RESTPT^SCAPMCU4(.DFN,DT,"SCRESTA")
15 IF SCREST D Q:$G(SCABORT)
16 .N SCTM
17 . W !,?5,"Patient has restricted consults due to the following team assignment(s):"
18 .S SCTM=0
19 .F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM)
20 .IF $D(^XUSEC("SC CONSULT",DUZ)) D
21 ..W !!,?10,"Team Members will be notified of new enrollments"
22 .ELSE D
23 ..W !!,?10,"You need the SC CONSULT key to do enrollments for this patient"
24 ..S SCABORT=1
25 D BEFORE^SCMCEV3(DFN)
26 S DA=+Y,DIE=DIC,DR="3",DR(2,2.001)="1",DR(3,2.011)=".01;1;5;3;4" D ^DIE
27 D AFTER^SCMCEV3(DFN)
28 D INVOKE^SCMCEV3(DFN)
29 G 19
3020 ;;Additional Non-Vet Elig Status
31 S DIC="^DPT(",DIC(0)="AEMQF" D ^DIC Q:"^"[X G:Y'>0 20
32 I $S('$D(^DPT(+Y,"VET")):1,^("VET")'="Y":1,1:0) W !,*7,"Patient must be a veteran!!" G 20
33 S DIE=DIC,DA=+Y,DR=".099" D ^DIE K DIE,DIC,DR
34 G 20
35WRT1 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
Note: See TracBrowser for help on using the repository browser.