SDAM2 ;ALB/MJK - Appt Mgt (cont) ;JAN 15, 2016
;;5.3;Scheduling;**250,296,327,478,446,627,686**;Aug 13, 1993;Build 53
;
CI ; -- protocol SDAM APPT CHECK IN entry pt
; input: VALMY := array entries
;
N %,SDI,SDAT,VALMY,SDAMCIDT,SDCIACT
D SEL^VALM2 S SDI=0,SDCIACT=""
D NOW^%DTC S SDAMCIDT=$P(%,".")_"."_$E($P(%,".",2)_"0000",1,4)
F S SDI=$O(VALMY(SDI)) Q:'SDI I $D(^TMP("SDAMIDX",$J,SDI)) K SDAT D
.S SDAT=^TMP("SDAMIDX",$J,SDI)
.W !,^TMP("SDAM",$J,+SDAT,0)
.D:VALMCC SELECT^VALM10(+SDAT,1)
.D ONE($P(SDAT,U,2),$P(SDAT,U,4),$P(SDAT,U,3),$P(SDAT,U,5),0,SDAMCIDT)
.D:VALMCC SELECT^VALM10(+SDAT,0)
S VALMBCK=$S(VALMCC:"",1:"R")
Q
;
ONE(DFN,SDCL,SDT,SDDA,SDASK,SDAMCIDT) ; -- check in one appt
; input: DFN := ifn of patient
; SDCL := clinic#
; SDT := appt d/t
; SDDA := ifn in ^SC multiple or null
; SDASK := ask d/t of ci always [1|yes or 0|no]
; SDAMCIDT := ci date/time [optional]
;
I $D(XRTL) D T0^%ZOSV
S:'SDDA SDDA=$$FIND(DFN,SDT,SDCL)
I 'SDDA W !!,*7,"You cannot check in this appointment." D PAUSE^VALM1 G ONEQ
N SDATA,SDCIHDL,X S SDATA=SDDA_U_DFN_U_SDT_U_SDCL,SDCIHDL=$$HANDLE^SDAMEVT(1)
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
I '$D(^SD(409.63,"ACI",1,+SDATA("BEFORE","STATUS"))) W !!,*7,"You cannot check in this appointment." D PAUSE^VALM1 G ONEQ
; *** mt blocking removed
;S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$G(EASACT)'="W",$$MT^EASMTCHK(DFN,"","C",SDT) D PAUSE^VALM1 G ONEQ
I $P(SDT,".")>DT W !!,*7,"It is too soon to check in this appointment." D PAUSE^VALM1 G ONEQ
S:'$D(^SC(SDCL,"S",0)) ^(0)="^44.001DA^^"
S DR="",X=$G(^SC(SDCL,"S",SDT,1,SDDA,"C"))
I +X S DR=309
; -- already co'ed
I DR="",$P(X,U,3) D
.S DR="309//"
.I $P(^SC(SDCL,0),U,24)!(SDASK) S DR=DR_$$FTIME^VALM1($P(X,U,3)) Q
.S DR=DR_"//^S X="_$P(X,U,3)
;
I DR="",$P(^SC(SDCL,0),U,24)!(SDASK) S DR="309//"_$S(SDAMCIDT:$$FTIME^VALM1(SDAMCIDT),1:"NOW")
I DR="" S DR="309///"_$S(SDAMCIDT:"/"_SDAMCIDT,1:"NOW")
S DA(2)=SDCL,DA(1)=SDT,DA=SDDA,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIE
;update SDEC APPOINTMENT ;alb/sat 627
N SDECAPPT,SDECDT
S SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL)
S SDECDT=$$GET1^DIQ(44.003,SDDA_","_SDT_","_SDCL_",",309,"I")
D SDECCHK^SDEC25(SDECAPPT,SDECDT)
;alb/sat 627 end addition/modification
D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
I '$P(SDATA("AFTER","STATUS"),U,4),'$P(SDATA("BEFORE","STATUS"),U,4) W !?8,*7,"...appointment has not been checked in" D PAUSE^VALM1
I SDATA("BEFORE","STATUS")'=SDATA("AFTER","STATUS") D
.I $P(SDATA("AFTER","STATUS"),U,4),'$P(SDATA("BEFORE","STATUS"),U,4) W !?8,"...checked in ",$$FTIME^VALM1($P(SDATA("AFTER","STATUS"),U,4))
.I $D(SDCIACT) D
..S Y=SDATA("AFTER","STATUS"),Y1=$P(Y,U,4),Y=$P(Y,U,3)
..I $P(SDATA("BEFORE","STATUS"),U,3)'=Y D UPD($$LOWER^VALM1(Y),"STAT",+SDAT,1),UPD("","TIME",+SDAT,1)
..I $P(SDATA("AFTER","STATUS"),U,3)["CHECKED IN" D UPD($S($P(Y1,".")=DT:$$TIME^SDAM1($P(Y1,".",2)),1:" "),"TIME",+SDAT,1)
.D EVT^SDAMEVT(.SDATA,4,0,SDCIHDL) ; 4 := ci evt , 0 := interactive mode
I $D(XRT0) S XRTN="SDAM2" D T1^%ZOSV
ONEQ K DA,DIE,DR,DQ,DE,Y,Y1 Q
;
;
FIND(DFN,SDT,SDCL) ; -- return appt ifn for pat
; input: DFN := ifn of pat.
; SDT := appt d/t
; SDCL := ifn of clinic
; output: [returned] := ifn if pat has appt on date/time
;
N Y
;*zeb+1 686 3/14/19 reverse $O to fix handling of more than one cancelled appointment for a particular patient/time/clinic combo
S Y=99999 F S Y=$O(^SC(SDCL,"S",SDT,1,Y),-1) Q:'Y I $D(^(Y,0)),DFN=+^(0),$D(^DPT(+DFN,"S",SDT,0)),$$VALID(DFN,SDCL,SDT,Y) S CNSTLNK=$P($G(^SC(SDCL,"S",SDT,1,Y,"CONS")),U) K:CNSTLNK="" CNSTLNK Q ;SD/478
Q Y
;
UPD(TEXT,FLD,LINE,SAVE) ; -- update data for screen
D FLDTEXT^VALM10(LINE,FLD,TEXT)
D:VALMCC CNTRL^VALM10(LINE,$P(VALMDDF(FLD),U,2),$P(VALMDDF(FLD),U,3),IOINHI,IOINORM,+$G(SAVE))
Q
;
MAKE ; -- make appt action
N ORACTION,ORVP,XQORQUIT,SDAMERR
D FULL^VALM1
W !!,VALMHDR(1)
D ^SDM
I '$D(SDAMERR) D BLD^SDAM
I $D(SDAMERR) D PAUSE^VALM1
D SDM^SDKILL S VALMBCK="R"
Q
;
WI ; -- walk-in visit action
S VALMBCK="R"
D FULL^VALM1
I SDAMTYP="P" I $$CL^SDAMWI(SDFN) D BLD^SDAM1
I SDAMTYP="C" I $$PT^SDAMWI(SDCLN) D BLD^SDAM3
;evaluate wait list ;SD/327
EWLCHK ;check if patient has any open EWL entries (SD/372)
;CLN expected as clinic IEN
I '$D(DFN) Q
Q:'$D(SDT)
K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
N SD S SD=SDT
I '$D(SC) S SC=+$G(CLN)
;
K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
W:$D(IOF) @IOF D APPT^SDWLEVAL(DFN,SD,SC)
Q:'$D(^TMP($J,"APPT"))
N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
.K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
.D INIT^SDWLPL(DFN,"M")
.Q:'$D(^TMP($J,"SDWLPL"))
.D LIST^SDWLPL("M",DFN)
.F Q:'$D(^TMP($J,"SDWLPL")) N SDR D ANSW^SDWLEVAL(1,.SDR) I 'SDR D LIST^SDWLPL("M",DFN) D
..F N SDR D ANSW^SDWLEVAL(0,.SDR) Q:'$D(^TMP($J,"SDWLPL")) I 'SDR W !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
I $D(^TMP($J,"APPT")) N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
.Q:'$D(^TMP($J,"SDWLPL")) D ASKREM^SDWLEVAL S SDCTN=1 ;display and process selected open EWL entries
.Q
Q
;
DATE ; -- change date range
S VALMB=SDBEG D RANGE^VALM11
I $S('VALMBEG:1,SDBEG'=VALMBEG:0,1:SDEND=VALMEND) W !!,"Date range was not changed." D PAUSE^VALM1 S VALMBCK="" G DATEQ
S SDBEG=VALMBEG,SDEND=VALMEND
I SDAMTYP="P" D BLD^SDAM1
I SDAMTYP="C" D BLD^SDAM3
S VALMBCK="R"
DATEQ K VALMB,VALMBEG,VALMEND Q
;
INP(DFN,VDATE) ; -- determine inpatient status ; dom is not an inpatient appt
N SDINP,VAINDT,VADMVT
S SDINP="",VAINDT=VDATE D ADM^VADPT2 G INPQ:'VADMVT
I $P(^DG(43,1,0),U,21),$P($G(^DIC(42,+$P($G(^DGPM(VADMVT,0)),U,6),0)),U,3)="D" G INPQ
S SDINP="I"
INPQ Q SDINP
;
VALID(DFN,SDCL,SDT,SDDA) ; -- return valid appt.
; **NOTE: For speed consideration the ^SC and ^DPT nodes must be
; check to see they exist prior to calling this entry point.
; input: DFN := ifn of pat.
; SDT := appt d/t
; SDCL := ifn of clinic
; SDDA := ifn of appt
; output: [returned] := 1 for valid appt., 0 for not valid
Q $S($P(^SC(SDCL,"S",SDT,1,SDDA,0),U,9)'="C":1,$P(^DPT(DFN,"S",SDT,0),U,2)["C":1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAM2 6362 printed Dec 13, 2024@02:47:07 Page 2
SDAM2 ;ALB/MJK - Appt Mgt (cont) ;JAN 15, 2016
+1 ;;5.3;Scheduling;**250,296,327,478,446,627,686**;Aug 13, 1993;Build 53
+2 ;
CI ; -- protocol SDAM APPT CHECK IN entry pt
+1 ; input: VALMY := array entries
+2 ;
+3 NEW %,SDI,SDAT,VALMY,SDAMCIDT,SDCIACT
+4 DO SEL^VALM2
SET SDI=0
SET SDCIACT=""
+5 DO NOW^%DTC
SET SDAMCIDT=$PIECE(%,".")_"."_$EXTRACT($PIECE(%,".",2)_"0000",1,4)
+6 FOR
SET SDI=$ORDER(VALMY(SDI))
if 'SDI
QUIT
IF $DATA(^TMP("SDAMIDX",$JOB,SDI))
KILL SDAT
Begin DoDot:1
+7 SET SDAT=^TMP("SDAMIDX",$JOB,SDI)
+8 WRITE !,^TMP("SDAM",$JOB,+SDAT,0)
+9 if VALMCC
DO SELECT^VALM10(+SDAT,1)
+10 DO ONE($PIECE(SDAT,U,2),$PIECE(SDAT,U,4),$PIECE(SDAT,U,3),$PIECE(SDAT,U,5),0,SDAMCIDT)
+11 if VALMCC
DO SELECT^VALM10(+SDAT,0)
End DoDot:1
+12 SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+13 QUIT
+14 ;
ONE(DFN,SDCL,SDT,SDDA,SDASK,SDAMCIDT) ; -- check in one appt
+1 ; input: DFN := ifn of patient
+2 ; SDCL := clinic#
+3 ; SDT := appt d/t
+4 ; SDDA := ifn in ^SC multiple or null
+5 ; SDASK := ask d/t of ci always [1|yes or 0|no]
+6 ; SDAMCIDT := ci date/time [optional]
+7 ;
+8 IF $DATA(XRTL)
DO T0^%ZOSV
+9 if 'SDDA
SET SDDA=$$FIND(DFN,SDT,SDCL)
+10 IF 'SDDA
WRITE !!,*7,"You cannot check in this appointment."
DO PAUSE^VALM1
GOTO ONEQ
+11 NEW SDATA,SDCIHDL,X
SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
SET SDCIHDL=$$HANDLE^SDAMEVT(1)
+12 DO BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
+13 IF '$DATA(^SD(409.63,"ACI",1,+SDATA("BEFORE","STATUS")))
WRITE !!,*7,"You cannot check in this appointment."
DO PAUSE^VALM1
GOTO ONEQ
+14 ; *** mt blocking removed
+15 ;S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$G(EASACT)'="W",$$MT^EASMTCHK(DFN,"","C",SDT) D PAUSE^VALM1 G ONEQ
+16 IF $PIECE(SDT,".")>DT
WRITE !!,*7,"It is too soon to check in this appointment."
DO PAUSE^VALM1
GOTO ONEQ
+17 if '$DATA(^SC(SDCL,"S",0))
SET ^(0)="^44.001DA^^"
+18 SET DR=""
SET X=$GET(^SC(SDCL,"S",SDT,1,SDDA,"C"))
+19 IF +X
SET DR=309
+20 ; -- already co'ed
+21 IF DR=""
IF $PIECE(X,U,3)
Begin DoDot:1
+22 SET DR="309//"
+23 IF $PIECE(^SC(SDCL,0),U,24)!(SDASK)
SET DR=DR_$$FTIME^VALM1($PIECE(X,U,3))
QUIT
+24 SET DR=DR_"//^S X="_$PIECE(X,U,3)
End DoDot:1
+25 ;
+26 IF DR=""
IF $PIECE(^SC(SDCL,0),U,24)!(SDASK)
SET DR="309//"_$SELECT(SDAMCIDT:$$FTIME^VALM1(SDAMCIDT),1:"NOW")
+27 IF DR=""
SET DR="309///"_$SELECT(SDAMCIDT:"/"_SDAMCIDT,1:"NOW")
+28 SET DA(2)=SDCL
SET DA(1)=SDT
SET DA=SDDA
SET DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
DO ^DIE
+29 ;update SDEC APPOINTMENT ;alb/sat 627
+30 NEW SDECAPPT,SDECDT
+31 SET SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL)
+32 SET SDECDT=$$GET1^DIQ(44.003,SDDA_","_SDT_","_SDCL_",",309,"I")
+33 DO SDECCHK^SDEC25(SDECAPPT,SDECDT)
+34 ;alb/sat 627 end addition/modification
+35 DO AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
+36 IF '$PIECE(SDATA("AFTER","STATUS"),U,4)
IF '$PIECE(SDATA("BEFORE","STATUS"),U,4)
WRITE !?8,*7,"...appointment has not been checked in"
DO PAUSE^VALM1
+37 IF SDATA("BEFORE","STATUS")'=SDATA("AFTER","STATUS")
Begin DoDot:1
+38 IF $PIECE(SDATA("AFTER","STATUS"),U,4)
IF '$PIECE(SDATA("BEFORE","STATUS"),U,4)
WRITE !?8,"...checked in ",$$FTIME^VALM1($PIECE(SDATA("AFTER","STATUS"),U,4))
+39 IF $DATA(SDCIACT)
Begin DoDot:2
+40 SET Y=SDATA("AFTER","STATUS")
SET Y1=$PIECE(Y,U,4)
SET Y=$PIECE(Y,U,3)
+41 IF $PIECE(SDATA("BEFORE","STATUS"),U,3)'=Y
DO UPD($$LOWER^VALM1(Y),"STAT",+SDAT,1)
DO UPD("","TIME",+SDAT,1)
+42 IF $PIECE(SDATA("AFTER","STATUS"),U,3)["CHECKED IN"
DO UPD($SELECT($PIECE(Y1,".")=DT:$$TIME^SDAM1($PIECE(Y1,".",2)),1:" "),"TIME",+SDAT,1)
End DoDot:2
+43 ; 4 := ci evt , 0 := interactive mode
DO EVT^SDAMEVT(.SDATA,4,0,SDCIHDL)
End DoDot:1
+44 IF $DATA(XRT0)
SET XRTN="SDAM2"
DO T1^%ZOSV
ONEQ KILL DA,DIE,DR,DQ,DE,Y,Y1
QUIT
+1 ;
+2 ;
FIND(DFN,SDT,SDCL) ; -- return appt ifn for pat
+1 ; input: DFN := ifn of pat.
+2 ; SDT := appt d/t
+3 ; SDCL := ifn of clinic
+4 ; output: [returned] := ifn if pat has appt on date/time
+5 ;
+6 NEW Y
+7 ;*zeb+1 686 3/14/19 reverse $O to fix handling of more than one cancelled appointment for a particular patient/time/clinic combo
+8 ;SD/478
SET Y=99999
FOR
SET Y=$ORDER(^SC(SDCL,"S",SDT,1,Y),-1)
if 'Y
QUIT
IF $DATA(^(Y,0))
IF DFN=+^(0)
IF $DATA(^DPT(+DFN,"S",SDT,0))
IF $$VALID(DFN,SDCL,SDT,Y)
SET CNSTLNK=$PIECE($GET(^SC(SDCL,"S",SDT,1,Y,"CONS")),U)
if CNSTLNK=""
KILL CNSTLNK
QUIT
+9 QUIT Y
+10 ;
UPD(TEXT,FLD,LINE,SAVE) ; -- update data for screen
+1 DO FLDTEXT^VALM10(LINE,FLD,TEXT)
+2 if VALMCC
DO CNTRL^VALM10(LINE,$PIECE(VALMDDF(FLD),U,2),$PIECE(VALMDDF(FLD),U,3),IOINHI,IOINORM,+$GET(SAVE))
+3 QUIT
+4 ;
MAKE ; -- make appt action
+1 NEW ORACTION,ORVP,XQORQUIT,SDAMERR
+2 DO FULL^VALM1
+3 WRITE !!,VALMHDR(1)
+4 DO ^SDM
+5 IF '$DATA(SDAMERR)
DO BLD^SDAM
+6 IF $DATA(SDAMERR)
DO PAUSE^VALM1
+7 DO SDM^SDKILL
SET VALMBCK="R"
+8 QUIT
+9 ;
WI ; -- walk-in visit action
+1 SET VALMBCK="R"
+2 DO FULL^VALM1
+3 IF SDAMTYP="P"
IF $$CL^SDAMWI(SDFN)
DO BLD^SDAM1
+4 IF SDAMTYP="C"
IF $$PT^SDAMWI(SDCLN)
DO BLD^SDAM3
+5 ;evaluate wait list ;SD/327
EWLCHK ;check if patient has any open EWL entries (SD/372)
+1 ;CLN expected as clinic IEN
+2 IF '$DATA(DFN)
QUIT
+3 if '$DATA(SDT)
QUIT
+4 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"APPT")
+5 NEW SD
SET SD=SDT
+6 IF '$DATA(SC)
SET SC=+$GET(CLN)
+7 ;
+8 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"APPT")
+9 if $DATA(IOF)
WRITE @IOF
DO APPT^SDWLEVAL(DFN,SD,SC)
+10 if '$DATA(^TMP($JOB,"APPT"))
QUIT
+11 NEW SDEV
DO EN^SDWLEVAL(DFN,.SDEV)
IF SDEV
IF $LENGTH(SDEV(1))>0
Begin DoDot:1
+12 KILL ^TMP("SDWLPL",$JOB),^TMP($JOB,"SDWLPL")
+13 DO INIT^SDWLPL(DFN,"M")
+14 if '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
+15 DO LIST^SDWLPL("M",DFN)
+16 FOR
if '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
NEW SDR
DO ANSW^SDWLEVAL(1,.SDR)
IF 'SDR
DO LIST^SDWLPL("M",DFN)
Begin DoDot:2
+17 FOR
NEW SDR
DO ANSW^SDWLEVAL(0,.SDR)
if '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
IF 'SDR
WRITE !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
End DoDot:2
End DoDot:1
+18 IF $DATA(^TMP($JOB,"APPT"))
NEW SDEV
DO EN^SDWLEVAL(DFN,.SDEV)
IF SDEV
IF $LENGTH(SDEV(1))>0
Begin DoDot:1
+19 ;display and process selected open EWL entries
if '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
DO ASKREM^SDWLEVAL
SET SDCTN=1
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
DATE ; -- change date range
+1 SET VALMB=SDBEG
DO RANGE^VALM11
+2 IF $SELECT('VALMBEG:1,SDBEG'=VALMBEG:0,1:SDEND=VALMEND)
WRITE !!,"Date range was not changed."
DO PAUSE^VALM1
SET VALMBCK=""
GOTO DATEQ
+3 SET SDBEG=VALMBEG
SET SDEND=VALMEND
+4 IF SDAMTYP="P"
DO BLD^SDAM1
+5 IF SDAMTYP="C"
DO BLD^SDAM3
+6 SET VALMBCK="R"
DATEQ KILL VALMB,VALMBEG,VALMEND
QUIT
+1 ;
INP(DFN,VDATE) ; -- determine inpatient status ; dom is not an inpatient appt
+1 NEW SDINP,VAINDT,VADMVT
+2 SET SDINP=""
SET VAINDT=VDATE
DO ADM^VADPT2
if 'VADMVT
GOTO INPQ
+3 IF $PIECE(^DG(43,1,0),U,21)
IF $PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(VADMVT,0)),U,6),0)),U,3)="D"
GOTO INPQ
+4 SET SDINP="I"
INPQ QUIT SDINP
+1 ;
VALID(DFN,SDCL,SDT,SDDA) ; -- return valid appt.
+1 ; **NOTE: For speed consideration the ^SC and ^DPT nodes must be
+2 ; check to see they exist prior to calling this entry point.
+3 ; input: DFN := ifn of pat.
+4 ; SDT := appt d/t
+5 ; SDCL := ifn of clinic
+6 ; SDDA := ifn of appt
+7 ; output: [returned] := 1 for valid appt., 0 for not valid
+8 QUIT $SELECT($PIECE(^SC(SDCL,"S",SDT,1,SDDA,0),U,9)'="C":1,$PIECE(^DPT(DFN,"S",SDT,0),U,2)["C":1,1:0)
