SDCOAM ;ALB/RMO - Appt Mgmt Actions - Check Out; 11 FEB 1993 10:00 am
;;5.3;Scheduling;**1,20,27,66,132,1001,1012,1015**;08/13/93;Build 21
;IHS/ITSC/LJF 10/10/2003 removed requirement for SD SUPERVISOR key on Delete Check-out
;cmi/flag/maw 06/02/2010 PATCH 1012 RQMT149 added for check of appt in list view DEL
;
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
;
;IHS/ITSC/LJF 10/10/2003 no reason for key in IHS since check-out not associated with visit coding
;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)
..I $P(SDAT,U,6)]"" W !!,*7,">>> This is not a valid appointment." D PAUSE^VALM1 Q ;cmi/maw 6/2/2010 PATCH 1012 for list view
..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
;IHS/ITSC/LJF 6/2/2004 PATCH #1001 remove VA warning.
;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)
SDCOAM ;ALB/RMO - Appt Mgmt Actions - Check Out; 11 FEB 1993 10:00 am
+1 ;;5.3;Scheduling;**1,20,27,66,132,1001,1012,1015**;08/13/93;Build 21
+2 ;IHS/ITSC/LJF 10/10/2003 removed requirement for SD SUPERVISOR key on Delete Check-out
+3 ;cmi/flag/maw 06/02/2010 PATCH 1012 RQMT149 added for check of appt in list view DEL
+4 ;
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 ;
+2 ;IHS/ITSC/LJF 10/10/2003 no reason for key in IHS since check-out not associated with visit coding
+3 ;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
+4 ;
+5 NEW DFN,SDCL,SDCOAP,SDDA,SDOE,SDT,VALMY,VALSTP
+6 ;VALSTP is used in scdxhldr to identify deletes
SET VALMBCK=""
SET VALSTP=""
+7 DO EN^VALM2(XQORNOD(0))
+8 DO FULL^VALM1
+9 SET SDCOAP=0
+10 FOR
SET SDCOAP=$ORDER(VALMY(SDCOAP))
IF 'SDCOAP
QUIT
Begin DoDot:1
+11 IF $DATA(^TMP("SDAMIDX",$JOB,SDCOAP))
KILL SDAT
SET SDAT=^(SDCOAP)
Begin DoDot:2
+12 WRITE !!,^TMP("SDAM",$JOB,+SDAT,0)
+13 ;cmi/maw 6/2/2010 PATCH 1012 for list view
IF $PIECE(SDAT,U,6)]""
WRITE !!,*7,">>> This is not a valid appointment."
DO PAUSE^VALM1
QUIT
+14 SET DFN=+$PIECE(SDAT,"^",2)
SET SDT=+$PIECE(SDAT,"^",3)
SET SDCL=+$PIECE(SDAT,"^",4)
SET SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
+15 SET SDOE=+$PIECE($GET(^DPT(DFN,"S",SDT,0)),"^",20)
+16 IF 'SDOE!('$$CODT^SDCOU(DFN,SDT,SDCL))
WRITE !!,*7,">>> The appointment must have a check out date/time to delete."
DO PAUSE^VALM1
QUIT
+17 IF '$$ASK
QUIT
+18 NEW SDATA,SDELHDL
+19 IF '$$EDITOK^SDCO3(SDOE,1)
QUIT
+20 SET SDELHDL=$$HANDLE^SDAMEVT(1)
+21 DO EN^SDCODEL(SDOE,1,SDELHDL)
DO PAUSE^VALM1
+22 DO BLD^SDAM
+23 SET SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
End DoDot:2
End DoDot:1
+24 SET VALMBCK="R"
+25 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 ;IHS/ITSC/LJF 6/2/2004 PATCH #1001 remove VA warning.
+3 ;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."
+4 SET DIR("A")="Are you sure you want to delete the appointment check out"
+5 SET DIR("B")="NO"
SET DIR(0)="Y"
WRITE !
DO ^DIR
+6 QUIT +$GET(Y)
