Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDCO1

SDCO1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;check out if sd/369 is released before 446!!!
  1. ;
  1. EN ;Entry point for SDCO APPT CHECK OUT protocol
  1. N SDCOALBF,SDCOAP,SDCOBG,SDCODT,VALMY
  1. S VALMBCK=""
  1. D EN^VALM2(XQORNOD(0))
  1. D FULL^VALM1
  1. S SDCOAP=0 D NOW^%DTC S SDCODT=$P(%,".")_"."_$E($P(%,".",2)_"0000",1,4)
  1. F S SDCOAP=$O(VALMY(SDCOAP)) Q:'SDCOAP D
  1. .I $D(^TMP("SDAMIDX",$J,SDCOAP)) K SDAT S SDAT=^(SDCOAP) D
  1. ..W !!,^TMP("SDAM",$J,+SDAT,0)
  1. ..I $$CHK^SDCOU(SDCOAP) D CO(+$P(SDAT,"^",2),+$P(SDAT,"^",3),+$P(SDAT,"^",4),+$P(SDAT,"^",5),0,SDCODT,"CO",+SDAT,.SDCOALBF)
  1. I $G(SDCOALBF) S SDCOBG=VALMBG W ! D BLD^SDAM S:$D(@VALMAR@(SDCOBG,0)) VALMBG=SDCOBG
  1. S VALMBCK="R"
  1. K SDAT
  1. Q
  1. ;
  1. CO(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOACT,SDLNE,SDCOALBF) ;Appt Check Out
  1. ; Input -- DFN Patient file IEN
  1. ; SDT Appointment Date/Time
  1. ; SDCL Hospital Location file IEN for Appt
  1. ; SDDA IEN in ^SC multiple or null [Optional]
  1. ; SDASK Ask Check Out Date/Time [Optional]
  1. ; SDCODT Date/Time of Check Out [Optional]
  1. ; SDCOACT Appt Mgmt Check Out Action [Optional]
  1. ; SDLNE Appt Mgmt Line Number [Optional]
  1. ; Output -- SDCOALBF Re-build Appt Mgmt List
  1. I $D(XRTL) D T0^%ZOSV
  1. N SDCOQUIT,SDOE,SDATA,SDECAPPT
  1. S:'SDDA SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
  1. I 'SDDA W !!,*7,">>> You cannot check out this appointment." D PAUSE^VALM1 G COQ
  1. S SDATA=$G(^DPT(DFN,"S",SDT,0))
  1. ; ** MT Blocking removed
  1. ;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
  1. ;
  1. ;-- if new encounter, pass to PCE
  1. I $$NEW^SDPCE(SDT) D S VALMBCK="R",SDCOALBF=1 G COQ
  1. . N SDCOED
  1. . S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
  1. . ;
  1. . ; -- has appt already been checked out
  1. . S SDCOED=$$CHK($TR($$STATUS^SDAM1(DFN,SDT,SDCL,SDATA,SDDA),";","^"))
  1. . ;
  1. . ; -- if not checked out then do interview process
  1. . IF '$$CODT^SDCOU(DFN,SDT,SDCL) D
  1. . . N SDCOMKF,SDTRES
  1. . . ;
  1. . . ; -- first, check if should make follow-up appt
  1. . . IF $G(SDCOACT)="CO",'SDCOED D
  1. . . . N SDCOMKF
  1. . . . D MC^SDCO5(SDOE,1,.SDCOMKF,.SDCOQUIT) Q:$D(SDCOQUIT)
  1. . . . ;
  1. . . . ; -- Set flag to re-build appointment list
  1. . . . IF $G(SDCOMKF) S SDCOALBF=1
  1. . . ;
  1. . . ; -- c/o interview if user didn't quit
  1. . . I '$D(SDCOQUIT),'SDCOED D
  1. . . . N SDAPTYP
  1. . . . S SDTRES=$$INTV^PXAPI("INTV","SD","PIMS",$P($G(^SCE(+SDOE,0)),U,5),$P($G(^SCE(+SDOE,0)),U,4),DFN)
  1. . . . Q:SDTRES<0
  1. . . . ;update SDEC APPOINTMENT - alb/sat 627
  1. . . . S SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL) ;get SDEC APPOINTMENT ien
  1. . . . I SDECAPPT="" D SDEC^SDAMWI1 S SDECAPPT=$$APPTGET^SDECUTL(DFN,SDT,SDCL)
  1. . . . D CO1^SDEC25B(SDECAPPT,$S($G(SDCODT)="":$E($$NOW^XLFDT,1,12),1:SDCODT),+SDOE)
  1. . . . ;
  1. . . . ; -- ask user if they want to see c/o screen
  1. . . . S SDGAFC=$$ASK^SDCO6
  1. . . . I 'SDGAFC D
  1. . . . .N SDELIG
  1. . . . .S SDELIG=$$ELSTAT^SDUTL2(DFN)
  1. . . . .I $$MHCLIN^SDUTL2(SDCL),'($$COLLAT^SDUTL2(SDELIG)!$P(SDATA,U,11)) D
  1. . . . . .I $$NEWGAF^SDUTL2(DFN) D
  1. . . . . . .I '$$GAFCM^SDUTL2() S SDGAFC=1
  1. . . .I SDGAFC D EN^SDCO(SDOE,,1)
  1. . ;
  1. . ; -- if already checked out then show c/o screen
  1. . E D EN^SDCO(SDOE,,1)
  1. ;
  1. ; -- view if old encounters
  1. S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
  1. D EN^SDCO(SDOE,,1)
  1. ;
  1. COQ K % D EWLCHK Q
  1. Q
  1. EWLCHK ;check if patient has any open EWL entries (SD/372)
  1. ;get appointment
  1. ;
  1. K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
  1. W:$D(IOF) @IOF D APPT^SDWLEVAL(DFN,SDT,SDCL)
  1. Q:'$D(^TMP($J,"APPT"))
  1. N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
  1. .K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
  1. .D INIT^SDWLPL(DFN,"M")
  1. .Q:'$D(^TMP($J,"SDWLPL"))
  1. .D LIST^SDWLPL("M",DFN)
  1. .F Q:'$D(^TMP($J,"SDWLPL")) N SDR D ANSW^SDWLEVAL(1,.SDR) I 'SDR D LIST^SDWLPL("M",DFN) D
  1. ..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",!
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. BEFORE(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- event driver before ; not used
  1. S SDATA=SDDA_"^"_DFN_"^"_SDT_"^"_SDCL,SDHDL=$$HANDLE^SDAMEVT(1)
  1. D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
  1. Q
  1. ;
  1. AFTER(SDATA,DFN,SDT,SDCL,SDDA,SDHDL,SDLNE) ; -- event driver after ; not used
  1. D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
  1. D:$G(SDLNE) UPD(DFN,SDT,SDCL,SDLNE,SDATA("BEFORE","STATUS"),SDATA("AFTER","STATUS"))
  1. D EVT^SDAMEVT(.SDATA,5,0,SDHDL)
  1. Q
  1. ;
  1. UPD(DFN,SDT,SDCL,SDLNE,SDSTB,SDSTA) ; -- update appt mgmt screen ; used by AFTER but AFTER is not used
  1. N SDAMBOLD
  1. 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)=""
  1. I $P(SDSTA,"^",3)["CHECKED OUT",$P($P(SDSTA,"^",5),".")=DT D UPD^SDAM2($$TIME^SDAM1($P($P(SDSTA,"^",5),".",2)),"TIME",SDLNE)
  1. Q
  1. ;
  1. ELIG(DFN,SDT,SDCL,SDDA) ; -- update elig if blank
  1. N X,DR
  1. I $P(^SC(SDCL,"S",SDT,1,SDDA,0),U,10)="" D
  1. .S X=+$G(^DPT(DFN,.36)),X=$S('$D(^DIC(8,X,0)):"",$P(^(0),U,4)=6:"",1:X)
  1. .I X]"" S DR="30////^S X="_X D DIE(SDCL,SDT,SDDA,DR)
  1. Q
  1. ;
  1. CHK(SDSTB) ; -- is appointment checked out
  1. N Y
  1. I "^2^8^12^"[("^"_+SDSTB_"^"),$P(SDSTB,"^",3)["CHECKED OUT" S Y=1
  1. Q +$G(Y)
  1. ;
  1. DT(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOQUIT) ;Update Check Out Date
  1. N %DT,DR,SDCIDT,X
  1. S:'$D(^SC(SDCL,"S",0)) ^(0)="^44.001DA^^"
  1. S DR="",SDCIDT=$P($G(^SC(SDCL,"S",SDT,1,SDDA,"C")),"^"),X=$P($G(^("C")),"^",3)
  1. I X G DTQ:'SDASK S DR="303R"
  1. 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")
  1. I DR="" S DR="303R///"_$S($G(SDCODT):"/"_$S(SDCODT<SDCIDT:SDCIDT,1:SDCODT),1:"NOW")
  1. S DR="S SDCOQUIT="""";"_DR_";K SDCOQUIT"
  1. D DIE(SDCL,SDT,SDDA,DR)
  1. DTQ Q
  1. ;
  1. DIE(SDCL,SDT,SDDA,DR) ; -- update appt data in ^SC
  1. N DA,DIE
  1. S DA(2)=SDCL,DA(1)=SDT,DA=SDDA,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
  1. D ^DIE K DQ,DE
  1. DIEQ Q