| 1 | ECTSIN ;B'ham ISC/PTD-Enter/Edit Workload Data for Fiscal Year ;01/29/91 08:00
|
---|
| 2 | V ;;1.05;INTERIM MANAGEMENT SUPPORT;;
|
---|
| 3 | YR W ! S %DT="AE",%DT("A")="Enter two digit code for Fiscal Year: ",%DT(0)=2700000 D ^%DT G:$D(DTOUT)!("^"[X) EXIT^ECTSIN1 S YRDA=$E(Y,1,3),YR=$E(Y,2,3) W !
|
---|
| 4 | ;IF DATA EXISTS IN WORKLOAD SUBFILES FOR YRDA, ALLOW EDIT
|
---|
| 5 | I ($O(^ECT(731,YRDA,30,0))&($O(^ECT(731,YRDA,40,0)))) D DIE G EXIT^ECTSIN1
|
---|
| 6 | ;IF NO DATA FOR ANY FY OR NO DATA IN WORKLOAD SUBFILES FOR ANY FY, GO TO SRCH
|
---|
| 7 | I '$O(^ECT(731,0)) G SRCH
|
---|
| 8 | S YEAR=0,(INPREF,OPTREF)="" F J=0:0 S YEAR=$O(^ECT(731,YEAR)) Q:'YEAR S:$O(^ECT(731,YEAR,30,0)) INPREF=YEAR S:$O(^ECT(731,YEAR,40,0)) OPTREF=YEAR
|
---|
| 9 | G:INPREF="" SRCH G:OPTREF="" SRCH G:INPREF'=OPTREF SRCH
|
---|
| 10 | ;ELSE THERE IS WORKLOAD SUBFILE DATA FOR 'YEAR'; SO SET LOCAL ARRAYS
|
---|
| 11 | S FY=INPREF,(INP,OP)=0
|
---|
| 12 | F J=0:0 S INP=$O(^ECT(731,FY,30,INP)) Q:'INP S INP($P(^ECT(731,FY,30,INP,0),"^"))=$P(^ECT(731,FY,30,INP,0),"^",2)
|
---|
| 13 | F J=0:0 S OP=$O(^ECT(731,FY,40,OP)) Q:'OP S OPT($P(^DG(40.8,OP,0),"^"))=OP
|
---|
| 14 | G ^ECTSIN1
|
---|
| 15 | ;
|
---|
| 16 | SRCH ;SEARCH THROUGH FILES 42 AND 40.8 TO DETERMINE INP AND OP NAMES
|
---|
| 17 | ;DETERMINE INPATIENT ENTITIES
|
---|
| 18 | S WD=0
|
---|
| 19 | WD F J=0:0 S WD=$O(^DIC(42,WD)) Q:'WD S LOC=^DIC(42,WD,0),SRV=$P(LOC,"^",3),DIV=$P(LOC,"^",11) G:DIV="" WD D:(SRV'="NH")&(SRV'="D") SET1 D:(SRV="NH")!(SRV="D") SET2
|
---|
| 20 | ;DETERMINE OUTPATIENT ENTITIES
|
---|
| 21 | S DIV=0 F J=0:0 S DIV=$O(^DG(40.8,DIV)) Q:'DIV S OPT($P(^DG(40.8,DIV,0),"^"))=DIV
|
---|
| 22 | ;DISPLAY NAMES FOUND; ASK FOR VALIDATION
|
---|
| 23 | K ARR S X="" F J=0:0 S X=$O(INP(X)) Q:X="" S ARR(X)=""
|
---|
| 24 | S VAR="INP" D VRFY G:$D(DTOUT)!($D(DUOUT)) EXIT^ECTSIN1
|
---|
| 25 | K ARR S X="" F J=0:0 S X=$O(OPT(X)) Q:X="" S ARR(X)=""
|
---|
| 26 | S VAR="OPT" D VRFY G:$D(DTOUT)!($D(DUOUT)) EXIT^ECTSIN1
|
---|
| 27 | G ^ECTSIN1
|
---|
| 28 | ;
|
---|
| 29 | SET1 S INP($P(^DG(40.8,DIV,0),"^"))=DIV
|
---|
| 30 | Q
|
---|
| 31 | ;
|
---|
| 32 | SET2 S INP(($P(^DG(40.8,DIV,0),"^"))_" "_$S(SRV="NH":"NHCU",1:"DOM"))=DIV
|
---|
| 33 | Q
|
---|
| 34 | ;
|
---|
| 35 | DIE W !!,"This is an EXISTING entry. You may edit if you wish.",!! S (DIC,DIE)="^ECT(731,",DIC(0)="M",X=YR D ^DIC K DIC Q:Y<0 S DA=+Y,DR="30;40",DR(2,731.03)=".01;2",DR(2,731.04)="1" D ^DIE K DIE
|
---|
| 36 | Q
|
---|
| 37 | ;
|
---|
| 38 | VRFY ;VALIDATE LIST OF INPATIENT AND OUTPATIENT NAMES
|
---|
| 39 | K DTOUT,DUOUT S CNT=0,LCN="" Q:$O(ARR(LCN))=""
|
---|
| 40 | W !!,"Number of "_$S(VAR="INP":"INPATIENT discharges",1:"OUTPATIENT visits")_" will be asked for each of these locations: ",!
|
---|
| 41 | F J=0:0 S LCN=$O(ARR(LCN)) Q:LCN="" S CNT=CNT+1 W !?5,CNT,?10,LCN
|
---|
| 42 | W ! S DIR(0)="Y",DIR("A")="Are all of these locations VALID names",DIR("B")="YES",DIR("?")="If list is correct, press <RETURN>; if not correct, enter 'N'." D ^DIR
|
---|
| 43 | Q:$D(DTOUT) Q:$D(DUOUT) I Y=0 D DLT G VRFY
|
---|
| 44 | Q
|
---|
| 45 | ;
|
---|
| 46 | DLT ;DELETE INVALID NAME
|
---|
| 47 | S CNT=0,LCN="" W !! F J=0:0 S LCN=$O(ARR(LCN)) Q:LCN="" S CNT=CNT+1 W !?10,CNT,?15,LCN
|
---|
| 48 | W !!,"DELETE which name? " R ANS:DTIME Q:'$T!("^"[ANS) I (ANS<1)!(ANS>CNT) W !!,*7,"You MUST answer with a number from 1 to ",CNT G DLT
|
---|
| 49 | S CNT=0,LCN="" F J=0:0 S LCN=$O(ARR(LCN)) Q:LCN="" S CNT=CNT+1 I CNT=ANS K:VAR="INP" INP(LCN),ARR(LCN) K:VAR="OPT" OPT(LCN),ARR(LCN)
|
---|
| 50 | Q
|
---|
| 51 | ;
|
---|