SDACS0.m

SDACS0 ; IHS/ADC/PDW/ENM - EXTERNAL PACKAGE CALL TO ADD CODES 12:29 ;  [ 03/25/1999  11:48 AM ]

 ;;5.3;IHS SCHEDULING;**1015**;MAR 25, 1999;Build 21

 ;;MAS VERSION 5.0;

 ;Parameter check - continues to SDACS1 for update

APPT ;set appt type based on eligiblity - appt type 10=COMPUTER GENERATED

 S SDAPTYP=0 D ELIG^VADPT I VAERR!'$D(VAEL(1)) S SDAPTYP=10 G SET

 S SDFLAG=$S(+VAEL(1)=9:8,+VAEL(1)=13:7,+VAEL(1)=14:4,1:0) I $D(VAEL(1))=11 I $D(VAEL(1,9))!($D(VAEL(1,13)))!($D(VAEL(1,14)))!(SDFLAG) S SDAPTYP=10 G SET

 S SDAPTYP=$S($D(VAEL(1))=1&(SDFLAG):SDFLAG,1:9)

SET D DT^DICRW S SDERR=1,(SDCPTCT,SDCTR,SDSCCT)=0,SDMSG=$S($D(ZTQUEUED):0,'$D(SDMSG):0,1:SDMSG) K SDSD

 I "0SCB"'[SDMSG S SDMSG=0

SETERR I $S('$D(DUZ):1,'DUZ:1,'$D(DFN):1,'$D(SDIV):1,'$D(SDC):1,'$D(SDATE):1,'$D(SDCTYPE):1,1:0) S SDEMSG="All necessary parameters are not defined - nothing " D ERR:SDMSG'=0 G CLEAN

 S VAINDT=SDATE D ADM^VADPT2 K VAINDT G:VADMVT CLEAN

 I "SCB"'[SDCTYPE S SDEMSG="Invalid Stop Code Type - nothing " D ERR:SDMSG'=0 G CLEAN

 I "CB"[SDCTYPE,$D(SDCPT)'>9 S SDEMSG="Procedure array not defined - nothing " D ERR:SDMSG'=0 G CLEAN

 I '$O(^DG(40.8,"AD",SDIV,0)) S SDERR=1,SDIV=-1

 E  S SDIV=$O(^DG(40.8,"AD",SDIV,0))

 I SDIV=-1 S SDEMSG="Invalid Division - No credits " D ERR:SDMSG'=0 G CLEAN

 I SDATE>DT S SDEMSG="Stop Codes can not be entered for future dates - nothing " D ERR:SDMSG'=0 G CLEAN

 I '$D(^DPT(DFN,0)) S SDEMSG="Invalid patient - No credits " D ERR:SDMSG'=0 G CLEAN

 I $D(^SDV("ADT",DFN,$P(SDATE,"."))) S DA(1)=+^SDV("ADT",DFN,$P(SDATE,".")),IX=0 F IJ=0:1 S IX=$O(^SDV(DA(1),"CS","B",IX)) Q:IX'>0!(IJ=15)

 I $D(IJ),IJ S SDSCCT=IJ I SDSCCT'<15 D EXCESS G CLEAN

 G ^SDACS1 ;Continue

CLEAN K SDA,SDAPTYP,SDB,SDCPTCT,SDCTR,SDEMSG,SDF,SDFDT,SDFLAG,SDP,SDSCCT,DA,DIC,DIE,DR,IJ,IX,VADMVT,VAEL,VAERR,Y K:SDMSG=0 SDMSG Q

ERR W !,*7,SDEMSG,"recorded in Scheduling module" Q

EXCESS S SDEMSG="Fifteen Stop Codes for this date on record - no more can be " D ERR:SDMSG'=0 Q

SDACS0    ; IHS/ADC/PDW/ENM - EXTERNAL PACKAGE CALL TO ADD CODES 12:29 ;  [ 03/25/1999  11:48 AM ]

 +1       ;;5.3;IHS SCHEDULING;**1015**;MAR 25, 1999;Build 21

 +2       ;;MAS VERSION 5.0;

 +3       ;Parameter check - continues to SDACS1 for update

APPT      ;set appt type based on eligiblity - appt type 10=COMPUTER GENERATED

 +1        SET SDAPTYP=0

           DO ELIG^VADPT

           IF VAERR!'$DATA(VAEL(1))

               SET SDAPTYP=10

               GOTO SET

 +2        SET SDFLAG=$SELECT(+VAEL(1)=9:8,+VAEL(1)=13:7,+VAEL(1)=14:4,1:0)

           IF $DATA(VAEL(1))=11

               IF $DATA(VAEL(1,9))!($DATA(VAEL(1,13)))!($DATA(VAEL(1,14)))!(SDFLAG)

                   SET SDAPTYP=10

                   GOTO SET

 +3        SET SDAPTYP=$SELECT($DATA(VAEL(1))=1&(SDFLAG):SDFLAG,1:9)

SET        DO DT^DICRW

           SET SDERR=1

           SET (SDCPTCT,SDCTR,SDSCCT)=0

           SET SDMSG=$SELECT($DATA(ZTQUEUED):0,'$DATA(SDMSG):0,1:SDMSG)

           KILL SDSD

 +1        IF "0SCB"'[SDMSG

               SET SDMSG=0

SETERR     IF $SELECT('$DATA(DUZ):1,'DUZ:1,'$DATA(DFN):1,'$DATA(SDIV):1,'$DATA(SDC):1,'$DATA(SDATE):1,'$DATA(SDCTYPE):1,1:0)

               SET SDEMSG="All necessary parameters are not defined - nothing "

               IF SDMSG'=0

                   DO ERR

               GOTO CLEAN

 +1        SET VAINDT=SDATE

           DO ADM^VADPT2

           KILL VAINDT

           IF VADMVT

               GOTO CLEAN

 +2        IF "SCB"'[SDCTYPE

               SET SDEMSG="Invalid Stop Code Type - nothing "

               IF SDMSG'=0

                   DO ERR

               GOTO CLEAN

 +3        IF "CB"[SDCTYPE

               IF $DATA(SDCPT)'>9

                   SET SDEMSG="Procedure array not defined - nothing "

                   IF SDMSG'=0

                       DO ERR

                   GOTO CLEAN

 +4        IF '$ORDER(^DG(40.8,"AD",SDIV,0))

               SET SDERR=1

               SET SDIV=-1

 +5       IF '$TEST

               SET SDIV=$ORDER(^DG(40.8,"AD",SDIV,0))

 +6        IF SDIV=-1

               SET SDEMSG="Invalid Division - No credits "

               IF SDMSG'=0

                   DO ERR

               GOTO CLEAN

 +7        IF SDATE>DT

               SET SDEMSG="Stop Codes can not be entered for future dates - nothing "

               IF SDMSG'=0

                   DO ERR

               GOTO CLEAN

 +8        IF '$DATA(^DPT(DFN,0))

               SET SDEMSG="Invalid patient - No credits "

               IF SDMSG'=0

                   DO ERR

               GOTO CLEAN

 +9        IF $DATA(^SDV("ADT",DFN,$PIECE(SDATE,".")))

               SET DA(1)=+^SDV("ADT",DFN,$PIECE(SDATE,"."))

               SET IX=0

               FOR IJ=0:1

                   SET IX=$ORDER(^SDV(DA(1),"CS","B",IX))

                   IF IX'>0!(IJ=15)

                       QUIT 

 +10       IF $DATA(IJ)

               IF IJ

                   SET SDSCCT=IJ

                   IF SDSCCT'<15

                       DO EXCESS

                       GOTO CLEAN

 +11      ;Continue

           GOTO ^SDACS1

CLEAN      KILL SDA,SDAPTYP,SDB,SDCPTCT,SDCTR,SDEMSG,SDF,SDFDT,SDFLAG,SDP,SDSCCT,DA,DIC,DIE,DR,IJ,IX,VADMVT,VAEL,VAERR,Y

           IF SDMSG=0

               KILL SDMSG

           QUIT 

ERR        WRITE !,*7,SDEMSG,"recorded in Scheduling module"

           QUIT 

EXCESS     SET SDEMSG="Fifteen Stop Codes for this date on record - no more can be "

           IF SDMSG'=0

               DO ERR

           QUIT