SDAMEP ;ALB/CAW - Extended Display ; 16 May 2001 1:46 PM ; Compiled August 4, 2010 10:18:29
;;5.3;PIMS;**241,334,480,1001,1012,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/LJF 7/12/2000 rerouted to IHS display format
;ihs/cmi/maw 06/01/2012 added call to patient wellness handout
;
EN ; Selection of appointment
K ^TMP("SDAMEP",$J)
S VALMBCK=""
D SEL G ENQ:'$D(SDW)!(SDERR)
;
;IHS/ITSC/WAR 11/26/2004 PATCH #1001 Need DFN defined prior to PID^VADPT call
S DFN=$P(^TMP("SDAMIDX",$J,SDW),U,2)
;IHS/ANMC/LJF 7/12/2000
D PID^VADPT
S DFN=$P(^TMP("SDAMIDX",$J,SDW),U,2),SDT=$P(^(SDW),U,3),SDCL=$P(^(SDW),U,4),SDDA=$P(^(SDW),U,5),SDLN=0
S SDWLE=$P(^TMP("SDAMIDX",$J,SDW),U,6) ;cmi/maw 6/1/2010 PATCH 1012 for wait list
I $G(SDWLE)]"" D EN^BSDAMEPW(SDWLE) Q ;cmi/maw 6/1/2010 PATCH 1012 for wait list
D EN^BSDAMEP Q
;IHS/ANMC/LJF 7/12/2000
;
N SDWIDTH,SDPT,SDSC,SDPTI,SDAMEP
W ! D WAIT^DICD
S DFN=$P(^TMP("SDAMIDX",$J,SDW),U,2)
D FULL^VALM1 S DIC=2,DIC(0)="EM",X="`"_DFN ;,SDAMEP=1
D ^DIC I Y<0 S VALMBCK="R" Q
D EN^VALM("SDAM APPT PROFILE")
S VALMBCK="R"
ENQ Q
;
HDR ; Header
N VA,VAERR
D PID^VADPT
S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(DFN,0)),"^",1),1,30)_" ("_VA("BID")_")"
S X=$S($D(^DPT(DFN,.1)):"Ward: "_^(.1),1:"Outpatient")
S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X))
S X="Clinic: "_$P(^SC(SDCL,0),U)
S VALMHDR(2)=$$SETSTR^VALM1(X,"Appointment #: "_SDW,81-$L(X),$L(X))
Q
;
INIT ;
N VA,VAERR,SDFSTCOL,SDSECCOL
D PID^VADPT
S SDT=$P(^TMP("SDAMIDX",$J,SDW),U,3),DFN=$P(^(SDW),U,2),SDCL=$P(^(SDW),U,4),SDDA=$P(^(SDW),U,5),SDLN=0 ;added DFN SD*5.3*480
D INIT^SDAMEP1
D APDATA^SDAMEP1 ; Appointment Data
D APLOG^SDAMEP3 ; Appointment Event Log
D PDATA^SDAMEP2 ; Patient Data
D APCO^SDAMEP4 ; Appointment Check Out Data
S VALMCNT=SDLN
Q
;
FNL ;
K SD,SDOE,SDSC,SDPT,SDLN,VALMCNT,SDEIC,SDI,SDX,SDW,SDEN,SDSTATE,SDERR,SDFLG,SDMT,SDT,DGPMVI,SDDISCH,SDPV,SDPOV,SDST,SDSTA,DIC ;SD*567 added DIC
D CLEAN^VALM10
Q
;
SEL ; -- select processing
N BG,LST,Y
S BG=+$O(@VALMAR@("IDX",VALMBG,0))
S LST=+$O(@VALMAR@("IDX",VALMLST,0))
I 'BG W !!,*7,"There are no '",VALM("ENTITY"),"s' to select.",! S DIR(0)="E" D ^DIR K DIR D OUT G SELQ
S Y=+$P($P(XQORNOD(0),U,4),"=",2)
I 'Y S DIR(0)="N^"_BG_":"_LST,DIR("A")="Select "_VALM("ENTITY")_"(s)" D ^DIR K DIR I $D(DIRUT) D OUT G SELQ
;
; -- check was valid entries
S SDERR=0,SDW=Y
I SDW<BG!(SDW>LST) D
.W !,*7,"Selection '",SDW,"' is not a valid choice."
.D OUT,PAUSE^VALM1
;
SELQ K DIRUT,DTOUT,DUOUT,DIROUT Q
;
OUT ;
S SDERR=1
Q
SDAMEP ;ALB/CAW - Extended Display ; 16 May 2001 1:46 PM ; Compiled August 4, 2010 10:18:29
+1 ;;5.3;PIMS;**241,334,480,1001,1012,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/LJF 7/12/2000 rerouted to IHS display format
+3 ;ihs/cmi/maw 06/01/2012 added call to patient wellness handout
+4 ;
EN ; Selection of appointment
+1 KILL ^TMP("SDAMEP",$JOB)
+2 SET VALMBCK=""
+3 DO SEL
IF '$DATA(SDW)!(SDERR)
GOTO ENQ
+4 ;
+5 ;IHS/ITSC/WAR 11/26/2004 PATCH #1001 Need DFN defined prior to PID^VADPT call
+6 SET DFN=$PIECE(^TMP("SDAMIDX",$JOB,SDW),U,2)
+7 ;IHS/ANMC/LJF 7/12/2000
+8 DO PID^VADPT
+9 SET DFN=$PIECE(^TMP("SDAMIDX",$JOB,SDW),U,2)
SET SDT=$PIECE(^(SDW),U,3)
SET SDCL=$PIECE(^(SDW),U,4)
SET SDDA=$PIECE(^(SDW),U,5)
SET SDLN=0
+10 ;cmi/maw 6/1/2010 PATCH 1012 for wait list
SET SDWLE=$PIECE(^TMP("SDAMIDX",$JOB,SDW),U,6)
+11 ;cmi/maw 6/1/2010 PATCH 1012 for wait list
IF $GET(SDWLE)]""
DO EN^BSDAMEPW(SDWLE)
QUIT
+12 DO EN^BSDAMEP
QUIT
+13 ;IHS/ANMC/LJF 7/12/2000
+14 ;
+15 NEW SDWIDTH,SDPT,SDSC,SDPTI,SDAMEP
+16 WRITE !
DO WAIT^DICD
+17 SET DFN=$PIECE(^TMP("SDAMIDX",$JOB,SDW),U,2)
+18 ;,SDAMEP=1
DO FULL^VALM1
SET DIC=2
SET DIC(0)="EM"
SET X="`"_DFN
+19 DO ^DIC
IF Y<0
SET VALMBCK="R"
QUIT
+20 DO EN^VALM("SDAM APPT PROFILE")
+21 SET VALMBCK="R"
ENQ QUIT
+1 ;
HDR ; Header
+1 NEW VA,VAERR
+2 DO PID^VADPT
+3 SET VALMHDR(1)=$EXTRACT($PIECE("Patient: "_$GET(^DPT(DFN,0)),"^",1),1,30)_" ("_VA("BID")_")"
+4 SET X=$SELECT($DATA(^DPT(DFN,.1)):"Ward: "_^(.1),1:"Outpatient")
+5 SET VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$LENGTH(X),$LENGTH(X))
+6 SET X="Clinic: "_$PIECE(^SC(SDCL,0),U)
+7 SET VALMHDR(2)=$$SETSTR^VALM1(X,"Appointment #: "_SDW,81-$LENGTH(X),$LENGTH(X))
+8 QUIT
+9 ;
INIT ;
+1 NEW VA,VAERR,SDFSTCOL,SDSECCOL
+2 DO PID^VADPT
+3 ;added DFN SD*5.3*480
SET SDT=$PIECE(^TMP("SDAMIDX",$JOB,SDW),U,3)
SET DFN=$PIECE(^(SDW),U,2)
SET SDCL=$PIECE(^(SDW),U,4)
SET SDDA=$PIECE(^(SDW),U,5)
SET SDLN=0
+4 DO INIT^SDAMEP1
+5 ; Appointment Data
DO APDATA^SDAMEP1
+6 ; Appointment Event Log
DO APLOG^SDAMEP3
+7 ; Patient Data
DO PDATA^SDAMEP2
+8 ; Appointment Check Out Data
DO APCO^SDAMEP4
+9 SET VALMCNT=SDLN
+10 QUIT
+11 ;
FNL ;
+1 ;SD*567 added DIC
KILL SD,SDOE,SDSC,SDPT,SDLN,VALMCNT,SDEIC,SDI,SDX,SDW,SDEN,SDSTATE,SDERR,SDFLG,SDMT,SDT,DGPMVI,SDDISCH,SDPV,SDPOV,SDST,SDSTA,DIC
+2 DO CLEAN^VALM10
+3 QUIT
+4 ;
SEL ; -- select processing
+1 NEW BG,LST,Y
+2 SET BG=+$ORDER(@VALMAR@("IDX",VALMBG,0))
+3 SET LST=+$ORDER(@VALMAR@("IDX",VALMLST,0))
+4 IF 'BG
WRITE !!,*7,"There are no '",VALM("ENTITY"),"s' to select.",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
DO OUT
GOTO SELQ
+5 SET Y=+$PIECE($PIECE(XQORNOD(0),U,4),"=",2)
+6 IF 'Y
SET DIR(0)="N^"_BG_":"_LST
SET DIR("A")="Select "_VALM("ENTITY")_"(s)"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO OUT
GOTO SELQ
+7 ;
+8 ; -- check was valid entries
+9 SET SDERR=0
SET SDW=Y
+10 IF SDW<BG!(SDW>LST)
Begin DoDot:1
+11 WRITE !,*7,"Selection '",SDW,"' is not a valid choice."
+12 DO OUT
DO PAUSE^VALM1
End DoDot:1
+13 ;
SELQ KILL DIRUT,DTOUT,DUOUT,DIROUT
QUIT
+1 ;
OUT ;
+1 SET SDERR=1
+2 QUIT
