source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCO1.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1SDCO1 ;ALB/RMO - Appointment - Check Out;Apr 23 1999 ; Compiled November 16, 2006 15:24:29
2 ;;5.3;Scheduling;**27,132,149,193,250,296,446**;08/13/93;Build 77
3 ;
4 ;check out if sd/369 is released before 446!!!
5 ;
6EN ;Entry point for SDCO APPT CHECK OUT protocol
7 N SDCOALBF,SDCOAP,SDCOBG,SDCODT,VALMY
8 S VALMBCK=""
9 D EN^VALM2(XQORNOD(0))
10 D FULL^VALM1
11 S SDCOAP=0 D NOW^%DTC S SDCODT=$P(%,".")_"."_$E($P(%,".",2)_"0000",1,4)
12 F S SDCOAP=$O(VALMY(SDCOAP)) Q:'SDCOAP D
13 .I $D(^TMP("SDAMIDX",$J,SDCOAP)) K SDAT S SDAT=^(SDCOAP) D
14 ..W !!,^TMP("SDAM",$J,+SDAT,0)
15 ..I $$CHK^SDCOU(SDCOAP) D CO(+$P(SDAT,"^",2),+$P(SDAT,"^",3),+$P(SDAT,"^",4),+$P(SDAT,"^",5),0,SDCODT,"CO",+SDAT,.SDCOALBF)
16 I $G(SDCOALBF) S SDCOBG=VALMBG W ! D BLD^SDAM S:$D(@VALMAR@(SDCOBG,0)) VALMBG=SDCOBG
17 S VALMBCK="R"
18 K SDAT
19 Q
20 ;
21CO(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOACT,SDLNE,SDCOALBF) ;Appt Check Out
22 ; Input -- DFN Patient file IEN
23 ; SDT Appointment Date/Time
24 ; SDCL Hospital Location file IEN for Appt
25 ; SDDA IEN in ^SC multiple or null [Optional]
26 ; SDASK Ask Check Out Date/Time [Optional]
27 ; SDCODT Date/Time of Check Out [Optional]
28 ; SDCOACT Appt Mgmt Check Out Action [Optional]
29 ; SDLNE Appt Mgmt Line Number [Optional]
30 ; Output -- SDCOALBF Re-build Appt Mgmt List
31 I $D(XRTL) D T0^%ZOSV
32 N SDCOQUIT,SDOE,SDATA
33 S:'SDDA SDDA=$$FIND^SDAM2(DFN,SDT,SDCL)
34 I 'SDDA W !!,*7,">>> You cannot check out this appointment." D PAUSE^VALM1 G COQ
35 S SDATA=$G(^DPT(DFN,"S",SDT,0))
36 ; ** MT Blocking removed
37 ;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
38 ;
39 ;-- if new encounter, pass to PCE
40 I $$NEW^SDPCE(SDT) D S VALMBCK="R",SDCOALBF=1 G COQ
41 . N SDCOED
42 . S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
43 . ;
44 . ; -- has appt already been checked out
45 . S SDCOED=$$CHK($TR($$STATUS^SDAM1(DFN,SDT,SDCL,SDATA,SDDA),";","^"))
46 . ;
47 . ; -- if not checked out then do interview process
48 . IF '$$CODT^SDCOU(DFN,SDT,SDCL) D
49 . . N SDCOMKF,SDTRES
50 . . ;
51 . . ; -- first, check if should make follow-up appt
52 . . IF $G(SDCOACT)="CO",'SDCOED D
53 . . . N SDCOMKF
54 . . . D MC^SDCO5(SDOE,1,.SDCOMKF,.SDCOQUIT) Q:$D(SDCOQUIT)
55 . . . ;
56 . . . ; -- Set flag to re-build appointment list
57 . . . IF $G(SDCOMKF) S SDCOALBF=1
58 . . ;
59 . . ; -- c/o interview if user didn't quit
60 . . I '$D(SDCOQUIT),'SDCOED D
61 . . . N SDAPTYP
62 . . . S SDTRES=$$INTV^PXAPI("INTV","SD","PIMS",$P($G(^SCE(+SDOE,0)),U,5),$P($G(^SCE(+SDOE,0)),U,4),DFN)
63 . . . Q:SDTRES<0
64 . . . ;
65 . . . ; -- ask user if they want to see c/o screen
66 . . . S SDGAFC=$$ASK^SDCO6
67 . . . I 'SDGAFC D
68 . . . .N SDELIG
69 . . . .S SDELIG=$$ELSTAT^SDUTL2(DFN)
70 . . . .I $$MHCLIN^SDUTL2(SDCL),'($$COLLAT^SDUTL2(SDELIG)!$P(SDATA,U,11)) D
71 . . . . .I $$NEWGAF^SDUTL2(DFN) D
72 . . . . . .I '$$GAFCM^SDUTL2() S SDGAFC=1
73 . . .I SDGAFC D EN^SDCO(SDOE,,1)
74 . ;
75 . ; -- if already checked out then show c/o screen
76 . E D EN^SDCO(SDOE,,1)
77 ;
78 ; -- view if old encounters
79 S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
80 D EN^SDCO(SDOE,,1)
81 ;
82COQ K % D EWLCHK Q
83 Q
84EWLCHK ;check if patient has any open EWL entries (SD/372)
85 ;get appointment
86 ;
87 K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
88 W:$D(IOF) @IOF D APPT^SDWLEVAL(DFN,SDT,SDCL)
89 Q:'$D(^TMP($J,"APPT"))
90 N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
91 .K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
92 .D INIT^SDWLPL(DFN,"M")
93 .Q:'$D(^TMP($J,"SDWLPL"))
94 .D LIST^SDWLPL("M",DFN)
95 .F Q:'$D(^TMP($J,"SDWLPL")) N SDR D ANSW^SDWLEVAL(1,.SDR) I 'SDR D LIST^SDWLPL("M",DFN) D
96 ..F N SDR D ANSW^SDWLEVAL(0,.SDR) Q:'$D(^TMP($J,"SDWLPL")) I 'SDR W !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
97 ..Q
98 .Q
99 Q
100 ;
101BEFORE(SDATA,DFN,SDT,SDCL,SDDA,SDHDL) ; -- event driver before ; not used
102 S SDATA=SDDA_"^"_DFN_"^"_SDT_"^"_SDCL,SDHDL=$$HANDLE^SDAMEVT(1)
103 D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
104 Q
105 ;
106AFTER(SDATA,DFN,SDT,SDCL,SDDA,SDHDL,SDLNE) ; -- event driver after ; not used
107 D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDHDL)
108 D:$G(SDLNE) UPD(DFN,SDT,SDCL,SDLNE,SDATA("BEFORE","STATUS"),SDATA("AFTER","STATUS"))
109 D EVT^SDAMEVT(.SDATA,5,0,SDHDL)
110 Q
111 ;
112UPD(DFN,SDT,SDCL,SDLNE,SDSTB,SDSTA) ; -- update appt mgmt screen ; used by AFTER but AFTER is not used
113 N SDAMBOLD
114 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)=""
115 I $P(SDSTA,"^",3)["CHECKED OUT",$P($P(SDSTA,"^",5),".")=DT D UPD^SDAM2($$TIME^SDAM1($P($P(SDSTA,"^",5),".",2)),"TIME",SDLNE)
116 Q
117 ;
118ELIG(DFN,SDT,SDCL,SDDA) ; -- update elig if blank
119 N X,DR
120 I $P(^SC(SDCL,"S",SDT,1,SDDA,0),U,10)="" D
121 .S X=+$G(^DPT(DFN,.36)),X=$S('$D(^DIC(8,X,0)):"",$P(^(0),U,4)=6:"",1:X)
122 .I X]"" S DR="30////^S X="_X D DIE(SDCL,SDT,SDDA,DR)
123 Q
124 ;
125CHK(SDSTB) ; -- is appointment checked out
126 N Y
127 I "^2^8^12^"[("^"_+SDSTB_"^"),$P(SDSTB,"^",3)["CHECKED OUT" S Y=1
128 Q +$G(Y)
129 ;
130DT(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOQUIT) ;Update Check Out Date
131 N %DT,DR,SDCIDT,X
132 S:'$D(^SC(SDCL,"S",0)) ^(0)="^44.001DA^^"
133 S DR="",SDCIDT=$P($G(^SC(SDCL,"S",SDT,1,SDDA,"C")),"^"),X=$P($G(^("C")),"^",3)
134 I X G DTQ:'SDASK S DR="303R"
135 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")
136 I DR="" S DR="303R///"_$S($G(SDCODT):"/"_$S(SDCODT<SDCIDT:SDCIDT,1:SDCODT),1:"NOW")
137 S DR="S SDCOQUIT="""";"_DR_";K SDCOQUIT"
138 D DIE(SDCL,SDT,SDDA,DR)
139DTQ Q
140 ;
141DIE(SDCL,SDT,SDDA,DR) ; -- update appt data in ^SC
142 N DA,DIE
143 S DA(2)=SDCL,DA(1)=SDT,DA=SDDA,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
144 D ^DIE K DQ,DE
145DIEQ Q
Note: See TracBrowser for help on using the repository browser.