SDCO1 ;ALB/RMO - Appointment - Check Out ;JAN 15, 2016
;;5.3;Scheduling;**27,132,149,193,250,296,446,538,627**;08/13/93;Build 249
;
;check out if sd/369 is released before 446!!!
;
EN ;Entry point for SDCO APPT CHECK OUT protocol
N SDCOALBF,SDCOAP,SDCOBG,SDCODT,VALMY
S VALMBCK=""
D EN^VALM2(XQORNOD(0))
D FULL^VALM1
S SDCOAP=0 D NOW^%DTC S SDCODT=$P(%,".")_"."_$E($P(%,".",2)_"0000",1,4)
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 $$CHK^SDCOU(SDCOAP) D CO(+$P(SDAT,"^",2),+$P(SDAT,"^",3),+$P(SDAT,"^",4),+$P(SDAT,"^",5),0,SDCODT,"CO",+SDAT,.SDCOALBF)
I $G(SDCOALBF) S SDCOBG=VALMBG W ! D BLD^SDAM S:$D(@VALMAR@(SDCOBG,0)) VALMBG=SDCOBG
S VALMBCK="R"
K SDAT
Q
;
CO(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOACT,SDLNE,SDCOALBF) ;Appt Check Out
; Input -- DFN Patient file IEN
; SDT Appointment Date/Time
; SDCL Hospital Location file IEN for Appt
; SDDA IEN in ^SC multiple or null [Optional]
; SDASK Ask Check Out Date/Time [Optional]
; SDCODT Date/Time of Check Out [Optional]
; SDCOACT Appt Mgmt Check Out Action [Optional]
; SDLNE Appt Mgmt Line Number [Optional]
; Output -- SDCOALBF Re-build Appt Mgmt List
I $D(XRTL) D T0^%ZOSV
N SDCOQUIT,SDOE,SDATA,SDECAPPT
S:'SDDA SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
I 'SDDA W !!,*7,">>> You cannot check out this appointment." D PAUSE^VALM1 G COQ
S SDATA=$G(^DPT(DFN,"S",SDT,0))
; ** MT Blocking removed
;S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$G(EASACT)'="W",$$MT^EASMTCHK(DFN,$P($G(SDATA),U,16),"C",$G(SDT)) D PAUSE^VALM1 G COQ
;
;-- if new encounter, pass to PCE
I $$NEW^SDPCE(SDT) D S VALMBCK="R",SDCOALBF=1 G COQ
. N SDCOED
. S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
. ;
. ; -- has appt already been checked out
. S SDCOED=$$CHK($TR($$STATUS^SDAM1(DFN,SDT,SDCL,SDATA,SDDA),";","^"))
. ;
. ; -- if not checked out then do interview process
. IF '$$CODT^SDCOU(DFN,SDT,SDCL) D
. . N SDCOMKF,SDTRES
. . ;
. . ; -- first, check if should make follow-up appt
. . IF $G(SDCOACT)="CO",'SDCOED D
. . . N SDCOMKF
. . . D MC^SDCO5(SDOE,1,.SDCOMKF,.SDCOQUIT) Q:$D(SDCOQUIT)
. . . ;
. . . ; -- Set flag to re-build appointment list
. . . IF $G(SDCOMKF) S SDCOALBF=1
. . ;
. . ; -- c/o interview if user didn't quit
. . I '$D(SDCOQUIT),'SDCOED D
. . . N SDAPTYP
. . . S SDTRES=$$INTV^PXAPI("INTV","SD","PIMS",$P($G(^SCE(+SDOE,0)),U,5),$P($G(^SCE(+SDOE,0)),U,4),DFN)
. . . Q:SDTRES<0
. . . ;update SDEC APPOINTMENT - alb/sat 627
. . . S SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL) ;get SDEC APPOINTMENT ien
. . . I SDECAPPT="" D SDEC^SDAMWI1 S SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL)
. . . D CO1^SDEC25B(SDECAPPT,$S($G(SDCODT)="":$E($$NOW^XLFDT,1,12),1:SDCODT),+SDOE)
. . . ;
. . . ; -- ask user if they want to see c/o screen
. . . S SDGAFC=$$ASK^SDCO6
. . . I 'SDGAFC D
. . . .N SDELIG
. . . .S SDELIG=$$ELSTAT^SDUTL2(DFN)
. . . .I $$MHCLIN^SDUTL2(SDCL),'($$COLLAT^SDUTL2(SDELIG)!$P(SDATA,U,11)) D
. . . . .I $$NEWGAF^SDUTL2(DFN) D
. . . . . .I '$$GAFCM^SDUTL2() S SDGAFC=1
. . .I SDGAFC D EN^SDCO(SDOE,,1)
. ;
. ; -- if already checked out then show c/o screen
. E D EN^SDCO(SDOE,,1)
;
; -- view if old encounters
S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
D EN^SDCO(SDOE,,1)
;
COQ K % D EWLCHK Q
Q
EWLCHK ;check if patient has any open EWL entries (SD/372)
;get appointment
;
K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
W:$D(IOF) @IOF D APPT^SDWLEVAL(DFN,SDT,SDCL)
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 ACCEPT OR ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
..Q
.Q
Q
;
BEFORE(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- event driver before ; not used
S SDATA=SDDA_"^"_DFN_"^"_SDT_"^"_SDCL,SDHDL=$$HANDLE^SDAMEVT(1)
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
Q
;
AFTER(SDATA,DFN,SDT,SDCL,SDDA,SDHDL,SDLNE) ; -- event driver after ; not used
D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
D:$G(SDLNE) UPD(DFN,SDT,SDCL,SDLNE,SDATA("BEFORE","STATUS"),SDATA("AFTER","STATUS"))
D EVT^SDAMEVT(.SDATA,5,0,SDHDL)
Q
;
UPD(DFN,SDT,SDCL,SDLNE,SDSTB,SDSTA) ; -- update appt mgmt screen ; used by AFTER but AFTER is not used
N SDAMBOLD
I $P(SDSTB,"^",3)'=$P(SDSTA,"^",3) D UPD^SDAM2($$LOWER^VALM1($P(SDSTA,"^",3)),"STAT",SDLNE),UPD^SDAM2("","TIME",SDLNE) S SDAMBOLD(DFN,SDT,SDCL)=""
I $P(SDSTA,"^",3)["CHECKED OUT",$P($P(SDSTA,"^",5),".")=DT D UPD^SDAM2($$TIME^SDAM1($P($P(SDSTA,"^",5),".",2)),"TIME",SDLNE)
Q
;
ELIG(DFN,SDT,SDCL,SDDA) ; -- update elig if blank
N X,DR
I $P(^SC(SDCL,"S",SDT,1,SDDA,0),U,10)="" D
.S X=+$G(^DPT(DFN,.36)),X=$S('$D(^DIC(8,X,0)):"",$P(^(0),U,4)=6:"",1:X)
.I X]"" S DR="30////^S X="_X D DIE(SDCL,SDT,SDDA,DR)
Q
;
CHK(SDSTB) ; -- is appointment checked out
N Y
I "^2^8^12^"[("^"_+SDSTB_"^"),$P(SDSTB,"^",3)["CHECKED OUT" S Y=1
Q +$G(Y)
;
DT(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOQUIT) ;Update Check Out Date
N %DT,DR,SDCIDT,X
S:'$D(^SC(SDCL,"S",0)) ^(0)="^44.001DA^^"
S DR="",SDCIDT=$P($G(^SC(SDCL,"S",SDT,1,SDDA,"C")),"^"),X=$P($G(^("C")),"^",3)
I X G DTQ:'SDASK S DR="303R"
I DR="",$P(^SC(SDCL,0),U,24),$$REQ^SDM1A(SDT)="CO" S DR="303R//"_$S($G(SDCODT):$$FTIME^VALM1($S(SDCODT<SDCIDT:SDCIDT,1:SDCODT)),1:"NOW")
I DR="" S DR="303R///"_$S($G(SDCODT):"/"_$S(SDCODT<SDCIDT:SDCIDT,1:SDCODT),1:"NOW")
S DR="S SDCOQUIT="""";"_DR_";K SDCOQUIT"
D DIE(SDCL,SDT,SDDA,DR)
DTQ Q
;
DIE(SDCL,SDT,SDDA,DR) ; -- update appt data in ^SC
N DA,DIE
S DA(2)=SDCL,DA(1)=SDT,DA=SDDA,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
D ^DIE K DQ,DE
DIEQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCO1 6070 printed Oct 16, 2024@18:49:52 Page 2
SDCO1 ;ALB/RMO - Appointment - Check Out ;JAN 15, 2016
+1 ;;5.3;Scheduling;**27,132,149,193,250,296,446,538,627**;08/13/93;Build 249
+2 ;
+3 ;check out if sd/369 is released before 446!!!
+4 ;
EN ;Entry point for SDCO APPT CHECK OUT protocol
+1 NEW SDCOALBF,SDCOAP,SDCOBG,SDCODT,VALMY
+2 SET VALMBCK=""
+3 DO EN^VALM2(XQORNOD(0))
+4 DO FULL^VALM1
+5 SET SDCOAP=0
DO NOW^%DTC
SET SDCODT=$PIECE(%,".")_"."_$EXTRACT($PIECE(%,".",2)_"0000",1,4)
+6 FOR
SET SDCOAP=$ORDER(VALMY(SDCOAP))
if 'SDCOAP
QUIT
Begin DoDot:1
+7 IF $DATA(^TMP("SDAMIDX",$JOB,SDCOAP))
KILL SDAT
SET SDAT=^(SDCOAP)
Begin DoDot:2
+8 WRITE !!,^TMP("SDAM",$JOB,+SDAT,0)
+9 IF $$CHK^SDCOU(SDCOAP)
DO CO(+$PIECE(SDAT,"^",2),+$PIECE(SDAT,"^",3),+$PIECE(SDAT,"^",4),+$PIECE(SDAT,"^",5),0,SDCODT,"CO",+SDAT,.SDCOALBF)
End DoDot:2
End DoDot:1
+10 IF $GET(SDCOALBF)
SET SDCOBG=VALMBG
WRITE !
DO BLD^SDAM
if $DATA(@VALMAR@(SDCOBG,0))
SET VALMBG=SDCOBG
+11 SET VALMBCK="R"
+12 KILL SDAT
+13 QUIT
+14 ;
CO(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOACT,SDLNE,SDCOALBF) ;Appt Check Out
+1 ; Input -- DFN Patient file IEN
+2 ; SDT Appointment Date/Time
+3 ; SDCL Hospital Location file IEN for Appt
+4 ; SDDA IEN in ^SC multiple or null [Optional]
+5 ; SDASK Ask Check Out Date/Time [Optional]
+6 ; SDCODT Date/Time of Check Out [Optional]
+7 ; SDCOACT Appt Mgmt Check Out Action [Optional]
+8 ; SDLNE Appt Mgmt Line Number [Optional]
+9 ; Output -- SDCOALBF Re-build Appt Mgmt List
+10 IF $DATA(XRTL)
DO T0^%ZOSV
+11 NEW SDCOQUIT,SDOE,SDATA,SDECAPPT
+12 if 'SDDA
SET SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
+13 IF 'SDDA
WRITE !!,*7,">>> You cannot check out this appointment."
DO PAUSE^VALM1
GOTO COQ
+14 SET SDATA=$GET(^DPT(DFN,"S",SDT,0))
+15 ; ** MT Blocking removed
+16 ;S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$G(EASACT)'="W",$$MT^EASMTCHK(DFN,$P($G(SDATA),U,16),"C",$G(SDT)) D PAUSE^VALM1 G COQ
+17 ;
+18 ;-- if new encounter, pass to PCE
+19 IF $$NEW^SDPCE(SDT)
Begin DoDot:1
+20 NEW SDCOED
+21 SET SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
+22 ;
+23 ; -- has appt already been checked out
+24 SET SDCOED=$$CHK($TRANSLATE($$STATUS^SDAM1(DFN,SDT,SDCL,SDATA,SDDA),";","^"))
+25 ;
+26 ; -- if not checked out then do interview process
+27 IF '$$CODT^SDCOU(DFN,SDT,SDCL)
Begin DoDot:2
+28 NEW SDCOMKF,SDTRES
+29 ;
+30 ; -- first, check if should make follow-up appt
+31 IF $GET(SDCOACT)="CO"
IF 'SDCOED
Begin DoDot:3
+32 NEW SDCOMKF
+33 DO MC^SDCO5(SDOE,1,.SDCOMKF,.SDCOQUIT)
if $DATA(SDCOQUIT)
QUIT
+34 ;
+35 ; -- Set flag to re-build appointment list
+36 IF $GET(SDCOMKF)
SET SDCOALBF=1
End DoDot:3
+37 ;
+38 ; -- c/o interview if user didn't quit
+39 IF '$DATA(SDCOQUIT)
IF 'SDCOED
Begin DoDot:3
+40 NEW SDAPTYP
+41 SET SDTRES=$$INTV^PXAPI("INTV","SD","PIMS",$PIECE($GET(^SCE(+SDOE,0)),U,5),$PIECE($GET(^SCE(+SDOE,0)),U,4),DFN)
+42 if SDTRES<0
QUIT
+43 ;update SDEC APPOINTMENT - alb/sat 627
+44 ;get SDEC APPOINTMENT ien
SET SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL)
+45 IF SDECAPPT=""
DO SDEC^SDAMWI1
SET SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL)
+46 DO CO1^SDEC25B(SDECAPPT,$SELECT($GET(SDCODT)="":$EXTRACT($$NOW^XLFDT,1,12),1:SDCODT),+SDOE)
+47 ;
+48 ; -- ask user if they want to see c/o screen
+49 SET SDGAFC=$$ASK^SDCO6
+50 IF 'SDGAFC
Begin DoDot:4
+51 NEW SDELIG
+52 SET SDELIG=$$ELSTAT^SDUTL2(DFN)
+53 IF $$MHCLIN^SDUTL2(SDCL)
IF '($$COLLAT^SDUTL2(SDELIG)!$PIECE(SDATA,U,11))
Begin DoDot:5
+54 IF $$NEWGAF^SDUTL2(DFN)
Begin DoDot:6
+55 IF '$$GAFCM^SDUTL2()
SET SDGAFC=1
End DoDot:6
End DoDot:5
End DoDot:4
+56 IF SDGAFC
DO EN^SDCO(SDOE,,1)
End DoDot:3
End DoDot:2
+57 ;
+58 ; -- if already checked out then show c/o screen
+59 IF '$TEST
DO EN^SDCO(SDOE,,1)
End DoDot:1
SET VALMBCK="R"
SET SDCOALBF=1
GOTO COQ
+60 ;
+61 ; -- view if old encounters
+62 SET SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
+63 DO EN^SDCO(SDOE,,1)
+64 ;
COQ KILL %
DO EWLCHK
QUIT
+1 QUIT
EWLCHK ;check if patient has any open EWL entries (SD/372)
+1 ;get appointment
+2 ;
+3 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"APPT")
+4 if $DATA(IOF)
WRITE @IOF
DO APPT^SDWLEVAL(DFN,SDT,SDCL)
+5 if '$DATA(^TMP($JOB,"APPT"))
QUIT
+6 NEW SDEV
DO EN^SDWLEVAL(DFN,.SDEV)
IF SDEV
IF $LENGTH(SDEV(1))>0
Begin DoDot:1
+7 KILL ^TMP("SDWLPL",$JOB),^TMP($JOB,"SDWLPL")
+8 DO INIT^SDWLPL(DFN,"M")
+9 if '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
+10 DO LIST^SDWLPL("M",DFN)
+11 FOR
if '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
NEW SDR
DO ANSW^SDWLEVAL(1,.SDR)
IF 'SDR
DO LIST^SDWLPL("M",DFN)
Begin DoDot:2
+12 FOR
NEW SDR
DO ANSW^SDWLEVAL(0,.SDR)
if '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
IF 'SDR
WRITE !!,"MUST ACCEPT OR ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
BEFORE(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- event driver before ; not used
+1 SET SDATA=SDDA_"^"_DFN_"^"_SDT_"^"_SDCL
SET SDHDL=$$HANDLE^SDAMEVT(1)
+2 DO BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
+3 QUIT
+4 ;
AFTER(SDATA,DFN,SDT,SDCL,SDDA,SDHDL,SDLNE) ; -- event driver after ; not used
+1 DO AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
+2 if $GET(SDLNE)
DO UPD(DFN,SDT,SDCL,SDLNE,SDATA("BEFORE","STATUS"),SDATA("AFTER","STATUS"))
+3 DO EVT^SDAMEVT(.SDATA,5,0,SDHDL)
+4 QUIT
+5 ;
UPD(DFN,SDT,SDCL,SDLNE,SDSTB,SDSTA) ; -- update appt mgmt screen ; used by AFTER but AFTER is not used
+1 NEW SDAMBOLD
+2 IF $PIECE(SDSTB,"^",3)'=$PIECE(SDSTA,"^",3)
DO UPD^SDAM2($$LOWER^VALM1($PIECE(SDSTA,"^",3)),"STAT",SDLNE)
DO UPD^SDAM2("","TIME",SDLNE)
SET SDAMBOLD(DFN,SDT,SDCL)=""
+3 IF $PIECE(SDSTA,"^",3)["CHECKED OUT"
IF $PIECE($PIECE(SDSTA,"^",5),".")=DT
DO UPD^SDAM2($$TIME^SDAM1($PIECE($PIECE(SDSTA,"^",5),".",2)),"TIME",SDLNE)
+4 QUIT
+5 ;
ELIG(DFN,SDT,SDCL,SDDA) ; -- update elig if blank
+1 NEW X,DR
+2 IF $PIECE(^SC(SDCL,"S",SDT,1,SDDA,0),U,10)=""
Begin DoDot:1
+3 SET X=+$GET(^DPT(DFN,.36))
SET X=$SELECT('$DATA(^DIC(8,X,0)):"",$PIECE(^(0),U,4)=6:"",1:X)
+4 IF X]""
SET DR="30////^S X="_X
DO DIE(SDCL,SDT,SDDA,DR)
End DoDot:1
+5 QUIT
+6 ;
CHK(SDSTB) ; -- is appointment checked out
+1 NEW Y
+2 IF "^2^8^12^"[("^"_+SDSTB_"^")
IF $PIECE(SDSTB,"^",3)["CHECKED OUT"
SET Y=1
+3 QUIT +$GET(Y)
+4 ;
DT(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOQUIT) ;Update Check Out Date
+1 NEW %DT,DR,SDCIDT,X
+2 if '$DATA(^SC(SDCL,"S",0))
SET ^(0)="^44.001DA^^"
+3 SET DR=""
SET SDCIDT=$PIECE($GET(^SC(SDCL,"S",SDT,1,SDDA,"C")),"^")
SET X=$PIECE($GET(^("C")),"^",3)
+4 IF X
if 'SDASK
GOTO DTQ
SET DR="303R"
+5 IF DR=""
IF $PIECE(^SC(SDCL,0),U,24)
IF $$REQ^SDM1A(SDT)="CO"
SET DR="303R//"_$SELECT($GET(SDCODT):$$FTIME^VALM1($SELECT(SDCODT<SDCIDT:SDCIDT,1:SDCODT)),1:"NOW")
+6 IF DR=""
SET DR="303R///"_$SELECT($GET(SDCODT):"/"_$SELECT(SDCODT<SDCIDT:SDCIDT,1:SDCODT),1:"NOW")
+7 SET DR="S SDCOQUIT="""";"_DR_";K SDCOQUIT"
+8 DO DIE(SDCL,SDT,SDDA,DR)
DTQ QUIT
+1 ;
DIE(SDCL,SDT,SDDA,DR) ; -- update appt data in ^SC
+1 NEW DA,DIE
+2 SET DA(2)=SDCL
SET DA(1)=SDT
SET DA=SDDA
SET DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
+3 DO ^DIE
KILL DQ,DE
DIEQ QUIT
