SDAPP.m

SDAPP ;ALB/TMP - SCHEDULING  CHART REQUEST ; 07 SEP 84  4:17 pm

 ;;5.3;Scheduling;**21,32,41,79,1015**;AUG 13, 1993;Build 21

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

SDAPP     ;ALB/TMP - SCHEDULING  CHART REQUEST ; 07 SEP 84  4:17 pm

 +1       ;;5.3;Scheduling;**21,32,41,79,1015**;AUG 13, 1993;Build 21

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