- ECTSIN ;B'ham ISC/PTD-Enter/Edit Workload Data for Fiscal Year ;01/29/91 08:00
- V ;;1.05;INTERIM MANAGEMENT SUPPORT;;
- 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 !
- ;IF DATA EXISTS IN WORKLOAD SUBFILES FOR YRDA, ALLOW EDIT
- I ($O(^ECT(731,YRDA,30,0))&($O(^ECT(731,YRDA,40,0)))) D DIE G EXIT^ECTSIN1
- ;IF NO DATA FOR ANY FY OR NO DATA IN WORKLOAD SUBFILES FOR ANY FY, GO TO SRCH
- I '$O(^ECT(731,0)) G SRCH
- 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
- G:INPREF="" SRCH G:OPTREF="" SRCH G:INPREF'=OPTREF SRCH
- ;ELSE THERE IS WORKLOAD SUBFILE DATA FOR 'YEAR'; SO SET LOCAL ARRAYS
- S FY=INPREF,(INP,OP)=0
- 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)
- F J=0:0 S OP=$O(^ECT(731,FY,40,OP)) Q:'OP S OPT($P(^DG(40.8,OP,0),"^"))=OP
- G ^ECTSIN1
- ;
- SRCH ;SEARCH THROUGH FILES 42 AND 40.8 TO DETERMINE INP AND OP NAMES
- ;DETERMINE INPATIENT ENTITIES
- S WD=0
- 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
- ;DETERMINE OUTPATIENT ENTITIES
- 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
- ;DISPLAY NAMES FOUND; ASK FOR VALIDATION
- K ARR S X="" F J=0:0 S X=$O(INP(X)) Q:X="" S ARR(X)=""
- S VAR="INP" D VRFY G:$D(DTOUT)!($D(DUOUT)) EXIT^ECTSIN1
- K ARR S X="" F J=0:0 S X=$O(OPT(X)) Q:X="" S ARR(X)=""
- S VAR="OPT" D VRFY G:$D(DTOUT)!($D(DUOUT)) EXIT^ECTSIN1
- G ^ECTSIN1
- ;
- SET1 S INP($P(^DG(40.8,DIV,0),"^"))=DIV
- Q
- ;
- SET2 S INP(($P(^DG(40.8,DIV,0),"^"))_" "_$S(SRV="NH":"NHCU",1:"DOM"))=DIV
- Q
- ;
- 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
- Q
- ;
- VRFY ;VALIDATE LIST OF INPATIENT AND OUTPATIENT NAMES
- K DTOUT,DUOUT S CNT=0,LCN="" Q:$O(ARR(LCN))=""
- W !!,"Number of "_$S(VAR="INP":"INPATIENT discharges",1:"OUTPATIENT visits")_" will be asked for each of these locations: ",!
- F J=0:0 S LCN=$O(ARR(LCN)) Q:LCN="" S CNT=CNT+1 W !?5,CNT,?10,LCN
- 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
- Q:$D(DTOUT) Q:$D(DUOUT) I Y=0 D DLT G VRFY
- Q
- ;
- DLT ;DELETE INVALID NAME
- 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
- 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
- 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)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECTSIN 2984 printed Jan 18, 2025@03:04:06 Page 2
- ECTSIN ;B'ham ISC/PTD-Enter/Edit Workload Data for Fiscal Year ;01/29/91 08:00
- V ;;1.05;INTERIM MANAGEMENT SUPPORT;;
- YR WRITE !
- SET %DT="AE"
- SET %DT("A")="Enter two digit code for Fiscal Year: "
- SET %DT(0)=2700000
- DO ^%DT
- if $DATA(DTOUT)!("^"[X)
- GOTO EXIT^ECTSIN1
- SET YRDA=$EXTRACT(Y,1,3)
- SET YR=$EXTRACT(Y,2,3)
- WRITE !
- +1 ;IF DATA EXISTS IN WORKLOAD SUBFILES FOR YRDA, ALLOW EDIT
- +2 IF ($ORDER(^ECT(731,YRDA,30,0))&($ORDER(^ECT(731,YRDA,40,0))))
- DO DIE
- GOTO EXIT^ECTSIN1
- +3 ;IF NO DATA FOR ANY FY OR NO DATA IN WORKLOAD SUBFILES FOR ANY FY, GO TO SRCH
- +4 IF '$ORDER(^ECT(731,0))
- GOTO SRCH
- +5 SET YEAR=0
- SET (INPREF,OPTREF)=""
- FOR J=0:0
- SET YEAR=$ORDER(^ECT(731,YEAR))
- if 'YEAR
- QUIT
- if $ORDER(^ECT(731,YEAR,30,0))
- SET INPREF=YEAR
- if $ORDER(^ECT(731,YEAR,40,0))
- SET OPTREF=YEAR
- +6 if INPREF=""
- GOTO SRCH
- if OPTREF=""
- GOTO SRCH
- if INPREF'=OPTREF
- GOTO SRCH
- +7 ;ELSE THERE IS WORKLOAD SUBFILE DATA FOR 'YEAR'; SO SET LOCAL ARRAYS
- +8 SET FY=INPREF
- SET (INP,OP)=0
- +9 FOR J=0:0
- SET INP=$ORDER(^ECT(731,FY,30,INP))
- if 'INP
- QUIT
- SET INP($PIECE(^ECT(731,FY,30,INP,0),"^"))=$PIECE(^ECT(731,FY,30,INP,0),"^",2)
- +10 FOR J=0:0
- SET OP=$ORDER(^ECT(731,FY,40,OP))
- if 'OP
- QUIT
- SET OPT($PIECE(^DG(40.8,OP,0),"^"))=OP
- +11 GOTO ^ECTSIN1
- +12 ;
- SRCH ;SEARCH THROUGH FILES 42 AND 40.8 TO DETERMINE INP AND OP NAMES
- +1 ;DETERMINE INPATIENT ENTITIES
- +2 SET WD=0
- WD FOR J=0:0
- SET WD=$ORDER(^DIC(42,WD))
- if 'WD
- QUIT
- SET LOC=^DIC(42,WD,0)
- SET SRV=$PIECE(LOC,"^",3)
- SET DIV=$PIECE(LOC,"^",11)
- if DIV=""
- GOTO WD
- if (SRV'="NH")&(SRV'="D")
- DO SET1
- if (SRV="NH")!(SRV="D")
- DO SET2
- +1 ;DETERMINE OUTPATIENT ENTITIES
- +2 SET DIV=0
- FOR J=0:0
- SET DIV=$ORDER(^DG(40.8,DIV))
- if 'DIV
- QUIT
- SET OPT($PIECE(^DG(40.8,DIV,0),"^"))=DIV
- +3 ;DISPLAY NAMES FOUND; ASK FOR VALIDATION
- +4 KILL ARR
- SET X=""
- FOR J=0:0
- SET X=$ORDER(INP(X))
- if X=""
- QUIT
- SET ARR(X)=""
- +5 SET VAR="INP"
- DO VRFY
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXIT^ECTSIN1
- +6 KILL ARR
- SET X=""
- FOR J=0:0
- SET X=$ORDER(OPT(X))
- if X=""
- QUIT
- SET ARR(X)=""
- +7 SET VAR="OPT"
- DO VRFY
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXIT^ECTSIN1
- +8 GOTO ^ECTSIN1
- +9 ;
- SET1 SET INP($PIECE(^DG(40.8,DIV,0),"^"))=DIV
- +1 QUIT
- +2 ;
- SET2 SET INP(($PIECE(^DG(40.8,DIV,0),"^"))_" "_$SELECT(SRV="NH":"NHCU",1:"DOM"))=DIV
- +1 QUIT
- +2 ;
- DIE WRITE !!,"This is an EXISTING entry. You may edit if you wish.",!!
- SET (DIC,DIE)="^ECT(731,"
- SET DIC(0)="M"
- SET X=YR
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET DA=+Y
- SET DR="30;40"
- SET DR(2,731.03)=".01;2"
- SET DR(2,731.04)="1"
- DO ^DIE
- KILL DIE
- +1 QUIT
- +2 ;
- VRFY ;VALIDATE LIST OF INPATIENT AND OUTPATIENT NAMES
- +1 KILL DTOUT,DUOUT
- SET CNT=0
- SET LCN=""
- if $ORDER(ARR(LCN))=""
- QUIT
- +2 WRITE !!,"Number of "_$SELECT(VAR="INP":"INPATIENT discharges",1:"OUTPATIENT visits")_" will be asked for each of these locations: ",!
- +3 FOR J=0:0
- SET LCN=$ORDER(ARR(LCN))
- if LCN=""
- QUIT
- SET CNT=CNT+1
- WRITE !?5,CNT,?10,LCN
- +4 WRITE !
- SET DIR(0)="Y"
- SET DIR("A")="Are all of these locations VALID names"
- SET DIR("B")="YES"
- SET DIR("?")="If list is correct, press <RETURN> if not correct, enter 'N'."
- DO ^DIR
- +5 if $DATA(DTOUT)
- QUIT
- if $DATA(DUOUT)
- QUIT
- IF Y=0
- DO DLT
- GOTO VRFY
- +6 QUIT
- +7 ;
- DLT ;DELETE INVALID NAME
- +1 SET CNT=0
- SET LCN=""
- WRITE !!
- FOR J=0:0
- SET LCN=$ORDER(ARR(LCN))
- if LCN=""
- QUIT
- SET CNT=CNT+1
- WRITE !?10,CNT,?15,LCN
- +2 WRITE !!,"DELETE which name? "
- READ ANS:DTIME
- if '$TEST!("^"[ANS)
- QUIT
- IF (ANS<1)!(ANS>CNT)
- WRITE !!,*7,"You MUST answer with a number from 1 to ",CNT
- GOTO DLT
- +3 SET CNT=0
- SET LCN=""
- FOR J=0:0
- SET LCN=$ORDER(ARR(LCN))
- if LCN=""
- QUIT
- SET CNT=CNT+1
- IF CNT=ANS
- if VAR="INP"
- KILL INP(LCN),ARR(LCN)
- if VAR="OPT"
- KILL OPT(LCN),ARR(LCN)
- +4 QUIT
- +5 ;