SDAMEVT ;ALB/MJK - Appt Event Driver Utilities ; 12/1/91 [ 09/19/96 1:39 PM ]
;;5.3;Scheduling;**15,132,443,717**;Aug 13, 1993;Build 12
;;Per VHA Directive 2004-038, this routine should not be modified
;
BEFORE(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- get before values
K ^TMP("SDAMEVT",$J)
D CAPTURE("BEFORE",.SDATA,.DFN,.SDT,.SDCL,.SDDA,.SDHDL)
Q
;
AFTER(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- get after values
D CAPTURE("AFTER",.SDATA,.DFN,.SDT,.SDCL,.SDDA,.SDHDL)
Q
;
HANDLE(SDORG) ; -- get evt handle
; SDORG = originating process (1=appt , 2=a/e , 3=disp)
S (Y,^($J))=$G(^TMP("SDEVT HANDLE",$J))+1
Q Y
;
CLEAN(SDHDL) ;
K ^TMP("SDEVT",$J,SDHDL)
Q
;
HDLKILL ; -- kill off handle data
K SDHDL,^TMP("SDEVT HANDLE",$J),^TMP("SDEVT",$J)
Q
;
CAPTURE(SDCAP,SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ;
N Z
S (Z,^TMP("SDAMEVT",$J,SDCAP,"DPT"),^TMP("SDEVT",$J,SDHDL,1,"DPT",0,SDCAP))=$G(^DPT(DFN,"S",SDT,0))
S (^TMP("SDAMEVT",$J,SDCAP,"SC"),^TMP("SDEVT",$J,SDHDL,1,"SC",0,SDCAP))=$G(^SC(SDCL,"S",SDT,1,+SDDA,0))
S (^TMP("SDAMEVT",$J,SDCAP,"STATUS"),SDATA(SDCAP,"STATUS"))=$TR($$STATUS^SDAM1(DFN,SDT,SDCL,Z,SDDA),";","^")
D:$P(Z,U,20) OE(.SDCAP,1,$P(Z,U,20),.SDHDL)
Q
;
;
EVT(SDATA,SDAMEVT,SDMODE,SDHDL) ; -- calls the sdam event protocol
N OROLD
K DTOUT,DIROUT
I $G(SDATA("BEFORE","STATUS"))=$G(SDATA("AFTER","STATUS")),'$$COMP^SDAMEVT4(SDHDL,SDAMEVT) G EVTQ ; SD*5.3*443
S:$P(SDATA,U,3) $P(SDATA,U,5)=$$REQ^SDM1A(+$P(SDATA,U,3))
I SDMODE=2 N DGQUIET S DGQUIET=1 ;*zeb 10/4/18 717 set DGQUIET to suppress user interaction when called from GUI
S X=+$O(^ORD(101,"B","SDAM APPOINTMENT EVENTS",0))_";ORD(101,"
D EN^XQOR
EVTQ K XQORPOP,X,^TMP("SDAMEVT",$J) D CLEAN(SDHDL) Q
;
;
MAKE(DFN,SDT,SDCL,SDDA,SDMODE) ; -- make appt event #1
N SDATA,%,SDMKHDL,SDHDL K ^TMP("SDAMEVT",$J)
S SDMKHDL=$$HANDLE(1)
S (^TMP("SDAMEVT",$J,"BEFORE","DPT"),^TMP("SDAMEVT",$J,"BEFORE","SC"),SDATA("BEFORE","STATUS"),^TMP("SDAMEVT",$J,"BEFORE","STATUS"),^TMP("SDEVT",$J,SDMKHDL,1,"DPT",0,"BEFORE"),^TMP("SDEVT",$J,SDMKHDL,1,"SC",0,"BEFORE"))=""
D AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDMKHDL)
S SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D EVT(.SDATA,1,+$G(SDMODE),SDMKHDL) ;*zeb 10/25/18 717 fix typo with SDMODE so SDMODE is passed correctly
Q:SDMODE=2 ;*zeb 10/24/18 717 don't need check in/out code below if calling from GUI
; -- if appt d/t is less than NOW then check-in
D NOW^%DTC
I SDT<% W:'$G(SDMODE) ! D
.N SDACT,SDCOQUIT
.S SDDA=+SDATA,DFN=$P(SDATA,U,2),SDT=$P(SDATA,U,3),SDCL=$P(SDATA,U,4) K SDATA
.I $$REQ^SDM1A(SDT)="CO",'$G(SDCOACT) D
..S SDACT=$S(SDT<DT:"CO",1:$$ASK^SDAMEX) I SDACT']"" S SDCOQUIT=1 Q
..I SDACT="CO" D CO^SDCO1(DFN,SDT,SDCL,SDDA,0,SDT)
.I '$G(SDCOQUIT),$G(SDACT)'="CO" D ONE^SDAM2(DFN,SDCL,SDT,SDDA,0,SDT)
Q
;
;
CANCEL(SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDHDL) ; -- cancel event #2
D AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
I (SDMODE'=2),("^5^7^9^10^"[("^"_+SDATA("AFTER","STATUS")_"^")),($P($G(^DPT(DFN,"S",SDT,0)),"^",20)) D EN^SDCODEL(+$P(^(0),"^",20),0,SDHDL),OENUL^SDAMEVT1("AFTER",SDHDL) ;*zeb 10/25/18 717 status has already changed for GUI calls
S SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D EVT(.SDATA,2,$S(SDMODE=2:2,1:0),SDHDL) ;*zeb 10/25/18 717 don't assume SDMODE is 0 if it is 2
Q
;
;
NOSHOW(SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDHDL) ; -- no-show event #3
D AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
I "^4^6^"[("^"_+SDATA("AFTER","STATUS")_"^"),$P($G(^DPT(DFN,"S",SDT,0)),"^",20) D EN^SDCODEL(+$P(^(0),"^",20),0,SDHDL),OENUL^SDAMEVT1("AFTER",SDHDL)
S SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D EVT(.SDATA,3,0,SDHDL)
Q
;
OE(SDCAP,SDORG,SDOE,SDHDL) ; -- set up encounter data
N I,OP,FILE,X,SDKID
;
; -- set up 'OP'posite variable
S OP=$S(SDCAP="BEFORE":"AFTER",1:"BEFORE")
;
; -- set zero of oe
S X=$G(^SCE(SDOE,0))
S ^TMP("SDEVT",$J,SDHDL,SDORG,"SDOE",SDOE,0,SDCAP)=X
S:'$D(^TMP("SDEVT",$J,SDHDL,SDORG,"SDOE",SDOE,0,OP)) ^(OP)=""
;
; -- save other data
S FILE=409.42
S I=0 F S I=$O(^SDD(FILE,"OE",SDOE,I)) Q:'I D
. S X=$G(^SDD(FILE,I,0))
. S ^TMP("SDEVT",$J,SDHDL,SDORG,"SDOE",SDOE,"CL",I,0,SDCAP)=X
. S:'$D(^TMP("SDEVT",$J,SDHDL,SDORG,"SDOE",SDOE,"CL",I,0,OP)) ^(OP)=""
;
IF SDORG'=1,SDORG'=3 G OEQ
;
; -- gets children oe's
S SDKID=0
F S SDKID=$O(^SCE("APAR",SDOE,SDKID)) Q:'SDKID D
. S X=$G(^SCE(SDKID,0))
. IF $P(X,U,8)'=4 Q ; -- must be a credit stop encounter
. S ^TMP("SDEVT",$J,SDHDL,4,"SDOE",SDKID,0,SDCAP)=X
. S:'$D(^TMP("SDEVT",$J,SDHDL,4,"SDOE",SDKID,0,OP)) ^(OP)=""
OEQ Q
;
OECHG(SDORG,SDHDL) ; -- compare befores and afters
N Y,I,SDOE S (Y,SDOE)=0
F S SDOE=$O(^TMP("SDEVT",$J,SDHDL,SDORG,"SDOE",SDOE)) Q:'SDOE D Q:Y
. S I=0
. F S I=$O(^TMP("SDEVT",$J,SDHDL,SDORG,"SDOE",SDOE,"CL",I)) Q:'I I $G(^(I,0,"BEFORE"))='$G(^("AFTER")) S Y=1 Q
Q Y
;
OEVT(SDOE,SDCAP,SDHDL,SDATA,SDOE0) ; -- event driver calls by oe
; SDATA only required for appts
; SDOE0 only required for check out deletion AFTER
;
N SD0,SDORG,SDT,DFN,SDDA,SDCL,SDOEP
S SD0=$S($D(^SCE(SDOE,0)):^(0),1:$G(SDOE0)),SDOEP=$P(SD0,U,6)
I SD0']""!(SDOEP) G OEVTQ
S SDT=+SD0,DFN=+$P(SD0,U,2),SDCL=+$P(SD0,U,4),SDORG=+$P(SD0,U,8),SDDA=$P(SD0,U,9)
I SDCAP="BEFORE" D
.I SDORG=1 D BEFORE(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL) Q
.I SDORG=2 D BEFORE^SDAMEVT2(SDOE,SDHDL) Q
.I SDORG=3 D BEFORE^SDAMEVT3(DFN,SDT,9,SDHDL)
I SDCAP="AFTER" D
.I SDORG=1 S SDATA=SDDA_"^"_DFN_"^"_SDT_"^"_SDCL D AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL),EVT(.SDATA,5,0,SDHDL) Q
.I SDORG=2 D EVT^SDAMEVT2(SDOE,7,SDHDL) Q
.I SDORG=3 D EVT^SDAMEVT3(DFN,SDT,9,SDHDL)
OEVTQ Q
;
; -- SEE SDAMEVT0 FOR DOC ON VARIABLES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMEVT 5651 printed Dec 13, 2024@02:47:38 Page 2
SDAMEVT ;ALB/MJK - Appt Event Driver Utilities ; 12/1/91 [ 09/19/96 1:39 PM ]
+1 ;;5.3;Scheduling;**15,132,443,717**;Aug 13, 1993;Build 12
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
BEFORE(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- get before values
+1 KILL ^TMP("SDAMEVT",$JOB)
+2 DO CAPTURE("BEFORE",.SDATA,.DFN,.SDT,.SDCL,.SDDA,.SDHDL)
+3 QUIT
+4 ;
AFTER(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- get after values
+1 DO CAPTURE("AFTER",.SDATA,.DFN,.SDT,.SDCL,.SDDA,.SDHDL)
+2 QUIT
+3 ;
HANDLE(SDORG) ; -- get evt handle
+1 ; SDORG = originating process (1=appt , 2=a/e , 3=disp)
+2 SET (Y,^($JOB))=$GET(^TMP("SDEVT HANDLE",$JOB))+1
+3 QUIT Y
+4 ;
CLEAN(SDHDL) ;
+1 KILL ^TMP("SDEVT",$JOB,SDHDL)
+2 QUIT
+3 ;
HDLKILL ; -- kill off handle data
+1 KILL SDHDL,^TMP("SDEVT HANDLE",$JOB),^TMP("SDEVT",$JOB)
+2 QUIT
+3 ;
CAPTURE(SDCAP,SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ;
+1 NEW Z
+2 SET (Z,^TMP("SDAMEVT",$JOB,SDCAP,"DPT"),^TMP("SDEVT",$JOB,SDHDL,1,"DPT",0,SDCAP))=$GET(^DPT(DFN,"S",SDT,0))
+3 SET (^TMP("SDAMEVT",$JOB,SDCAP,"SC"),^TMP("SDEVT",$JOB,SDHDL,1,"SC",0,SDCAP))=$GET(^SC(SDCL,"S",SDT,1,+SDDA,0))
+4 SET (^TMP("SDAMEVT",$JOB,SDCAP,"STATUS"),SDATA(SDCAP,"STATUS"))=$TRANSLATE($$STATUS^SDAM1(DFN,SDT,SDCL,Z,SDDA),";","^")
+5 if $PIECE(Z,U,20)
DO OE(.SDCAP,1,$PIECE(Z,U,20),.SDHDL)
+6 QUIT
+7 ;
+8 ;
EVT(SDATA,SDAMEVT,SDMODE,SDHDL) ; -- calls the sdam event protocol
+1 NEW OROLD
+2 KILL DTOUT,DIROUT
+3 ; SD*5.3*443
IF $GET(SDATA("BEFORE","STATUS"))=$GET(SDATA("AFTER","STATUS"))
IF '$$COMP^SDAMEVT4(SDHDL,SDAMEVT)
GOTO EVTQ
+4 if $PIECE(SDATA,U,3)
SET $PIECE(SDATA,U,5)=$$REQ^SDM1A(+$PIECE(SDATA,U,3))
+5 ;*zeb 10/4/18 717 set DGQUIET to suppress user interaction when called from GUI
IF SDMODE=2
NEW DGQUIET
SET DGQUIET=1
+6 SET X=+$ORDER(^ORD(101,"B","SDAM APPOINTMENT EVENTS",0))_";ORD(101,"
+7 DO EN^XQOR
EVTQ KILL XQORPOP,X,^TMP("SDAMEVT",$JOB)
DO CLEAN(SDHDL)
QUIT
+1 ;
+2 ;
MAKE(DFN,SDT,SDCL,SDDA,SDMODE) ; -- make appt event #1
+1 NEW SDATA,%,SDMKHDL,SDHDL
KILL ^TMP("SDAMEVT",$JOB)
+2 SET SDMKHDL=$$HANDLE(1)
+3 SET (^TMP("SDAMEVT",$JOB,"BEFORE","DPT"),^TMP("SDAMEVT",$JOB,"BEFORE","SC"),SDATA("BEFORE","STATUS"),^TMP("SDAMEVT",$JOB,"BEFORE","STATUS"),^TMP("SDEVT",$JOB,SDMKHDL,1,"DPT",0,"BEFORE"),^TMP("SDEVT",$JOB,SDMKHDL,1,"SC",0,"BEFORE"))=""
+4 DO AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDMKHDL)
+5 SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
+6 ;*zeb 10/25/18 717 fix typo with SDMODE so SDMODE is passed correctly
DO EVT(.SDATA,1,+$GET(SDMODE),SDMKHDL)
+7 ;*zeb 10/24/18 717 don't need check in/out code below if calling from GUI
if SDMODE=2
QUIT
+8 ; -- if appt d/t is less than NOW then check-in
+9 DO NOW^%DTC
+10 IF SDT<%
if '$GET(SDMODE)
WRITE !
Begin DoDot:1
+11 NEW SDACT,SDCOQUIT
+12 SET SDDA=+SDATA
SET DFN=$PIECE(SDATA,U,2)
SET SDT=$PIECE(SDATA,U,3)
SET SDCL=$PIECE(SDATA,U,4)
KILL SDATA
+13 IF $$REQ^SDM1A(SDT)="CO"
IF '$GET(SDCOACT)
Begin DoDot:2
+14 SET SDACT=$SELECT(SDT<DT:"CO",1:$$ASK^SDAMEX)
IF SDACT']""
SET SDCOQUIT=1
QUIT
+15 IF SDACT="CO"
DO CO^SDCO1(DFN,SDT,SDCL,SDDA,0,SDT)
End DoDot:2
+16 IF '$GET(SDCOQUIT)
IF $GET(SDACT)'="CO"
DO ONE^SDAM2(DFN,SDCL,SDT,SDDA,0,SDT)
End DoDot:1
+17 QUIT
+18 ;
+19 ;
CANCEL(SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDHDL) ; -- cancel event #2
+1 DO AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
+2 ;*zeb 10/25/18 717 status has already changed for GUI calls
IF (SDMODE'=2)
IF ("^5^7^9^10^"[("^"_+SDATA("AFTER","STATUS")_"^"))
IF ($PIECE($GET(^DPT(DFN,"S",SDT,0)),"^",20))
DO EN^SDCODEL(+$PIECE(^(0),"^",20),0,SDHDL)
DO OENUL^SDAMEVT1("AFTER",SDHDL)
+3 SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
+4 ;*zeb 10/25/18 717 don't assume SDMODE is 0 if it is 2
DO EVT(.SDATA,2,$SELECT(SDMODE=2:2,1:0),SDHDL)
+5 QUIT
+6 ;
+7 ;
NOSHOW(SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDHDL) ; -- no-show event #3
+1 DO AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
+2 IF "^4^6^"[("^"_+SDATA("AFTER","STATUS")_"^")
IF $PIECE($GET(^DPT(DFN,"S",SDT,0)),"^",20)
DO EN^SDCODEL(+$PIECE(^(0),"^",20),0,SDHDL)
DO OENUL^SDAMEVT1("AFTER",SDHDL)
+3 SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
+4 DO EVT(.SDATA,3,0,SDHDL)
+5 QUIT
+6 ;
OE(SDCAP,SDORG,SDOE,SDHDL) ; -- set up encounter data
+1 NEW I,OP,FILE,X,SDKID
+2 ;
+3 ; -- set up 'OP'posite variable
+4 SET OP=$SELECT(SDCAP="BEFORE":"AFTER",1:"BEFORE")
+5 ;
+6 ; -- set zero of oe
+7 SET X=$GET(^SCE(SDOE,0))
+8 SET ^TMP("SDEVT",$JOB,SDHDL,SDORG,"SDOE",SDOE,0,SDCAP)=X
+9 if '$DATA(^TMP("SDEVT",$JOB,SDHDL,SDORG,"SDOE",SDOE,0,OP))
SET ^(OP)=""
+10 ;
+11 ; -- save other data
+12 SET FILE=409.42
+13 SET I=0
FOR
SET I=$ORDER(^SDD(FILE,"OE",SDOE,I))
if 'I
QUIT
Begin DoDot:1
+14 SET X=$GET(^SDD(FILE,I,0))
+15 SET ^TMP("SDEVT",$JOB,SDHDL,SDORG,"SDOE",SDOE,"CL",I,0,SDCAP)=X
+16 if '$DATA(^TMP("SDEVT",$JOB,SDHDL,SDORG,"SDOE",SDOE,"CL",I,0,OP))
SET ^(OP)=""
End DoDot:1
+17 ;
+18 IF SDORG'=1
IF SDORG'=3
GOTO OEQ
+19 ;
+20 ; -- gets children oe's
+21 SET SDKID=0
+22 FOR
SET SDKID=$ORDER(^SCE("APAR",SDOE,SDKID))
if 'SDKID
QUIT
Begin DoDot:1
+23 SET X=$GET(^SCE(SDKID,0))
+24 ; -- must be a credit stop encounter
IF $PIECE(X,U,8)'=4
QUIT
+25 SET ^TMP("SDEVT",$JOB,SDHDL,4,"SDOE",SDKID,0,SDCAP)=X
+26 if '$DATA(^TMP("SDEVT",$JOB,SDHDL,4,"SDOE",SDKID,0,OP))
SET ^(OP)=""
End DoDot:1
OEQ QUIT
+1 ;
OECHG(SDORG,SDHDL) ; -- compare befores and afters
+1 NEW Y,I,SDOE
SET (Y,SDOE)=0
+2 FOR
SET SDOE=$ORDER(^TMP("SDEVT",$JOB,SDHDL,SDORG,"SDOE",SDOE))
if 'SDOE
QUIT
Begin DoDot:1
+3 SET I=0
+4 FOR
SET I=$ORDER(^TMP("SDEVT",$JOB,SDHDL,SDORG,"SDOE",SDOE,"CL",I))
if 'I
QUIT
IF $GET(^(I,0,"BEFORE"))='$GET(^("AFTER"))
SET Y=1
QUIT
End DoDot:1
if Y
QUIT
+5 QUIT Y
+6 ;
OEVT(SDOE,SDCAP,SDHDL,SDATA,SDOE0) ; -- event driver calls by oe
+1 ; SDATA only required for appts
+2 ; SDOE0 only required for check out deletion AFTER
+3 ;
+4 NEW SD0,SDORG,SDT,DFN,SDDA,SDCL,SDOEP
+5 SET SD0=$SELECT($DATA(^SCE(SDOE,0)):^(0),1:$GET(SDOE0))
SET SDOEP=$PIECE(SD0,U,6)
+6 IF SD0']""!(SDOEP)
GOTO OEVTQ
+7 SET SDT=+SD0
SET DFN=+$PIECE(SD0,U,2)
SET SDCL=+$PIECE(SD0,U,4)
SET SDORG=+$PIECE(SD0,U,8)
SET SDDA=$PIECE(SD0,U,9)
+8 IF SDCAP="BEFORE"
Begin DoDot:1
+9 IF SDORG=1
DO BEFORE(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
QUIT
+10 IF SDORG=2
DO BEFORE^SDAMEVT2(SDOE,SDHDL)
QUIT
+11 IF SDORG=3
DO BEFORE^SDAMEVT3(DFN,SDT,9,SDHDL)
End DoDot:1
+12 IF SDCAP="AFTER"
Begin DoDot:1
+13 IF SDORG=1
SET SDATA=SDDA_"^"_DFN_"^"_SDT_"^"_SDCL
DO AFTER(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
DO EVT(.SDATA,5,0,SDHDL)
QUIT
+14 IF SDORG=2
DO EVT^SDAMEVT2(SDOE,7,SDHDL)
QUIT
+15 IF SDORG=3
DO EVT^SDAMEVT3(DFN,SDT,9,SDHDL)
End DoDot:1
OEVTQ QUIT
+1 ;
+2 ; -- SEE SDAMEVT0 FOR DOC ON VARIABLES
