- 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
