SDCO7 ;ALB/RMO - Miscellaneous Actions - Check Out; 14 APR 1993 10:00 am
;;5.3;Scheduling;**132,149,175,193**;Aug 13, 1993
;
CD ;Entry point for SDCO DATE CHANGE protocol
; Input -- SDOE
N DFN,SDCL,SDCOQUIT,SDDA,SDOE0,SDORG,SDT
S VALMBCK=""
;
; -- if OLD encounter, quit
IF '$$EDITOK^SDCO3($G(SDOE),1) G CDQ
;
S SDOE0=$G(^SCE(+SDOE,0)),SDT=+^(0),DFN=+$P(SDOE0,"^",2),SDCL=+$P(SDOE0,"^",4),SDORG=+$P(SDOE0,"^",8),SDDA=+$P(SDOE0,"^",9)
I SDORG'=1 W !!,*7,">>> Only appointments have a check out date to edit." D PAUSE^VALM1 G CDQ
I '$P($G(^SC(SDCL,"S",SDT,1,SDDA,"C")),"^",3) W !!,*7,">>> No check out date for this appointment." D PAUSE^VALM1 G CDQ
D DT^SDCO1(DFN,SDT,SDCL,SDDA,1,.SDCOQUIT)
S VALMBCK="R"
CDQ Q
;
PD ;Entry point for SDCO PATIENT DEMOGRAPHICS protocol
; Input -- SDOE
S VALMBCK=""
D FULL^VALM1
W !!,VALMHDR(1),!
D DEM^SDCOAM(+$P($G(^SCE(+SDOE,0)),"^",2))
S VALMBCK="R"
PDQ Q
;
DC ;Entry point for SDCO DISCHARGE CLINIC protocol
; Input -- SDOE
N DFN,SDCLN,SDFN,SDOE0
S VALMBCK=""
S SDOE0=$G(^SCE(+SDOE,0)),SDFN=+$P(SDOE0,"^",2)
S:$P(SDOE0,"^",4) SDCLN=+$P(SDOE0,"^",4)
D FULL^VALM1
W !!,VALMHDR(1),!
D DIS^SDCOAM(SDFN,$G(SDCLN))
S VALMBCK="R"
DCQ Q
;
GAF ;Entry point for SDCO GAF protocol
;Input -- SDOE
S VALMBCK=""
D FULL^VALM1
W !!
N DFN,SDCL,SDELIG
S DFN=+$P($G(^SCE(+SDOE,0)),"^",2)
S SDCL=+$P($G(^SCE(+SDOE,0)),"^",4)
S SDATA=$G(^DPT(DFN,"S",SDT,0))
S SDELIG=$$ELSTAT^SDUTL2(DFN)
;
I '$$MHCLIN^SDUTL2(SDCL)!($$COLLAT^SDUTL2(SDELIG))!($P(SDATA,U,11)) D S VALMBCK="R" Q
. S DIR(0)="FAO"
. S DIR("A",1)="A GAF Score is not applicable to this appointment!"
. S DIR("A")="Press any key to continue"
. D ^DIR K DIR
;
N SDGSCR S SDGSCR=$$NEWGAF^SDUTL2(DFN)
I +$P(SDGSCR,U,5)>0 W !,"Warning: Patient is deceased."
I '+SDGSCR D
. W !,"Current GAF: "_+$P(SDGSCR,U,2)
. W $S($P(SDGSCR,U,3)>0:", from "_$$FMTE^XLFDT($P(SDGSCR,U,3),"D"),1:", Date Unavailable")
;
D EN^SDGAF(DFN)
D HDR^SDCO ; reset header after entering new GAF score
S VALMBCK="R"
GAFQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCO7 2091 printed Oct 16, 2024@18:50:03 Page 2
SDCO7 ;ALB/RMO - Miscellaneous Actions - Check Out; 14 APR 1993 10:00 am
+1 ;;5.3;Scheduling;**132,149,175,193**;Aug 13, 1993
+2 ;
CD ;Entry point for SDCO DATE CHANGE protocol
+1 ; Input -- SDOE
+2 NEW DFN,SDCL,SDCOQUIT,SDDA,SDOE0,SDORG,SDT
+3 SET VALMBCK=""
+4 ;
+5 ; -- if OLD encounter, quit
+6 IF '$$EDITOK^SDCO3($GET(SDOE),1)
GOTO CDQ
+7 ;
+8 SET SDOE0=$GET(^SCE(+SDOE,0))
SET SDT=+^(0)
SET DFN=+$PIECE(SDOE0,"^",2)
SET SDCL=+$PIECE(SDOE0,"^",4)
SET SDORG=+$PIECE(SDOE0,"^",8)
SET SDDA=+$PIECE(SDOE0,"^",9)
+9 IF SDORG'=1
WRITE !!,*7,">>> Only appointments have a check out date to edit."
DO PAUSE^VALM1
GOTO CDQ
+10 IF '$PIECE($GET(^SC(SDCL,"S",SDT,1,SDDA,"C")),"^",3)
WRITE !!,*7,">>> No check out date for this appointment."
DO PAUSE^VALM1
GOTO CDQ
+11 DO DT^SDCO1(DFN,SDT,SDCL,SDDA,1,.SDCOQUIT)
+12 SET VALMBCK="R"
CDQ QUIT
+1 ;
PD ;Entry point for SDCO PATIENT DEMOGRAPHICS protocol
+1 ; Input -- SDOE
+2 SET VALMBCK=""
+3 DO FULL^VALM1
+4 WRITE !!,VALMHDR(1),!
+5 DO DEM^SDCOAM(+$PIECE($GET(^SCE(+SDOE,0)),"^",2))
+6 SET VALMBCK="R"
PDQ QUIT
+1 ;
DC ;Entry point for SDCO DISCHARGE CLINIC protocol
+1 ; Input -- SDOE
+2 NEW DFN,SDCLN,SDFN,SDOE0
+3 SET VALMBCK=""
+4 SET SDOE0=$GET(^SCE(+SDOE,0))
SET SDFN=+$PIECE(SDOE0,"^",2)
+5 if $PIECE(SDOE0,"^",4)
SET SDCLN=+$PIECE(SDOE0,"^",4)
+6 DO FULL^VALM1
+7 WRITE !!,VALMHDR(1),!
+8 DO DIS^SDCOAM(SDFN,$GET(SDCLN))
+9 SET VALMBCK="R"
DCQ QUIT
+1 ;
GAF ;Entry point for SDCO GAF protocol
+1 ;Input -- SDOE
+2 SET VALMBCK=""
+3 DO FULL^VALM1
+4 WRITE !!
+5 NEW DFN,SDCL,SDELIG
+6 SET DFN=+$PIECE($GET(^SCE(+SDOE,0)),"^",2)
+7 SET SDCL=+$PIECE($GET(^SCE(+SDOE,0)),"^",4)
+8 SET SDATA=$GET(^DPT(DFN,"S",SDT,0))
+9 SET SDELIG=$$ELSTAT^SDUTL2(DFN)
+10 ;
+11 IF '$$MHCLIN^SDUTL2(SDCL)!($$COLLAT^SDUTL2(SDELIG))!($PIECE(SDATA,U,11))
Begin DoDot:1
+12 SET DIR(0)="FAO"
+13 SET DIR("A",1)="A GAF Score is not applicable to this appointment!"
+14 SET DIR("A")="Press any key to continue"
+15 DO ^DIR
KILL DIR
End DoDot:1
SET VALMBCK="R"
QUIT
+16 ;
+17 NEW SDGSCR
SET SDGSCR=$$NEWGAF^SDUTL2(DFN)
+18 IF +$PIECE(SDGSCR,U,5)>0
WRITE !,"Warning: Patient is deceased."
+19 IF '+SDGSCR
Begin DoDot:1
+20 WRITE !,"Current GAF: "_+$PIECE(SDGSCR,U,2)
+21 WRITE $SELECT($PIECE(SDGSCR,U,3)>0:", from "_$$FMTE^XLFDT($PIECE(SDGSCR,U,3),"D"),1:", Date Unavailable")
End DoDot:1
+22 ;
+23 DO EN^SDGAF(DFN)
+24 ; reset header after entering new GAF score
DO HDR^SDCO
+25 SET VALMBCK="R"
GAFQ QUIT
