- 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 Feb 19, 2025@00:15:55 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