SDAM ;MJK/ALB - Appt Mgt ; 8/30/99 9:09am
;;5.3;Scheduling;**149,177,76,242,380,1001,1005,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 6/01/2000 removed "* - New GAF Required" from header
; 8/18/2000 cleared screen before entering list template
; 9/29/2000 added kill of patient variables
; 8/29/2001 changed so can be called with patient set(VPR)
; also changed list temp entry code to INIT1
; 10/19/2001 added insurance coverage to heading
; 10/22/2001 cleaned up call to VALM
;IHS/ITSC/WAR 10/20/2004 PATCH 1001 clear DFN if viewing by clinic
;IHS/OIT/LJF 12/29/2005 PATCH 1005 added age to header display
;
D HDLKILL^SDAMEVT
EN ; -- main entry point
;IHS/ANMC/LJF 8/29/2001 start of changes
;N XQORS,VALMEVL D EN^VALM("SDAM APPT MGT") ;original VA code
K VALMQUIT D INIT Q:$D(VALMQUIT)
EN1 ;PEP; entry point when patient is known - see technical documentation
D TERM^VALM0 ;IHS/ANMC/LJF 10/22/2001 added for clean VALM call
NEW VALMCNT D EN^VALM("SDAM APPT MGT")
D KILL^AUPNPAT,KVA^VADPT,CLEAR^VALM1 ;IHS/ANMC/LJF 9/29/2000 added
;IHS/ANMC/LJF 8/29/2001 end of new code
Q
;
INIT ; -- set up appt man vars
K I,X,SDBEG,SDEND,SDB,XQORNOD,SDFN,SDCLN,DA,DR,DIE,DNM,DQ,%B,SDRES
S DIR(0)="43,213",DIR("A")="Select Patient name or Clinic name"
D ^DIR K DIR I $D(DIRUT) S VALMQUIT="" G INITQ
S SDY=Y
I SDY["DPT(" S DFN=+SDY D 2^VADPT I +VADM(6) D G:SDUP="^" INIT
. W !!,"WARNING ",VADM(7),!!
. R "Press Return to Continue or ^ to Quit: ",SDUP:DTIME
;I SDY["DPT(" S SDAMTYP="P",SDFN=+SDY D INIT^SDAM1
;I SDY["SC(" S SDRES=$$CLNCK^SDUTL2(+SDY,1) I 'SDRES D G INIT
;. W !,?5,"Clinic MUST be corrected before continuing."
;I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY D INIT^SDAM3
;
;IHS/ANMC/LJF 8/29/2001 changed code so can be called with patient set
Q
;
INIT1 ; added line label
;IHS/ANMC/LJF 8/29/2001 end of mods
;
I SDY["DPT(" S SDAMTYP="P",SDFN=+SDY D INIT^SDAM1
;IHS/ITSC/WAR 10/20/04 PATCH #1001 clear Pt DFN if a Clinic is chosen
;I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY D INIT^SDAM3
I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY K DFN D INIT^SDAM3
D CLEAR^VALM1 ;IHS/ANMC/LJF 8/18/2000
;
INITQ Q
;
HDR ; -- screen head
N X,SDX,SDLNX S SDLNX=2
;I SDAMTYP="P" D HDR^SDAM10 S VALM("TM")=5 D
I SDAMTYP="P" D HDR^SDAM10 D
.;IHS/OIT/LJF 12/29/2005 PATCH 1005 added patient age to PCP line
.;S SDX=$$PCLINE^SDPPTEM(SDFN,DT) Q:'$L(SDX)
.S SDX=" Age: "_$$AGE^AUPNPAT(SDFN,DT,"R")_" "_$$PCLINE^SDPPTEM(SDFN,DT) Q:'$L(SDX)
.;
.S VALMHDR(SDLNX)=SDX,SDLNX=3
.;S VALMHDR(SDLNX)=SDX,SDLNX=3,VALM("TM")=6
.;Increment Top & Bottom margins to allow for additional line
.;S VALM("TM")=VALM("TM")+1
.;S VALM("BM")=VALM("BM")+1
.Q
I SDAMTYP="C" D HDR^SDAM3
S X=$P(SDAMLIST,"^",2)
S VALMHDR(SDLNX)=X
;S X="* - New GAF Required",VALMHDR(SDLNX)=$$SETSTR^VALM1(X,VALMHDR(SDLNX),34,30)
I SDAMTYP="P" S VALMHDR(SDLNX)=$$SETSTR^VALM1($$INSUR^BDGF2(SDFN,SDBEG),VALMHDR(SDLNX),40,15) ;IHS/ANMC/LJF 10/19/2001
S VALMHDR(SDLNX)=$$SETSTR^VALM1($$FDATE^VALM1(SDBEG)_" thru "_$$FDATE^VALM1(SDEND),VALMHDR(SDLNX),59,22)
Q
;
FNL ; -- what to do after action
K ^TMP("SDAM",$J),^TMP("SDAMIDX",$J),^TMP("VALMIDX",$J)
K SDAMCNT,SDFLDD,SDACNT,VALMHCNT,SDPRD,SDFN,SDCLN,SDAMLIST,SDT,SDATA,SDBEG,SDEND,DFN,Y,SDAMTYP,SDY,X,SDCL,Y,SDDA,VALMY
Q
;
BLD ; -- entry point to bld list
; input: SDAMLIST := list to build
D:'$D(SDAMLIST) GROUP("ALL",.SDAMLIST)
I SDAMTYP="P" D BLD^SDAM1
I SDAMTYP="C" D BLD^SDAM3
BLDQ Q
;
LIST ; -- find and build
; input: X := status group
; output: SDAMLIST := array of status'
;
I X["CANCELLED",$G(SDAMTYP)="C" S VALMBCK="" W !!,*7,"You must be viewing a patient to list cancelled appointments." D PAUSE^VALM1 G LISTQ
D GROUP(X,.SDAMLIST),BLD
S VALMBCK="R"
LISTQ Q
;
GROUP(GROUP,SDAMLIST) ; -- find list
S (I,SDAMLIST)="" F S I=$O(SDAMLIST(I)) Q:I="" K SDAMLIST(I)
S GROUP=+$O(^SD(409.62,"B",GROUP,0))
G GROUPQ:'$D(^SD(409.62,GROUP,0)) S SDAMLIST=^(0)
S I=$G(^SD(409.62,GROUP,1)) S:I]"" SDAMLIST("SCR")=I
S I=0 F S I=$O(^SD(409.63,"C",GROUP,I)) Q:'I S SDAMLIST(I)=""
GROUPQ Q
;
FUT ; -- change date range
S X1=DT,X2=999 D C^%DTC
S SDEBG=DT,SDEND=X,X="FUTURE" K VALMHDR
D LIST
FUTQ Q
;
EXIT ; -- exit action for protocol
I $D(VALMBCK),VALMBCK="R" D REFRESH^VALM S VALMBCK=$P(VALMBCK,"R")_$P(VALMBCK,"R",2)
Q
;
SDAM ;MJK/ALB - Appt Mgt ; 8/30/99 9:09am
+1 ;;5.3;Scheduling;**149,177,76,242,380,1001,1005,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 6/01/2000 removed "* - New GAF Required" from header
+3 ; 8/18/2000 cleared screen before entering list template
+4 ; 9/29/2000 added kill of patient variables
+5 ; 8/29/2001 changed so can be called with patient set(VPR)
+6 ; also changed list temp entry code to INIT1
+7 ; 10/19/2001 added insurance coverage to heading
+8 ; 10/22/2001 cleaned up call to VALM
+9 ;IHS/ITSC/WAR 10/20/2004 PATCH 1001 clear DFN if viewing by clinic
+10 ;IHS/OIT/LJF 12/29/2005 PATCH 1005 added age to header display
+11 ;
+12 DO HDLKILL^SDAMEVT
EN ; -- main entry point
+1 ;IHS/ANMC/LJF 8/29/2001 start of changes
+2 ;N XQORS,VALMEVL D EN^VALM("SDAM APPT MGT") ;original VA code
+3 KILL VALMQUIT
DO INIT
IF $DATA(VALMQUIT)
QUIT
EN1 ;PEP; entry point when patient is known - see technical documentation
+1 ;IHS/ANMC/LJF 10/22/2001 added for clean VALM call
DO TERM^VALM0
+2 NEW VALMCNT
DO EN^VALM("SDAM APPT MGT")
+3 ;IHS/ANMC/LJF 9/29/2000 added
DO KILL^AUPNPAT
DO KVA^VADPT
DO CLEAR^VALM1
+4 ;IHS/ANMC/LJF 8/29/2001 end of new code
+5 QUIT
+6 ;
INIT ; -- set up appt man vars
+1 KILL I,X,SDBEG,SDEND,SDB,XQORNOD,SDFN,SDCLN,DA,DR,DIE,DNM,DQ,%B,SDRES
+2 SET DIR(0)="43,213"
SET DIR("A")="Select Patient name or Clinic name"
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET VALMQUIT=""
GOTO INITQ
+4 SET SDY=Y
+5 IF SDY["DPT("
SET DFN=+SDY
DO 2^VADPT
IF +VADM(6)
Begin DoDot:1
+6 WRITE !!,"WARNING ",VADM(7),!!
+7 READ "Press Return to Continue or ^ to Quit: ",SDUP:DTIME
End DoDot:1
IF SDUP="^"
GOTO INIT
+8 ;I SDY["DPT(" S SDAMTYP="P",SDFN=+SDY D INIT^SDAM1
+9 ;I SDY["SC(" S SDRES=$$CLNCK^SDUTL2(+SDY,1) I 'SDRES D G INIT
+10 ;. W !,?5,"Clinic MUST be corrected before continuing."
+11 ;I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY D INIT^SDAM3
+12 ;
+13 ;IHS/ANMC/LJF 8/29/2001 changed code so can be called with patient set
+14 QUIT
+15 ;
INIT1 ; added line label
+1 ;IHS/ANMC/LJF 8/29/2001 end of mods
+2 ;
+3 IF SDY["DPT("
SET SDAMTYP="P"
SET SDFN=+SDY
DO INIT^SDAM1
+4 ;IHS/ITSC/WAR 10/20/04 PATCH #1001 clear Pt DFN if a Clinic is chosen
+5 ;I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY D INIT^SDAM3
+6 IF SDY["SC("
SET SDAMTYP="C"
SET SDCLN=+SDY
KILL DFN
DO INIT^SDAM3
+7 ;IHS/ANMC/LJF 8/18/2000
DO CLEAR^VALM1
+8 ;
INITQ QUIT
+1 ;
HDR ; -- screen head
+1 NEW X,SDX,SDLNX
SET SDLNX=2
+2 ;I SDAMTYP="P" D HDR^SDAM10 S VALM("TM")=5 D
+3 IF SDAMTYP="P"
DO HDR^SDAM10
Begin DoDot:1
+4 ;IHS/OIT/LJF 12/29/2005 PATCH 1005 added patient age to PCP line
+5 ;S SDX=$$PCLINE^SDPPTEM(SDFN,DT) Q:'$L(SDX)
+6 SET SDX=" Age: "_$$AGE^AUPNPAT(SDFN,DT,"R")_" "_$$PCLINE^SDPPTEM(SDFN,DT)
IF '$LENGTH(SDX)
QUIT
+7 ;
+8 SET VALMHDR(SDLNX)=SDX
SET SDLNX=3
+9 ;S VALMHDR(SDLNX)=SDX,SDLNX=3,VALM("TM")=6
+10 ;Increment Top & Bottom margins to allow for additional line
+11 ;S VALM("TM")=VALM("TM")+1
+12 ;S VALM("BM")=VALM("BM")+1
+13 QUIT
End DoDot:1
+14 IF SDAMTYP="C"
DO HDR^SDAM3
+15 SET X=$PIECE(SDAMLIST,"^",2)
+16 SET VALMHDR(SDLNX)=X
+17 ;S X="* - New GAF Required",VALMHDR(SDLNX)=$$SETSTR^VALM1(X,VALMHDR(SDLNX),34,30)
+18 ;IHS/ANMC/LJF 10/19/2001
IF SDAMTYP="P"
SET VALMHDR(SDLNX)=$$SETSTR^VALM1($$INSUR^BDGF2(SDFN,SDBEG),VALMHDR(SDLNX),40,15)
+19 SET VALMHDR(SDLNX)=$$SETSTR^VALM1($$FDATE^VALM1(SDBEG)_" thru "_$$FDATE^VALM1(SDEND),VALMHDR(SDLNX),59,22)
+20 QUIT
+21 ;
FNL ; -- what to do after action
+1 KILL ^TMP("SDAM",$JOB),^TMP("SDAMIDX",$JOB),^TMP("VALMIDX",$JOB)
+2 KILL SDAMCNT,SDFLDD,SDACNT,VALMHCNT,SDPRD,SDFN,SDCLN,SDAMLIST,SDT,SDATA,SDBEG,SDEND,DFN,Y,SDAMTYP,SDY,X,SDCL,Y,SDDA,VALMY
+3 QUIT
+4 ;
BLD ; -- entry point to bld list
+1 ; input: SDAMLIST := list to build
+2 IF '$DATA(SDAMLIST)
DO GROUP("ALL",.SDAMLIST)
+3 IF SDAMTYP="P"
DO BLD^SDAM1
+4 IF SDAMTYP="C"
DO BLD^SDAM3
BLDQ QUIT
+1 ;
LIST ; -- find and build
+1 ; input: X := status group
+2 ; output: SDAMLIST := array of status'
+3 ;
+4 IF X["CANCELLED"
IF $GET(SDAMTYP)="C"
SET VALMBCK=""
WRITE !!,*7,"You must be viewing a patient to list cancelled appointments."
DO PAUSE^VALM1
GOTO LISTQ
+5 DO GROUP(X,.SDAMLIST)
DO BLD
+6 SET VALMBCK="R"
LISTQ QUIT
+1 ;
GROUP(GROUP,SDAMLIST) ; -- find list
+1 SET (I,SDAMLIST)=""
FOR
SET I=$ORDER(SDAMLIST(I))
IF I=""
QUIT
KILL SDAMLIST(I)
+2 SET GROUP=+$ORDER(^SD(409.62,"B",GROUP,0))
+3 IF '$DATA(^SD(409.62,GROUP,0))
GOTO GROUPQ
SET SDAMLIST=^(0)
+4 SET I=$GET(^SD(409.62,GROUP,1))
IF I]""
SET SDAMLIST("SCR")=I
+5 SET I=0
FOR
SET I=$ORDER(^SD(409.63,"C",GROUP,I))
IF 'I
QUIT
SET SDAMLIST(I)=""
GROUPQ QUIT
+1 ;
FUT ; -- change date range
+1 SET X1=DT
SET X2=999
DO C^%DTC
+2 SET SDEBG=DT
SET SDEND=X
SET X="FUTURE"
KILL VALMHDR
+3 DO LIST
FUTQ QUIT
+1 ;
EXIT ; -- exit action for protocol
+1 IF $DATA(VALMBCK)
IF VALMBCK="R"
DO REFRESH^VALM
SET VALMBCK=$PIECE(VALMBCK,"R")_$PIECE(VALMBCK,"R",2)
+2 QUIT
+3 ;
