DGSCHAD ;ALB/MRL - SCHEDULED ADMISSIONS ENTRY/CANCEL ;12/4/91 14:14 ;
;;5.3;Registration;**117,187,1015**;Aug 13, 1993;Build 21
;OERR MODIFICATIONS
1 ;Schedule Admission
D Q S DGNEW=0 K ORACTION G Q:$D(DGSKIP) W !! S DIC("A")="Schedule admission for patient: ",DIC(0)="AEZQLM"
11 S DLAYGO=41.1,DIC("S")="I '$P(^DGS(41.1,+Y,0),""^"",13)",DIC="^DGS(41.1," D ^DIC K DLAYGO,DIC("S"),DIC("A") G Q:Y'>0 S DGSCH=+Y,DFN=+$P(Y,"^",2)
EN S DGNEW=+$P(Y,U,3) I 'DGNEW&($D(ORACTION)) W !,"Editing is not allowed through this option, only adding",*7,! G Q
I $D(^DPT(+$P(^(0),"^",1),.35)),+^(.35) S Y=^(.35) X ^DD("DD") W !!,*7,"PATIENT DIED ON ",Y,"...CAN'T SCHEDULED ADMIT FOR EXPIRED PATIENT!!" D:DGNEW KILL G Q:$D(ORACTION),1:'$D(DGSKIP),Q
S (DA,Y)=DGSCH,DR="[DGSCHADMIT]",DIE=DIC D DIV^DGUTL,^DIE,SA G 1:DGERR I $S('$D(^DGS(41.1,"B",DFN)):1,'$D(^DPT(DFN,.3)):1,$P(^DPT(DFN,.3),"^",1)'="N":1,1:0) G Q:$D(ORACTION),1:'$D(DGSKIP),Q
K DFN1,DGPMDA,DGJJ G Q:$D(DGSKIP)
TP W ! D ASK^DGBLRV
G Q:$D(ORACTION),1:'$D(DGPMDA) Q
2 ;Cancel Scheduled Admission
D WARN W !! S DIC("A")="Cancel scheduled admission for patient: ",DIC("S")="I '$P(^DGS(41.1,+Y,0),""^"",13)",DIC(0)="AEZQM",DIC="^DGS(41.1," D ^DIC K DIC("A"),DIC("S") G Q:Y'>0 S DGSCH=+Y
W !!,*7,"All questions must be answered or this scheduled admission won't be cancelled!!" S (DA,Y)=DGSCH,DIE=DIC,DR="13;14////^S X=DUZ;15;16;" D ^DIE,CA,Q G 2
Q
SA ;Check SA for missing data
W ! S DGSCH1=$S($D(^DGS(41.1,+DGSCH,0)):^(0),1:"") I DGSCH1']"" S DGERR=0 Q
S DGERR=0,DGERSUB="PATIENT NAME^DATE OF RESERVATION^LENGTH OF STAY EXPECTED^ADMITTING DIAGNOSIS^PROVIDER^SURGERY^OPT/NSC STATUS^^^WARD OR TREATING SPECIALTY^^DIVISION"
F I=1,2,4,5,10,12 I $P(DGSCH1,"^",I)']"" S DGERR=1 W !?4,"> ",$P(DGERSUB,"^",I)," is not specified."
I $P(DGSCH1,"^",10)="W",$P(DGSCH1,"^",8)']"" S DGERR=1 W !?4,"> WARD location to which admit is scheduled is not specified."
I $P(DGSCH1,"^",10)="T",$P(DGSCH1,"^",9)']"" S DGERR=1 W !?4,"> TREATING SPECIALTY to which admit is scheduled is unspecified."
W !!,*7,"[",$S('DGERR:"ADMISSION HAS BEEN",1:"NOTHING")," SCHEDULED",$S('DGERR:"",1:"...ACTION DELETED"),"]" D:DGERR KILL Q
CA ;Check for missing CA data
W ! S DGERR=0,DGERR1="",DGERSUB="DATE/TIME CANCELLED^CANCELLED BY^REASON CANCELLED^WAS PATIENT NOTIFIED",DGSCH1=$S($D(^DGS(41.1,+DGSCH,0)):^(0),1:"") I DGSCH1']"" Q
F I=13:1:16 S:$P(DGSCH1,"^",I)]"" DGERR1=DGERR1_I_"///@;" I $P(DGSCH1,"^",I)']"" W !?4,"> ",$P(DGERSUB,"^",I-12)," is unspecified." S DGERR=1
W !!,*7,"...Scheduled Admission has ",$S(DGERR:"not ",1:""),"been Cancelled..." Q:'DGERR I $L(DGERR1) S DIE="^DGS(41.1,",DIC(0)="AEQMZ",DR=DGERR1 D ^DIE K DR
Q
WARN D Q D:'$D(DT) DT^DICRW Q
KILL S DIK="^DGS(41.1,",DA=DGSCH D ^DIK K DIK Q
Q K DGNEW,DGERR,DGERR1,DGERSUB,DGSCH,DGSCH1,DFN1,DIC,DIE,DR,X,Y,DGSDIV,DA,DIK,I Q
OREN D Q S XQORQUIT=1,DGNEW=0,DIC(0)="ELN",X=+ORVP D 11 Q
;
WACT(DGW,DGDT) ;ward active on scheduled admit date?
; input: DGW = ien of WARD LOCATION file
; DGDT = date of interest - defaults to DT
; returns: 1 if active
; 0 if inactive (out-of-service)
; -1 if error
;
N DGX,DGY
I '$D(DGW) Q -1
I '$D(^DIC(42,DGW,0)) Q -1
S DGY=$S($D(DGDT):DGDT,1:DT) I $P(DGY,".",1)'?7N Q -1
S DGX=+$O(^DIC(42,DGW,"OOS","B",DGY+.1),-1),DGX=$S($D(^DIC(42,DGW,"OOS",+$O(^(+DGX,0)),0)):^(0),1:"")
I '$P(DGX,U,6) Q 1
I $P(DGX,U,6),'$P(DGX,U,4) Q 0
I $P(DGX,U,6),$P(DGX,U,4)'>DGY Q 1
Q 0
DGSCHAD ;ALB/MRL - SCHEDULED ADMISSIONS ENTRY/CANCEL ;12/4/91 14:14 ;
+1 ;;5.3;Registration;**117,187,1015**;Aug 13, 1993;Build 21
+2 ;OERR MODIFICATIONS
1 ;Schedule Admission
+1 DO Q
SET DGNEW=0
KILL ORACTION
IF $DATA(DGSKIP)
GOTO Q
WRITE !!
SET DIC("A")="Schedule admission for patient: "
SET DIC(0)="AEZQLM"
11 SET DLAYGO=41.1
SET DIC("S")="I '$P(^DGS(41.1,+Y,0),""^"",13)"
SET DIC="^DGS(41.1,"
DO ^DIC
KILL DLAYGO,DIC("S"),DIC("A")
IF Y'>0
GOTO Q
SET DGSCH=+Y
SET DFN=+$PIECE(Y,"^",2)
EN SET DGNEW=+$PIECE(Y,U,3)
IF 'DGNEW&($DATA(ORACTION))
WRITE !,"Editing is not allowed through this option, only adding",*7,!
GOTO Q
+1 IF $DATA(^DPT(+$PIECE(^(0),"^",1),.35))
IF +^(.35)
SET Y=^(.35)
XECUTE ^DD("DD")
WRITE !!,*7,"PATIENT DIED ON ",Y,"...CAN'T SCHEDULED ADMIT FOR EXPIRED PATIENT!!"
IF DGNEW
DO KILL
IF $DATA(ORACTION)
GOTO Q
IF '$DATA(DGSKIP)
GOTO 1
GOTO Q
+2 SET (DA,Y)=DGSCH
SET DR="[DGSCHADMIT]"
SET DIE=DIC
DO DIV^DGUTL
DO ^DIE
DO SA
IF DGERR
GOTO 1
IF $SELECT('$DATA(^DGS(41.1,"B",DFN)):1,'$DATA(^DPT(DFN,.3)):1,$PIECE(^DPT(DFN,.3),"^",1)'="N":1,1:0)
IF $DATA(ORACTION)
GOTO Q
IF '$DATA(DGSKIP)
GOTO 1
GOTO Q
+3 KILL DFN1,DGPMDA,DGJJ
IF $DATA(DGSKIP)
GOTO Q
TP WRITE !
DO ASK^DGBLRV
+1 IF $DATA(ORACTION)
GOTO Q
IF '$DATA(DGPMDA)
GOTO 1
QUIT
2 ;Cancel Scheduled Admission
+1 DO WARN
WRITE !!
SET DIC("A")="Cancel scheduled admission for patient: "
SET DIC("S")="I '$P(^DGS(41.1,+Y,0),""^"",13)"
SET DIC(0)="AEZQM"
SET DIC="^DGS(41.1,"
DO ^DIC
KILL DIC("A"),DIC("S")
IF Y'>0
GOTO Q
SET DGSCH=+Y
+2 WRITE !!,*7,"All questions must be answered or this scheduled admission won't be cancelled!!"
SET (DA,Y)=DGSCH
SET DIE=DIC
SET DR="13;14////^S X=DUZ;15;16;"
DO ^DIE
DO CA
DO Q
GOTO 2
+3 QUIT
SA ;Check SA for missing data
+1 WRITE !
SET DGSCH1=$SELECT($DATA(^DGS(41.1,+DGSCH,0)):^(0),1:"")
IF DGSCH1']""
SET DGERR=0
QUIT
+2 SET DGERR=0
SET DGERSUB="PATIENT NAME^DATE OF RESERVATION^LENGTH OF STAY EXPECTED^ADMITTING DIAGNOSIS^PROVIDER^SURGERY^OPT/NSC STATUS^^^WARD OR TREATING SPECIALTY^^DIVISION"
+3 FOR I=1,2,4,5,10,12
IF $PIECE(DGSCH1,"^",I)']""
SET DGERR=1
WRITE !?4,"> ",$PIECE(DGERSUB,"^",I)," is not specified."
+4 IF $PIECE(DGSCH1,"^",10)="W"
IF $PIECE(DGSCH1,"^",8)']""
SET DGERR=1
WRITE !?4,"> WARD location to which admit is scheduled is not specified."
+5 IF $PIECE(DGSCH1,"^",10)="T"
IF $PIECE(DGSCH1,"^",9)']""
SET DGERR=1
WRITE !?4,"> TREATING SPECIALTY to which admit is scheduled is unspecified."
+6 WRITE !!,*7,"[",$SELECT('DGERR:"ADMISSION HAS BEEN",1:"NOTHING")," SCHEDULED",$SELECT('DGERR:"",1:"...ACTION DELETED"),"]"
IF DGERR
DO KILL
QUIT
CA ;Check for missing CA data
+1 WRITE !
SET DGERR=0
SET DGERR1=""
SET DGERSUB="DATE/TIME CANCELLED^CANCELLED BY^REASON CANCELLED^WAS PATIENT NOTIFIED"
SET DGSCH1=$SELECT($DATA(^DGS(41.1,+DGSCH,0)):^(0),1:"")
IF DGSCH1']""
QUIT
+2 FOR I=13:1:16
IF $PIECE(DGSCH1,"^",I)]""
SET DGERR1=DGERR1_I_"///@;"
IF $PIECE(DGSCH1,"^",I)']""
WRITE !?4,"> ",$PIECE(DGERSUB,"^",I-12)," is unspecified."
SET DGERR=1
+3 WRITE !!,*7,"...Scheduled Admission has ",$SELECT(DGERR:"not ",1:""),"been Cancelled..."
IF 'DGERR
QUIT
IF $LENGTH(DGERR1)
SET DIE="^DGS(41.1,"
SET DIC(0)="AEQMZ"
SET DR=DGERR1
DO ^DIE
KILL DR
+4 QUIT
WARN DO Q
IF '$DATA(DT)
DO DT^DICRW
QUIT
KILL SET DIK="^DGS(41.1,"
SET DA=DGSCH
DO ^DIK
KILL DIK
QUIT
Q KILL DGNEW,DGERR,DGERR1,DGERSUB,DGSCH,DGSCH1,DFN1,DIC,DIE,DR,X,Y,DGSDIV,DA,DIK,I
QUIT
OREN DO Q
SET XQORQUIT=1
SET DGNEW=0
SET DIC(0)="ELN"
SET X=+ORVP
DO 11
QUIT
+1 ;
WACT(DGW,DGDT) ;ward active on scheduled admit date?
+1 ; input: DGW = ien of WARD LOCATION file
+2 ; DGDT = date of interest - defaults to DT
+3 ; returns: 1 if active
+4 ; 0 if inactive (out-of-service)
+5 ; -1 if error
+6 ;
+7 NEW DGX,DGY
+8 IF '$DATA(DGW)
QUIT -1
+9 IF '$DATA(^DIC(42,DGW,0))
QUIT -1
+10 SET DGY=$SELECT($DATA(DGDT):DGDT,1:DT)
IF $PIECE(DGY,".",1)'?7N
QUIT -1
+11 SET DGX=+$ORDER(^DIC(42,DGW,"OOS","B",DGY+.1),-1)
SET DGX=$SELECT($DATA(^DIC(42,DGW,"OOS",+$ORDER(^(+DGX,0)),0)):^(0),1:"")
+12 IF '$PIECE(DGX,U,6)
QUIT 1
+13 IF $PIECE(DGX,U,6)
IF '$PIECE(DGX,U,4)
QUIT 0
+14 IF $PIECE(DGX,U,6)
IF $PIECE(DGX,U,4)'>DGY
QUIT 1
+15 QUIT 0
