SDCOAM ;ALB/RMO - Appt Mgmt Actions - Check Out; 11 FEB 1993 10:00 am
;;5.3;Scheduling;**1,20,27,66,132**;08/13/93
;
CO(SDCOACT,SDCOACTD) ;Check Out Classification, Provider and Diagnosis
; Actions on Appt Mgmt
N DFN,SDCL,SDCOAP,SDDA,SDOE,SDT,VALMY
S VALMBCK=""
D EN^VALM2(XQORNOD(0))
D FULL^VALM1
S SDCOAP=0
F S SDCOAP=$O(VALMY(SDCOAP)) Q:'SDCOAP D
.I $D(^TMP("SDAMIDX",$J,SDCOAP)) K SDAT S SDAT=^(SDCOAP) D
..W !!,^TMP("SDAM",$J,+SDAT,0)
..S DFN=+$P(SDAT,"^",2),SDT=+$P(SDAT,"^",3),SDCL=+$P(SDAT,"^",4),SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
..S SDOE=+$P($G(^DPT(DFN,"S",SDT,0)),"^",20)
..I 'SDOE!('$$CODT^SDCOU(DFN,SDT,SDCL)) W !!,*7,">>> The appointment must have a check out date/time to update ",SDCOACTD,"." D PAUSE^VALM1 Q
..D ACT(SDCOACT,SDOE,DFN,SDT,SDCL,SDDA,+SDAT)
S VALMBCK="R"
K SDAT
COQ Q
;
ACT(SDCOACT,SDOE,DFN,SDT,SDCL,SDDA,SDLNE) ; -- Check Out Actions
N SDCOMF,SDCOQUIT,SDHL,SDVISIT,SDATA,SDHDL
;
S SDVISIT=+$P($G(^SCE(+SDOE,0)),U,5)
;
; -- quit if not ok to edit
IF '$$EDITOK^SDCO3($G(SDOE),1) G ACTQ
;
; -- set pce action parameter
S SDPXACT=""
I $G(SDCOACT)="CL" S SDPXACT="SCC"
I $G(SDCOACT)="PR" S SDPXACT="PRV"
I $G(SDCOACT)="DX" S SDPXACT="POV"
I $G(SDCOACT)="CPT" S SDPXACT="CPT"
;
; -- quit if no action set
IF SDPXACT="" G ACTQ
;
; -- do pce interview then rebuild appt list
S X=$$INTV^PXAPI(SDPXACT,"SD","PIMS",.SDVISIT,.SDHL,DFN)
D BLD^SDAM
ACTQ Q
;
PD ;Entry point for SDAM PATIENT DEMOGRAPHICS protocol
N SDCOAP,VALMY
S VALMBCK=""
D FULL^VALM1
I SDAMTYP="P" W !!,VALMHDR(1),! D DEM(SDFN)
I SDAMTYP="C" D
.D EN^VALM2(XQORNOD(0))
.S SDCOAP=0 F S SDCOAP=$O(VALMY(SDCOAP)) Q:'SDCOAP D
..I $D(^TMP("SDAMIDX",$J,SDCOAP)) K SDAT S SDAT=^(SDCOAP) D
...W !!,^TMP("SDAM",$J,+SDAT,0),!
...D DEM(+$P(SDAT,"^",2))
S VALMBCK="R"
PDQ Q
;
DEM(DFN) ;Demographics
D QUES^DGRPU1(DFN,"ADD")
Q
;
DC ;Entry point for SDAM DISCHARGE CLINIC protocol
N SDCOAP,VALMY
S VALMBCK=""
D FULL^VALM1
I SDAMTYP="P" W !!,VALMHDR(1),! D DIS(SDFN)
I SDAMTYP="C" D
.D EN^VALM2(XQORNOD(0))
.S SDCOAP=0 F S SDCOAP=$O(VALMY(SDCOAP)) Q:'SDCOAP D
..I $D(^TMP("SDAMIDX",$J,SDCOAP)) K SDAT S SDAT=^(SDCOAP) D
...W !!,^TMP("SDAM",$J,+SDAT,0),!
...D DIS(+$P(SDAT,"^",2),$P(SDAT,"^",4))
S VALMBCK="R"
DCQ Q
;
DIS(SDFN,SDCLN) ;Discharge from Clinic
N SDAMERR
D ^SDCD
I $D(SDAMERR) D PAUSE^VALM1
Q
;
DEL ;Entry point for SDAM DELETE CHECK OUT protocol
I '$D(^XUSEC("SD SUPERVISOR",DUZ)) W !!,*7,">>> You must have the 'SD SUPERVISOR' key to delete an appointment check out." D PAUSE^VALM1 S VALMBCK="R" G DELQ
N DFN,SDCL,SDCOAP,SDDA,SDOE,SDT,VALMY,VALSTP
S VALMBCK="",VALSTP="" ;VALSTP is used in scdxhldr to identify deletes
D EN^VALM2(XQORNOD(0))
D FULL^VALM1
S SDCOAP=0
F S SDCOAP=$O(VALMY(SDCOAP)) Q:'SDCOAP D
.I $D(^TMP("SDAMIDX",$J,SDCOAP)) K SDAT S SDAT=^(SDCOAP) D
..W !!,^TMP("SDAM",$J,+SDAT,0)
..S DFN=+$P(SDAT,"^",2),SDT=+$P(SDAT,"^",3),SDCL=+$P(SDAT,"^",4),SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
..S SDOE=+$P($G(^DPT(DFN,"S",SDT,0)),"^",20)
..I 'SDOE!('$$CODT^SDCOU(DFN,SDT,SDCL)) W !!,*7,">>> The appointment must have a check out date/time to delete." D PAUSE^VALM1 Q
..I '$$ASK Q
..N SDATA,SDELHDL
..IF '$$EDITOK^SDCO3(SDOE,1) Q
..S SDELHDL=$$HANDLE^SDAMEVT(1)
..D EN^SDCODEL(SDOE,1,SDELHDL),PAUSE^VALM1
..D BLD^SDAM
..S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
S VALMBCK="R"
K SDAT
DELQ Q
;
ASK() ;Ask if user is sure they want to delete the check out
N DIR,DTOUT,DUOUT,Y
W !!,*7,">>> Deleting the appointment check out will also delete any check out related",!?4,"information. This information may include classifications, procedures,",!?4,"providers and diagnoses."
S DIR("A")="Are you sure you want to delete the appointment check out"
S DIR("B")="NO",DIR(0)="Y" W ! D ^DIR
Q +$G(Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCOAM 3900 printed Nov 22, 2024@17:59:31 Page 2
SDCOAM ;ALB/RMO - Appt Mgmt Actions - Check Out; 11 FEB 1993 10:00 am
+1 ;;5.3;Scheduling;**1,20,27,66,132**;08/13/93
+2 ;
CO(SDCOACT,SDCOACTD) ;Check Out Classification, Provider and Diagnosis
+1 ; Actions on Appt Mgmt
+2 NEW DFN,SDCL,SDCOAP,SDDA,SDOE,SDT,VALMY
+3 SET VALMBCK=""
+4 DO EN^VALM2(XQORNOD(0))
+5 DO FULL^VALM1
+6 SET SDCOAP=0
+7 FOR
SET SDCOAP=$ORDER(VALMY(SDCOAP))
if 'SDCOAP
QUIT
Begin DoDot:1
+8 IF $DATA(^TMP("SDAMIDX",$JOB,SDCOAP))
KILL SDAT
SET SDAT=^(SDCOAP)
Begin DoDot:2
+9 WRITE !!,^TMP("SDAM",$JOB,+SDAT,0)
+10 SET DFN=+$PIECE(SDAT,"^",2)
SET SDT=+$PIECE(SDAT,"^",3)
SET SDCL=+$PIECE(SDAT,"^",4)
SET SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
+11 SET SDOE=+$PIECE($GET(^DPT(DFN,"S",SDT,0)),"^",20)
+12 IF 'SDOE!('$$CODT^SDCOU(DFN,SDT,SDCL))
WRITE !!,*7,">>> The appointment must have a check out date/time to update ",SDCOACTD,"."
DO PAUSE^VALM1
QUIT
+13 DO ACT(SDCOACT,SDOE,DFN,SDT,SDCL,SDDA,+SDAT)
End DoDot:2
End DoDot:1
+14 SET VALMBCK="R"
+15 KILL SDAT
COQ QUIT
+1 ;
ACT(SDCOACT,SDOE,DFN,SDT,SDCL,SDDA,SDLNE) ; -- Check Out Actions
+1 NEW SDCOMF,SDCOQUIT,SDHL,SDVISIT,SDATA,SDHDL
+2 ;
+3 SET SDVISIT=+$PIECE($GET(^SCE(+SDOE,0)),U,5)
+4 ;
+5 ; -- quit if not ok to edit
+6 IF '$$EDITOK^SDCO3($GET(SDOE),1)
GOTO ACTQ
+7 ;
+8 ; -- set pce action parameter
+9 SET SDPXACT=""
+10 IF $GET(SDCOACT)="CL"
SET SDPXACT="SCC"
+11 IF $GET(SDCOACT)="PR"
SET SDPXACT="PRV"
+12 IF $GET(SDCOACT)="DX"
SET SDPXACT="POV"
+13 IF $GET(SDCOACT)="CPT"
SET SDPXACT="CPT"
+14 ;
+15 ; -- quit if no action set
+16 IF SDPXACT=""
GOTO ACTQ
+17 ;
+18 ; -- do pce interview then rebuild appt list
+19 SET X=$$INTV^PXAPI(SDPXACT,"SD","PIMS",.SDVISIT,.SDHL,DFN)
+20 DO BLD^SDAM
ACTQ QUIT
+1 ;
PD ;Entry point for SDAM PATIENT DEMOGRAPHICS protocol
+1 NEW SDCOAP,VALMY
+2 SET VALMBCK=""
+3 DO FULL^VALM1
+4 IF SDAMTYP="P"
WRITE !!,VALMHDR(1),!
DO DEM(SDFN)
+5 IF SDAMTYP="C"
Begin DoDot:1
+6 DO EN^VALM2(XQORNOD(0))
+7 SET SDCOAP=0
FOR
SET SDCOAP=$ORDER(VALMY(SDCOAP))
if 'SDCOAP
QUIT
Begin DoDot:2
+8 IF $DATA(^TMP("SDAMIDX",$JOB,SDCOAP))
KILL SDAT
SET SDAT=^(SDCOAP)
Begin DoDot:3
+9 WRITE !!,^TMP("SDAM",$JOB,+SDAT,0),!
+10 DO DEM(+$PIECE(SDAT,"^",2))
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET VALMBCK="R"
PDQ QUIT
+1 ;
DEM(DFN) ;Demographics
+1 DO QUES^DGRPU1(DFN,"ADD")
+2 QUIT
+3 ;
DC ;Entry point for SDAM DISCHARGE CLINIC protocol
+1 NEW SDCOAP,VALMY
+2 SET VALMBCK=""
+3 DO FULL^VALM1
+4 IF SDAMTYP="P"
WRITE !!,VALMHDR(1),!
DO DIS(SDFN)
+5 IF SDAMTYP="C"
Begin DoDot:1
+6 DO EN^VALM2(XQORNOD(0))
+7 SET SDCOAP=0
FOR
SET SDCOAP=$ORDER(VALMY(SDCOAP))
if 'SDCOAP
QUIT
Begin DoDot:2
+8 IF $DATA(^TMP("SDAMIDX",$JOB,SDCOAP))
KILL SDAT
SET SDAT=^(SDCOAP)
Begin DoDot:3
+9 WRITE !!,^TMP("SDAM",$JOB,+SDAT,0),!
+10 DO DIS(+$PIECE(SDAT,"^",2),$PIECE(SDAT,"^",4))
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET VALMBCK="R"
DCQ QUIT
+1 ;
DIS(SDFN,SDCLN) ;Discharge from Clinic
+1 NEW SDAMERR
+2 DO ^SDCD
+3 IF $DATA(SDAMERR)
DO PAUSE^VALM1
+4 QUIT
+5 ;
DEL ;Entry point for SDAM DELETE CHECK OUT protocol
+1 IF '$DATA(^XUSEC("SD SUPERVISOR",DUZ))
WRITE !!,*7,">>> You must have the 'SD SUPERVISOR' key to delete an appointment check out."
DO PAUSE^VALM1
SET VALMBCK="R"
GOTO DELQ
+2 NEW DFN,SDCL,SDCOAP,SDDA,SDOE,SDT,VALMY,VALSTP
+3 ;VALSTP is used in scdxhldr to identify deletes
SET VALMBCK=""
SET VALSTP=""
+4 DO EN^VALM2(XQORNOD(0))
+5 DO FULL^VALM1
+6 SET SDCOAP=0
+7 FOR
SET SDCOAP=$ORDER(VALMY(SDCOAP))
if 'SDCOAP
QUIT
Begin DoDot:1
+8 IF $DATA(^TMP("SDAMIDX",$JOB,SDCOAP))
KILL SDAT
SET SDAT=^(SDCOAP)
Begin DoDot:2
+9 WRITE !!,^TMP("SDAM",$JOB,+SDAT,0)
+10 SET DFN=+$PIECE(SDAT,"^",2)
SET SDT=+$PIECE(SDAT,"^",3)
SET SDCL=+$PIECE(SDAT,"^",4)
SET SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
+11 SET SDOE=+$PIECE($GET(^DPT(DFN,"S",SDT,0)),"^",20)
+12 IF 'SDOE!('$$CODT^SDCOU(DFN,SDT,SDCL))
WRITE !!,*7,">>> The appointment must have a check out date/time to delete."
DO PAUSE^VALM1
QUIT
+13 IF '$$ASK
QUIT
+14 NEW SDATA,SDELHDL
+15 IF '$$EDITOK^SDCO3(SDOE,1)
QUIT
+16 SET SDELHDL=$$HANDLE^SDAMEVT(1)
+17 DO EN^SDCODEL(SDOE,1,SDELHDL)
DO PAUSE^VALM1
+18 DO BLD^SDAM
+19 SET SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
End DoDot:2
End DoDot:1
+20 SET VALMBCK="R"
+21 KILL SDAT
DELQ QUIT
+1 ;
ASK() ;Ask if user is sure they want to delete the check out
+1 NEW DIR,DTOUT,DUOUT,Y
+2 WRITE !!,*7,">>> Deleting the appointment check out will also delete any check out related",!?4,"information. This information may include classifications, procedures,",!?4,"providers and diagnoses."
+3 SET DIR("A")="Are you sure you want to delete the appointment check out"
+4 SET DIR("B")="NO"
SET DIR(0)="Y"
WRITE !
DO ^DIR
+5 QUIT +$GET(Y)
