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