- 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
