source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDM1A.m@ 1141

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

initial load of FOIAVistA 6/30/08 version

File size: 9.5 KB
Line 
1SDM1A ;SF/GFT,ALB/TMP - MAKE APPOINTMENT ; 8/18/05 12:57pm ; Compiled April 17, 2007 15:12:14
2 ;;5.3;Scheduling;**26,94,155,206,168,223,241,263,327,478,446**;Aug 13, 1993;Build 77
3OK I $D(SDMLT) D ^SDM4 Q:X="^"!(SDMADE=2)
4 S ^SC(SC,"ST",$P(SD,"."),1)=S,^DPT(DFN,"S",SD,0)=SC,^SC(SC,"S",SD,0)=SD S:'$D(^DPT(DFN,"S",0)) ^(0)="^2.98P^^" S:'$D(^SC(SC,"S",0)) ^(0)="^44.001DA^^" L
5S1 L ^SC(SC,"S",SD,1):5 G:'$T S1 F SDY=1:1 I '$D(^SC(SC,"S",SD,1,SDY)) S:'$D(^(0)) ^(0)="^44.003PA^^" S ^(SDY,0)=DFN_U_(+SL) L Q
6 I SM S ^("OB")="O" ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDY,"OB")
7 I $D(^SC(SC,"RAD")),^("RAD")="Y"!(^("RAD")=1) S ^SC("ARAD",SC,SD,DFN)=""
8 S SDINP=$$INP^SDAM2(DFN,SD)
9 ;-- added sub-category
10 S COV=3,SDYC="",COV=$S(COLLAT=1:1,1:3),SDYC=$S(COLLAT=7:1,1:"")
11 S:SD<DT SDSRTY="W"
12 S ^DPT(DFN,"S",SD,0)=SC_"^"_$$STATUS(SC,SDINP,SD)_"^^^^^"_COV_"^^^^"_SDYC_"^^^^^"_SDAPTYP_U_$G(SD17)_"^^"_DT_"^^^^^"_$G(SDXSCAT)_U_$P($G(SDSRTY),U,2)_U_$$NAVA^SDMANA(SC,SD,$P($G(SDSRTY),U,2))
13 S ^DPT(DFN,"S",SD,1)=$G(SDDATE)_U_$G(SDSRFU)
14 I $D(SDMULT) S SDCLNCND=^SC(SC,0),STPCOD=$P(SDCLNCND,U,7),TMPYCLNC=SC_U_$P(SDCLNCND,U) D A^SDCNSLT ;SD/478 MULTI CLINIC OPTION SELECTED
15 ;xref DATE APPT. MADE field
16 D
17 .N DIV,DA,DIK
18 .S DA=SD,DA(1)=DFN,DIK="^DPT(DA(1),""S"",",DIK(1)=20 D EN1^DIK
19 .Q
20 K:$D(^DPT(DFN,"S",SD,"R")) ^("R") K:$D(^DPT("ASDCN",SC,SD,DFN)) ^(DFN)
21 S SDRT="A",SDTTM=SD,SDPL=SDY,SDSC=SC D RT^SDUTL
22 W !," ",+SL,"-MINUTE APPOINTMENT MADE" K SDINP
23 ;confirm request type & follow-up indicator
24 I $D(SDSRTY(0)) D CONF(.SDSRTY,.SDSRFU,DFN,SD,SC) W !
25 I $P(SD,".")'>DT,$D(^DPT(DFN,.321)) D EN1^SDM3
26 ;Wait List SD*5.3*263
27 ;I '$D(SDWLLIST) D ^SDWLR ;replaced with sd/372, see below
28EWLCHK ;check if patient has any open EWL entries (SD/372)
29 ;get appointment
30 K ^TMP($J,"SDAMA301"),^TMP($J,"APPT")
31 D APPT^SDWLEVAL(DFN,SD,SC)
32 Q:'$D(^TMP($J,"APPT"))
33 N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
34 .K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
35 .D INIT^SDWLPL(DFN,"M")
36 .Q:'$D(^TMP($J,"SDWLPL"))
37 .D LIST^SDWLPL("M",DFN)
38 .F Q:'$D(^TMP($J,"SDWLPL")) N SDR D ANSW^SDWLEVAL(1,.SDR) I 'SDR D LIST^SDWLPL("M",DFN) D
39 ..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",!
40 ;CREATE 120 FLAG IF APPLICABLE; appt created
41FLG N SDST S SDST=$G(^TMP($J,"APPT",1)) I +SDST>0 D
42 .Q ; sd/446
43 .N SDT,SDDES,SDPAR,SDDES1,SDT1 S SDPAR=0 S SDT=+SDST,SDDES=$P(SDST,U,17) I SDDES="" S SDDES=DT ; today's date if no desired date
44 .S X=SDT D H^%DTC S SDT1=%H
45 .S X=SDDES D H^%DTC S SDDES1=%H
46 .I SDT1-SDDES1>120 N SD120,SD120A S SD120=1,SD120A=1 D
47 ..; CREATE ewl eN SDPR S SDPR=$S(SDDES=DT:"A",1:"F") entry with 120 flag
48 ..N SDPR S SDPR=$S(SDDES=DT:"A",1:"F") ;10
49 ..N SDWLIN S SDWLIN=+$P(SDST,U,15) ;2
50 ..N SDWLSCPR S SDWLSCPR=0 I +$P(SDST,U,10)=11 S SDWLSCPR=1 ;15
51 ..N SC,SDWLSCL S SC=+$P(SDST,U,2) D
52 ...I $D(^SDWL(409.32,"B",SC)) S SDWLSCL=$O(^SDWL(409.32,"B",SC,"")) Q ;8
53 ...;create 409.32 entry
54 ...N DA,DIC S DIC(0)="LX",X=SC,DIC="^SDWL(409.32," D FILE^DICN
55 ...S SDWLSCL=DA
56 ...S DIE="^SDWL(409.32,"
57 ...S DR=".02////^S X=SDWLIN" D ^DIE
58 ...S DR="1////^S X=DT"
59 ...S DR=DR_";2////^S X=DUZ"
60 ...D ^DIE S SDPAR=1
61 ..N DA S DIC(0)="LX",(X,SDWLDFN)=+$P(SDST,U,4),X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
62 ..F L +^SDWL(409.3,DA):5 Q:$T D
63 ...I '$T W !,"Unable to acquire a lock on the Wait List file" Q
64 ..; Update EWL variables.
65 ..S SDWLDA=DA D EN^SDWLE11 ; get enrollee both SDWLDA and SDWLDFN have to be
66 ..N SDWLCM S SDWLCM=" > 120 days; appt created"
67 ..N SDWLSCPG S SDWLSCPG=$S($P($G(^DPT(SDWLDFN,.3)),U,1)="Y":$P(^(.3),U,2),1:"")
68 ..S DR="1////^S X=DT"
69 ..S DR=DR_";2////^S X=SDWLIN"
70 ..S DR=DR_";4////^S X=4"
71 ..S DR=DR_";8////^S X=SDWLSCL"
72 ..S DR=DR_";9////^S X=DUZ"
73 ..S DR=DR_";10////^S X=SDPR"
74 ..S DR=DR_";11////^S X=2" ; by patient for this entry to avoid asking for provider
75 ..S DR=DR_";14////^S X=SDWLSCPG"
76 ..S DR=DR_";15////^S X=SDWLSCPR"
77 ..S DR=DR_";22////^S X=SDDES"
78 ..S DR=DR_";23////^S X=""O"""
79 ..S DR=DR_";25////^S X=SDWLCM"
80 ..S DR=DR_";36////^S X=SD120"
81 ..S DR=DR_";39////^S X=SD120A"
82 ..S DIE="^SDWL(409.3,"
83 ..D ^DIE
84 ..L -^SDWL(409.3,DA)
85 ..D MESS^SDWL120(SDWLDFN,SC,SDT,SDPAR)
86 ;continue appointment entry process
87ORD S %=2 W !,"WANT PATIENT NOTIFIED OF LAB,X-RAY, OR EKG STOPS" D YN^DICN I '% W !," Enter YES to notify patient on appt. letter of LAB, X-RAY, or EKG stops" G ORD
88 I '(%-1) D ORDY^SDM3
89OTHER R !," OTHER INFO: ",D:DTIME I D["^" W !,*7,"'^' not allowed - hit return if no 'OTHER INFO' is to be entered" G OTHER
90 S TMPD=D I $L(D)>150 D MSG^SDMM G OTHER ;SD/478
91 I D]"",D?."?"!(D'?.ANP) W " ENTER LAB, SCAN, ETC." G OTHER
92 I $L($G(^SC(SC,"S",SD,1,SDY,0)))+$L(D)+$L(DT)+$S($D(DUZ):$L(DUZ),1:0)>250 D MSG^SDMM G OTHER ; sd/446
93 S $P(^(0),"^",4)=D,$P(^(0),U,6,7)=$S($D(DUZ):DUZ,1:"")_U_DT ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDY,0)
94 D:$D(TMP) LINK^SDCNSLT(SC,SDY,SD,CNSLTLNK) ;SD/478
95 D:$D(TMP) EDITCS^SDCNSLT(SD,TMPD,TMPYCLNC,CNSLTLNK) ;SD/478
96 K TMP ;SD/478
97XR I $S('$D(^SC(SC,"RAD")):1,^("RAD")="Y":0,^("RAD")=1:0,1:1) S %=2 W !,"WANT PREVIOUS X-RAY RESULTS SENT TO CLINIC" D YN^DICN G:'% HXR I '(%-1) S ^SC("ARAD",SC,SD,DFN)=""
98SDMM S SDEMP=0 I COLLAT=7 S:SDEC'=SDCOL SDEMP=SDCOL G OV
99 D ELIG^VADPT I $O(VAEL(1,0))>0 D ELIG^SDM4:"369"[SDAPTYP S SDEMP=$S(SDDECOD:SDDECOD,1:SDEMP)
100OV Q:$D(SDZM) K SDQ1,SDEC,SDCOL I +SDEMP S $P(^SC(SC,"S",SD,1,SDY,0),"^",10)=+SDEMP
101 S SDMADE=1 D EVT Q
102HXR W !," Enter YES to have previous XRAY results sent to the clinic" G XR
103 Q
104CS S SDCS=+$P(^SC(+SC,0),"^",7) I $S('$D(^DIC(40.7,SDCS,0)):1,'$P(^(0),"^",3):0,1:$P(^(0),"^",3)'>DT) W !!,*7,"** WARNING - CLINIC HAS AN INVALID OR INACTIVE STOP CODE!!!",!!
105 S SDCS=+$P(^SC(+SC,0),"^",18) I $S('SDCS:0,'$D(^DIC(40.7,SDCS,0)):1,'$P(^(0),"^",3):0,1:$P(^(0),"^",3)'>DT) W !!,*7,"** WARNING - CLINIC HAS AN INVALID OR INACTIVE CREDIT STOP CODE!!!",!!
106 K SDCS Q
107STATUS(SDCL,SDINP,SDT) ; -- determine status for NEW appts
108 Q $S(SDINP]"":SDINP,$$CHK(.SDCL,.SDT):"NT",1:"")
109CHK(SDCL,SDT) ; -- should appt be NT'ed
110 ; -- non-count clinic check := don't NT appt
111 ; -- appt update executed := need to NT appt
112 ; -- otherwise := don't NT appt
113 Q $S($P($G(^SC(SDCL,0)),U,17)="Y":0,$D(^SDD(409.65,"AUPD",$P(SDT,"."))):1,1:0)
114EVT ; -- separate tag if need to NEW vars
115 D MAKE^SDAMEVT(DFN,SD,SC,SDY,0)
116 Q
117REQ(SDT) ; -- which is required check in(CI) or out(CO)
118 Q $S($$REQDT()>SDT:"CI",1:"CO")
119REQDT() ; -- co required date
120 Q $S($P(^DG(43,1,"SCLR"),U,23):$P(^("SCLR"),U,23),1:2931001)
121COCMP(DFN,SDT) ; -- date CO completed
122 Q $P($G(^SCE(+$P($G(^DPT(DFN,"S",SDT,0)),U,20),0)),U,7)
123CI(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
124 N C
125 I '$$CHK(.SDCL,.SDT) G CIQ
126 I $$REQ(SDT)'="CI" G CIQ
127 I SDACT="SET",$D(^DPT(+^SC(SDCL,"S",SDT,1,SDDA,0),"S",SDT,0)),$P(^(0),U,2)="NT" S $P(^(0),U,2)=""
128 I SDACT="KILL" S C=$G(^SC(SDCL,"S",SDT,1,SDDA,"C")) I $D(^DPT(+$G(^(0)),"S",SDT,0)),$P(^(0),U,2)="",'$P(C,U,3) S $P(^(0),U,2)="NT"
129CIQ Q
130CO(SDCL,SDT,SDDA,SDACT) ; -- ok to update DPT
131 N DFN,C
132 I '$$CHK(.SDCL,.SDT) G COQ
133 I $$REQ(.SDT)'="CO" D G COQ
134 .I SDACT="SET",$D(^DPT(+^SC(SDCL,"S",SDT,1,SDDA,0),"S",SDT,0)),$P(^(0),U,2)="NT" S $P(^(0),U,2)=""
135 .I SDACT="KILL" S C=$G(^SC(SDCL,"S",SDT,1,SDDA,"C")) I $D(^DPT(+$G(^(0)),"S",SDT,0)),$P(^(0),U,2)="",'C S $P(^(0),U,2)="NT"
136 S DFN=+^SC(SDCL,"S",SDT,1,SDDA,0)
137 D UPD(.DFN,.SDT,$$COCMP(.DFN,.SDT),$S(SDACT="SET":X,1:""))
138COQ Q
139UPD(DFN,SDT,SDCOCMP,SDCODT) ; -- update status
140 N Y
141 I $D(^DPT(DFN,"S",SDT,0)) S Y=$P(^(0),U,2) D
142 .I 'SDCOCMP!('SDCODT) S:Y="" $P(^DPT(DFN,"S",SDT,0),U,2)="NT" Q
143 .S:Y="NT" $P(^DPT(DFN,"S",SDT,0),U,2)=""
144 Q
145OE(SDOE,SDACT) ; -- called by x-ref on co completed field(#.07) in ^SCE
146 N Y S Y=^SCE(SDOE,0)
147 I $P(Y,U,8)'=1 G OEQ
148 I $$REQ(+Y)'="CO" G OEQ
149 I '$$CANT(+$P(Y,U,2),+Y,SDOE),'$$CHK(+$P(Y,U,4),+Y) G OEQ
150 D UPD(+$P(Y,U,2),+Y,$S(SDACT="SET":X,1:""),$P($G(^SC(+$P(Y,U,4),"S",+Y,1,+$P(Y,U,9),"C")),U,3))
151OEQ Q
152CONF(SDSRTY,SDSRFU,DFN,SDT,SC) ;Confirm scheduling request type
153 ;Input: SDSRTY=request type
154 ;Input: SDSRFU=follow-up indicator
155 ;Input: DFN=patient ien
156 ;Input: SDT=appointment date/time
157 ;Input: SC=clinic ifn
158 N DIR,DIE,DA,DR,SDX,SDY,X,Y
159 S DIR(0)="Y",DIR("B")="YES"
160 S DIR("A")="THIS APPOINTMENT IS MARKED AS '"_SDSRTY(0)_"', IS THIS CORRECT"
161 W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
162 I 'Y S SDX='SDSRTY,SDX(0)=$$TXRT(.SDX) W !!,"THIS APPOINTMENT HAS NOW BEEN MARKED AS '"_$S('SDSRTY:"",1:"NOT ")_"NEXT AVAILABLE'."
163 ;S DIR("A")="THIS APPOINTMENT IS DEFINED AS '"_$S(SDSRFU:"FOLLOW-UP",1:"OTHER THAN FOLLOW-UP")_"', OK"
164 ;W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
165 ;I 'Y S SDY='SDSRFU W " (changed)"
166 Q:'$D(SDX) S DR=""
167 I $D(SDX) S DR="25///^S X=$P(SDX,U,2);26///^S X=$$NAVA^SDMANA(SC,SDT,$P(SDX,U,2))"
168 ;I $D(SDY) S:$L(DR) DR=DR_";" S DR=DR_"26///^S X=SDY"
169 S DA=SDT,DA(1)=DFN
170 S DIE="^DPT(DA(1),""S""," D ^DIE
171 Q
172TXRT(SDSRTY) ;Transform request type
173 ;Input: SDSRTY=variable to return request type (pass by reference)
174 ;Output: external text for SDSRTY(0)
175 I SDSRTY S SDSRTY=SDSRTY_U_"N" Q "NEXT AVAILABLE"
176 S SDSRTY=SDSRTY_U_"O" Q "NOT NEXT AVAILABLE"
177CANT(DFN,SDT,SDOE) ;Determine if clinic appt. has been marked "NT"
178 ;Output: '1' if appt. points to encounter and is marked "NT", otherwise '0'
179 N SDAPP S SDAPP=$G(^DPT(DFN,"S",SDT,0))
180 Q:$P(SDAPP,U,20)'=SDOE 0
181 Q $P(SDAPP,U,2)="NT"
182 ; -- Variable doc for above tags
183 ; SDCL := file 44 ien
184 ; SDT := appt date/time
185 ; DFN := file 2 ien
186 ; SDDA := ^SC(SDCL,"S",SDT,1,SDDA,0)
187 ; SDACT := current x-ref action 'set' or 'kill'
188 ; SDCOCMP := check out completed date
189 ; SDCODT := check out date/time
190 ; SDOE := Outpatient Encounter ien
191 ; SDINP := inpatient status ('I' or null)
192 ; SDINP := inpatient status ('I' or null)
Note: See TracBrowser for help on using the repository browser.