SDDIV.m

SDDIV ;BSN/GRR - MULTI-DIVISION SELECT ; 27 FEB 84  9:40 am

 ;;5.3;Scheduling;**20,1013,1015,1017**;Aug 13, 1993;Build 5

 ;IHS/ANMC/LJF 6/30/2000 changed $N to $O

 ;ihs/cmi/maw 05/02/2011 PATCH 1013 added WLLET for wait list letters

 ;ihs/cmi/maw 08/22/2013 PATCH 1017 changed code when looking at DIV on non multi sites

 ;

ROUT S DIC("A")="ROUTING SLIPS FOR WHICH DIVISION: " G ASK

APLST S DIC("A")="APPOINTMENT LIST FOR WHICH DIVISION: " G ASK

FRLST S DIC("A")="FILE ROOM LIST FOR WHICH DIVISION: " G ASK

CLST S DIC("A")="CLINIC LIST FOR WHICH DIVISION: " G ASK

PALST S DIC("A")="PRE-APPOINTMENT LETTERS FOR WHICH DIVISION: " G DIC

CNLET S DIC("A")="CANCELLATION LETTERS FOR WHICH DIVISION: " G DIC

PCNLET S DIC("A")="APPOINTMENT CANCELLATION LETTERS FOR WHICH DIVISION: " G DIC

WLLET S DIC("A")="WAIT LIST LETTERS FOR WHICH DIVISION: " G DIC

NSLET S DIC("A")="NO-SHOW LETTERS/AUTO REBOOK REPORT FOR WHICH DIVISION: " G ASK

NSLET1 S DIC("A")="NO-SHOW LETTERS FOR WHICH DIVISION: " G DIC

RALST S DIC("A")="RADIOLOGY LIST FOR WHICH DIVISION: " G ASK

A223 S DIC("A")="AMIS SEGMENT 223 FOR WHICH DIVISION: " G ASK

CSSD S DIC("A")="CREATE SURVEY DISPOSITIONING RECORDS FOR WHICH DIVISION (ENTER 'ALL' FOR ALL DIVISIONS): " G ASK

SDCP S DIC("A")="CLINIC PROFILES FOR WHICH DIVISION: " G ASK

DSSA S DIC("A")="DISPOSITION SURVEY APPOINTMENTS FOR WHICH DIVISION: " G ASK

PSDR S DIC("A")="DIVISION (ENTER 'ALL' FOR ALL DIVISIONS): " G ASK2

CSEE S DIC("A")="ENTER VISIT DATA FOR WHICH DIVISION: " G ASK

CALST S DIC("A")="CLINIC ASSIGNMENT LIST FOR WHICH DIVISION: " G ASK

CACTLST S DIC("A")="CLINIC WORKLOAD LIST FOR WHICH DIVISION: " G ASK

 Q

 ;

ASK S ALL=0,SDEF=$$PRIM^VASITE G:'$D(^DG(40.8,SDEF,0)) ERR W !,DIC("A")," ",$P(^(0),"^"),"// " R X:DTIME I X["^" G ERR

 I X="ALL" S ALL=1 I $D(SDALL),'SDALL S X="?",ALL=0 W *7," ??"

 S:X="" DIV=SDEF G:X=""!(X="ALL") AWAY S DIC="^DG(40.8,",DIC(0)="EQMN" I X["?",$S('$D(SDALL):1,SDALL:1,1:0) W "    Enter 'ALL' for all divisions or"

DIC D ^DIC G:X["?"!((Y<0)&('$D(SDLT))) ASK Q:$D(SDLT)&(Y'>0)  S:$D(SDLT) SDV1=+Y S DIV=+Y K DIC Q

AWAY S Y=1 K DIC,SDEF Q

ERR S Y=-1 K DIC,SDALL,SDEF Q

ASK2 ;S (VAUTD,Y)=0 I '$D(^DG(40.8,$N(^DG(40.8,0)),0)) W !,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP" G ERR  ;IHS/ANMC/LJF 6/30/2000

 S (VAUTD,Y)=0 I '$D(^DG(40.8,+$O(^DG(40.8,0)),0)) W !,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP" G ERR  ;IHS/ANMC/LJF 6/30/2000

 I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) G DIVISION^VAUTOMA

 ;S I=$N(^DG(40.8,0)) G:'$D(^DG(40.8,I,0)) ERR S VAUTD(I)=$P(^(0),U) K DIC Q  ;IHS/ANMC/LJF 6/30/2000

 ;S I=+$O(^DG(40.8,0)) G:'$D(^DG(40.8,I,0)) ERR S VAUTD(I)=$P(^(0),U) K DIC Q  ;IHS/ANMC/LJF 6/30/2000

 S I=+$O(^DG(40.8,"AD",DUZ(2),0)) G:'$D(^DG(40.8,I,0)) ERR S VAUTD(I)=$P(^(0),U) K DIC Q  ;ihs/cmi/maw 08/22/2013 PATCH 1017 for sites that are not multi div but have multiple entries in the file

 ; *** Notify IB if any significant changes occur in this routine. ***

SDDIV     ;BSN/GRR - MULTI-DIVISION SELECT ; 27 FEB 84  9:40 am

 +1       ;;5.3;Scheduling;**20,1013,1015,1017**;Aug 13, 1993;Build 5

 +2       ;IHS/ANMC/LJF 6/30/2000 changed $N to $O

 +3       ;ihs/cmi/maw 05/02/2011 PATCH 1013 added WLLET for wait list letters

 +4       ;ihs/cmi/maw 08/22/2013 PATCH 1017 changed code when looking at DIV on non multi sites

 +5       ;

ROUT       SET DIC("A")="ROUTING SLIPS FOR WHICH DIVISION: "

           GOTO ASK

APLST      SET DIC("A")="APPOINTMENT LIST FOR WHICH DIVISION: "

           GOTO ASK

FRLST      SET DIC("A")="FILE ROOM LIST FOR WHICH DIVISION: "

           GOTO ASK

CLST       SET DIC("A")="CLINIC LIST FOR WHICH DIVISION: "

           GOTO ASK

PALST      SET DIC("A")="PRE-APPOINTMENT LETTERS FOR WHICH DIVISION: "

           GOTO DIC

CNLET      SET DIC("A")="CANCELLATION LETTERS FOR WHICH DIVISION: "

           GOTO DIC

PCNLET     SET DIC("A")="APPOINTMENT CANCELLATION LETTERS FOR WHICH DIVISION: "

           GOTO DIC

WLLET      SET DIC("A")="WAIT LIST LETTERS FOR WHICH DIVISION: "

           GOTO DIC

NSLET      SET DIC("A")="NO-SHOW LETTERS/AUTO REBOOK REPORT FOR WHICH DIVISION: "

           GOTO ASK

NSLET1     SET DIC("A")="NO-SHOW LETTERS FOR WHICH DIVISION: "

           GOTO DIC

RALST      SET DIC("A")="RADIOLOGY LIST FOR WHICH DIVISION: "

           GOTO ASK

A223       SET DIC("A")="AMIS SEGMENT 223 FOR WHICH DIVISION: "

           GOTO ASK

CSSD       SET DIC("A")="CREATE SURVEY DISPOSITIONING RECORDS FOR WHICH DIVISION (ENTER 'ALL' FOR ALL DIVISIONS): "

           GOTO ASK

SDCP       SET DIC("A")="CLINIC PROFILES FOR WHICH DIVISION: "

           GOTO ASK

DSSA       SET DIC("A")="DISPOSITION SURVEY APPOINTMENTS FOR WHICH DIVISION: "

           GOTO ASK

PSDR       SET DIC("A")="DIVISION (ENTER 'ALL' FOR ALL DIVISIONS): "

           GOTO ASK2

CSEE       SET DIC("A")="ENTER VISIT DATA FOR WHICH DIVISION: "

           GOTO ASK

CALST      SET DIC("A")="CLINIC ASSIGNMENT LIST FOR WHICH DIVISION: "

           GOTO ASK

CACTLST    SET DIC("A")="CLINIC WORKLOAD LIST FOR WHICH DIVISION: "

           GOTO ASK

 +1        QUIT 

 +2       ;

ASK        SET ALL=0

           SET SDEF=$$PRIM^VASITE

           IF '$DATA(^DG(40.8,SDEF,0))

               GOTO ERR

           WRITE !,DIC("A")," ",$PIECE(^(0),"^"),"// "

           READ X:DTIME

           IF X["^"

               GOTO ERR

 +1        IF X="ALL"

               SET ALL=1

               IF $DATA(SDALL)

                   IF 'SDALL

                       SET X="?"

                       SET ALL=0

                       WRITE *7," ??"

 +2        IF X=""

               SET DIV=SDEF

           IF X=""!(X="ALL")

               GOTO AWAY

           SET DIC="^DG(40.8,"

           SET DIC(0)="EQMN"

           IF X["?"

               IF $SELECT('$DATA(SDALL):1,SDALL:1,1:0)

                   WRITE "    Enter 'ALL' for all divisions or"

DIC        DO ^DIC

           IF X["?"!((Y<0)&('$DATA(SDLT)))

               GOTO ASK

           IF $DATA(SDLT)&(Y'>0)

               QUIT 

           IF $DATA(SDLT)

               SET SDV1=+Y

           SET DIV=+Y

           KILL DIC

           QUIT 

AWAY       SET Y=1

           KILL DIC,SDEF

           QUIT 

ERR        SET Y=-1

           KILL DIC,SDALL,SDEF

           QUIT 

ASK2      ;S (VAUTD,Y)=0 I '$D(^DG(40.8,$N(^DG(40.8,0)),0)) W !,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP" G ERR  ;IHS/ANMC/LJF 6/30/2000

 +1       ;IHS/ANMC/LJF 6/30/2000

           SET (VAUTD,Y)=0

           IF '$DATA(^DG(40.8,+$ORDER(^DG(40.8,0)),0))

               WRITE !,*7,"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP"

               GOTO ERR

 +2        IF $DATA(^DG(43,1,"GL"))

               IF $PIECE(^("GL"),U,2)

                   GOTO DIVISION^VAUTOMA

 +3       ;S I=$N(^DG(40.8,0)) G:'$D(^DG(40.8,I,0)) ERR S VAUTD(I)=$P(^(0),U) K DIC Q  ;IHS/ANMC/LJF 6/30/2000

 +4       ;S I=+$O(^DG(40.8,0)) G:'$D(^DG(40.8,I,0)) ERR S VAUTD(I)=$P(^(0),U) K DIC Q  ;IHS/ANMC/LJF 6/30/2000

 +5       ;ihs/cmi/maw 08/22/2013 PATCH 1017 for sites that are not multi div but have multiple entries in the file

           SET I=+$ORDER(^DG(40.8,"AD",DUZ(2),0))

           IF '$DATA(^DG(40.8,I,0))

               GOTO ERR

           SET VAUTD(I)=$PIECE(^(0),U)

           KILL DIC

           QUIT 

 +6       ; *** Notify IB if any significant changes occur in this routine. ***