DGSCHAD ;ALB/MRL - SCHEDULED ADMISSIONS ENTRY/CANCEL ;Sep 22, 2020@08:37
;;5.3;Registration;**117,187,1020**;Aug 13, 1993;Build 11
;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
NOTIFY(OLDVAL,NEWVAL,DA,TYPE) ;queue data change messages
;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
I (($G(TYPE)="KILL")&($G(NEWVAL(1))'=""))!($G(XPDNM)'="") Q
N NODE1,NODE2,DATE,ACTION,FIELD,IENS,EXIT,FIELDS,HISTACT
S DATE=$$NOW^XLFDT,IENS=$$IENS^DILF(.DA),NODE1="DG SA FILE ENTRY NOTIFIER"
S NODE2=$G(^XTMP(NODE1,"B",IENS)),HISTACT="",EXIT=0
I NODE2'="" S HISTACT=$G(^XTMP(NODE1,NODE2,"ACTION"))
I $G(TYPE)="SET" D Q:EXIT
.S ACTION=$S($G(OLDVAL(1))="":"CREATED",1:"MODIFIED")
.I HISTACT="CREATED" D
..D GETFIELDS(.OLDVAL,.NEWVAL,.FIELDS)
..I ACTION="CREATED" D
...I $D(FIELDS) M ^XTMP(NODE1,NODE2,"FIELDS")=FIELDS
...S EXIT=1
..I ACTION="MODIFIED" D
...I '$D(FIELDS) S EXIT=1 Q
...S ACTION="CREATED"
.I HISTACT="DELETED" S NODE2=""
I $G(TYPE)="KILL" D Q:NODE2'=""
.S ACTION="DELETED"
.Q:NODE2=""
.K ^XTMP(NODE1,NODE2),^XTMP(NODE1,"B",IENS)
.I $O(^XTMP(NODE1,0))="" K ^XTMP(NODE1)
.I HISTACT'="CREATED" S NODE2=""
I $G(NODE2)="" S NODE2=1+$O(^XTMP(NODE1,"?"),-1)
I ACTION="MODIFIED",'$D(FIELDS) D GETFIELDS(.OLDVAL,.NEWVAL,.FIELDS) Q:'$D(FIELDS)
I ACTION'=HISTACT D
.S ^XTMP(NODE1,0)=$$FMADD^XLFDT(DT,3)_U_DT_U_"SA FILE ENTRY NOTIFIER DATA"
.S ^XTMP(NODE1,NODE2,"DATE")=DATE
.S ^XTMP(NODE1,NODE2,"IEN")=IENS
.S ^XTMP(NODE1,NODE2,"ACTION")=ACTION
.S ^XTMP(NODE1,NODE2,"DFN","CURRENT")=NEWVAL(1)
.S ^XTMP(NODE1,NODE2,"DFN","OLD")=OLDVAL(1)
.S ^XTMP(NODE1,"B",IENS)=NODE2
I $D(FIELDS) M ^XTMP(NODE1,NODE2,"FIELDS")=FIELDS
Q
GETFIELDS(OLDVAL,NEWVAL,FIELDS) ;return modified fields
N FIELD
S FIELD=0 F S FIELD=$O(OLDVAL(FIELD)) Q:'+FIELD D
.I OLDVAL(FIELD)=$G(NEWVAL(FIELD))!(NEWVAL(FIELD)=U) Q
.S FIELDS($S(FIELD=1:.01,1:FIELD))=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGSCHAD 5300 printed Nov 22, 2024@18:08:46 Page 2
DGSCHAD ;ALB/MRL - SCHEDULED ADMISSIONS ENTRY/CANCEL ;Sep 22, 2020@08:37
+1 ;;5.3;Registration;**117,187,1020**;Aug 13, 1993;Build 11
+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
NOTIFY(OLDVAL,NEWVAL,DA,TYPE) ;queue data change messages
+1 ;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
+2 ;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
+3 IF (($GET(TYPE)="KILL")&($GET(NEWVAL(1))'=""))!($GET(XPDNM)'="")
QUIT
+4 NEW NODE1,NODE2,DATE,ACTION,FIELD,IENS,EXIT,FIELDS,HISTACT
+5 SET DATE=$$NOW^XLFDT
SET IENS=$$IENS^DILF(.DA)
SET NODE1="DG SA FILE ENTRY NOTIFIER"
+6 SET NODE2=$GET(^XTMP(NODE1,"B",IENS))
SET HISTACT=""
SET EXIT=0
+7 IF NODE2'=""
SET HISTACT=$GET(^XTMP(NODE1,NODE2,"ACTION"))
+8 IF $GET(TYPE)="SET"
Begin DoDot:1
+9 SET ACTION=$SELECT($GET(OLDVAL(1))="":"CREATED",1:"MODIFIED")
+10 IF HISTACT="CREATED"
Begin DoDot:2
+11 DO GETFIELDS(.OLDVAL,.NEWVAL,.FIELDS)
+12 IF ACTION="CREATED"
Begin DoDot:3
+13 IF $DATA(FIELDS)
MERGE ^XTMP(NODE1,NODE2,"FIELDS")=FIELDS
+14 SET EXIT=1
End DoDot:3
+15 IF ACTION="MODIFIED"
Begin DoDot:3
+16 IF '$DATA(FIELDS)
SET EXIT=1
QUIT
+17 SET ACTION="CREATED"
End DoDot:3
End DoDot:2
+18 IF HISTACT="DELETED"
SET NODE2=""
End DoDot:1
if EXIT
QUIT
+19 IF $GET(TYPE)="KILL"
Begin DoDot:1
+20 SET ACTION="DELETED"
+21 if NODE2=""
QUIT
+22 KILL ^XTMP(NODE1,NODE2),^XTMP(NODE1,"B",IENS)
+23 IF $ORDER(^XTMP(NODE1,0))=""
KILL ^XTMP(NODE1)
+24 IF HISTACT'="CREATED"
SET NODE2=""
End DoDot:1
if NODE2'=""
QUIT
+25 IF $GET(NODE2)=""
SET NODE2=1+$ORDER(^XTMP(NODE1,"?"),-1)
+26 IF ACTION="MODIFIED"
IF '$DATA(FIELDS)
DO GETFIELDS(.OLDVAL,.NEWVAL,.FIELDS)
if '$DATA(FIELDS)
QUIT
+27 IF ACTION'=HISTACT
Begin DoDot:1
+28 SET ^XTMP(NODE1,0)=$$FMADD^XLFDT(DT,3)_U_DT_U_"SA FILE ENTRY NOTIFIER DATA"
+29 SET ^XTMP(NODE1,NODE2,"DATE")=DATE
+30 SET ^XTMP(NODE1,NODE2,"IEN")=IENS
+31 SET ^XTMP(NODE1,NODE2,"ACTION")=ACTION
+32 SET ^XTMP(NODE1,NODE2,"DFN","CURRENT")=NEWVAL(1)
+33 SET ^XTMP(NODE1,NODE2,"DFN","OLD")=OLDVAL(1)
+34 SET ^XTMP(NODE1,"B",IENS)=NODE2
End DoDot:1
+35 IF $DATA(FIELDS)
MERGE ^XTMP(NODE1,NODE2,"FIELDS")=FIELDS
+36 QUIT
GETFIELDS(OLDVAL,NEWVAL,FIELDS) ;return modified fields
+1 NEW FIELD
+2 SET FIELD=0
FOR
SET FIELD=$ORDER(OLDVAL(FIELD))
if '+FIELD
QUIT
Begin DoDot:1
+3 IF OLDVAL(FIELD)=$GET(NEWVAL(FIELD))!(NEWVAL(FIELD)=U)
QUIT
+4 SET FIELDS($SELECT(FIELD=1:.01,1:FIELD))=""
End DoDot:1
+5 QUIT
