Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m
r613 r623 1 SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/022 ;;5.3;Scheduling;**148,177,231,264,436,297,446,524**;AUG 13, 1993;Build 29 3 4 5 UNTP 6 7 8 9 10 11 12 13 S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) ; og/sd/524 14 15 16 17 QTUNTP 18 19 ENRCL 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 QTECL 44 DISCL 45 46 47 48 49 50 51 52 53 QTDCL 54 UNTM 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 QTUNTM 76 77 ALLPOS() 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 QTALL 106 ASTM 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 QTASTM 146 147 148 ASTP 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 QTASTP 191 192 193 NAME(DFN) 194 195 POSITION(SCTP) 196 197 TEAMNM(SCTM) 198 199 CLINIC(SCCL) 200 201 YESNO() 202 203 204 205 206 YESNO1() 207 208 209 210 211 212 YESNO2() 213 214 215 216 217 218 CONFIRM() 219 220 221 222 223 224 SELPOS() 225 226 227 228 229 230 231 DATE(TYPE) 232 233 234 235 236 237 238 239 240 ACTCL(DFN,SCCL) 241 242 243 244 PRACSCR(SC40452) 245 246 247 248 249 250 251 QTPP 252 POSSCR(SCTP) 253 254 255 256 257 WAITYN() 258 259 260 261 262 263 264 265 266 267 SC(DFN) 268 1 SCMCQK1 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002 12:10 PM ; Compiled April 12, 2007 10:03:59 2 ;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77 3 ; 4 ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER 5 UNTP ;unassign patient from pc prac position 6 I '$G(SCTP) W !,"No position defined" Q 7 N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS 8 S OK=0 9 W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]" 10 S SCDISCH=$$DATE("D") 11 G:SCDISCH<1 QTUNTP 12 G:'$$CONFIRM() QTUNTP 13 S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) 14 G:OK'>0 QTUNTP 15 S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) 16 I SCCL D DISCL 17 QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.") 18 Q 19 ENRCL ; 20 N SCRESTA,SCREST,SCCLNM,SCTM 21 N SCCL 22 F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D 23 .Q:$$ACTCL(DFN,SCCL) 24 .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic." 25 .;SCRESTA = Array of pt's teams causing restricted consults 26 .N SCRESTA 27 .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") 28 .I SCREST D 29 ..N SCTM 30 ..S SCCLNM=Y 31 ..W !,?5,"Patient has restricted consults due to team assignment(s):" 32 ..S SCTM=0 33 ..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) 34 .I SCREST&'$G(SCOKCONS) D G QTECL 35 ..W !,?5,"This patient may only be enrolled in clinics via" 36 ..W !,?15,"Edit Clinic Enrollment Data option" 37 .W !,"Do you wish to enroll the patient from this clinic on " 38 .S Y=SCASSDT X ^DD("DD") W Y,"?" 39 .I $$YESNO() D 40 ..W !,"Clinic Enrollment" 41 ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made" 42 ..E W "NOT made" 43 QTECL Q 44 DISCL ; 45 N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D 46 .Q:'$$ACTCL(DFN,SCCL) 47 .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic." 48 .W !,"Do you wish to discharge the patient from this clinic on " 49 .S Y=SCDISCH X ^DD("DD") W Y,"?" 50 .Q:'$$YESNO() 51 .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL 52 .N DFN D ^SDCD 53 QTDCL Q 54 UNTM ; 55 ;assign patient from pc team (and pc position if possible) 56 N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3 57 S OK=0 58 W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team" 59 W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]" 60 S SCDISCH=$$DATE("D") 61 G:SCDISCH<1 QTUNTM 62 G:'$$CONFIRM() QTUNTM 63 IF 'SCTPSTAT D G:OK2'>0 QTUNTM 64 .W !,"PC assignment unassigned." 65 .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) 66 .IF OK2>0 D 67 ..W "made." 68 ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9) 69 ..D:SCCL DISCL 70 S OK3=$$ALLPOS() 71 IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D 72 .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER) 73 ELSE D 74 .W !,"Future/Current Patient-Position Assignment exists" 75 QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.") 76 Q 77 ALLPOS() ;unassign all patient-positions for team 78 ;not stand-alone - needs dfn,sctm 79 ;return 1=No positions left assigned|0=At least 1 position assigned 80 N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2 81 S SCDT1("BEGIN")=SCDISCH+1 82 S SCDT1("END")=3990101 83 S SCDT1("INCL")=0 ;anytime from now to future 84 S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR) 85 S (SCTP,SCCNT)=0 86 W !,"Checking for other position assignments to team..." 87 F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D 88 .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1) 89 .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0)) 90 .S SCNODE=SCPTTPX(SCLOC) 91 .S SCPTTP2(SCTP)="" 92 .W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8) 93 .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D 94 ..W !,?5,"Unassignment date already exists or unassignment after assignment date" 95 ..W !,?15,"- Correct via PCMM GUI" 96 ..S OK=0 97 W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)" 98 G:'OK!('SCCNT) QTALL 99 W !!,"About to unassign the above patient-position assignments" 100 IF '$$CONFIRM S OK=0 G QTALL 101 S SCTP=0 102 F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK 103 .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) 104 .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI" 105 QTALL Q OK 106 ASTM ;assign patient to PC team 107 N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS 108 S OK=0 109 W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team" 110 I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" 111 S DIC="^SCTM(404.51," 112 S DIC(0)="AEMQZ" 113 S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))" 114 ;select from active teams that can be PC Teams 115 D ^DIC 116 G:Y<1 QTASTM 117 S SCTM=+Y 118 ;The following logic to present warning message added per SD*5.3*436 119 I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM 120 .S SCFLAG=0 121 .W !!,"This team is closed to further patient assignments. While you are" 122 .W !,"not currently prevented from assigning this patient, you may want to" 123 .W !,"check before continuing." 124 .Q:'$$YESNO1() ; new function call per SD*5.3*436 125 .Q:'$$CONFIRM() 126 .S SCFLAG=1 W ! 127 S SCASSDT=$$DATE("A") 128 G:SCASSDT<1 QTASTM 129 S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM) 130 S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8) 131 I SCTMCT'<SCTMMAX D G QTASTM:$$WAITYN(),QTASTM:'$$YESNO2() 132 .W !,"This assignment will reach or exceeded the maximum set for this team." 133 .W !,"Currently assigned: "_SCTMCT 134 .W !,"Maximum set for team: "_SCTMMAX 135 I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM 136 S SCTM=+Y 137 ;setup fields 138 S SCTMFLDS(.08)=1 ;primary care assignment 139 S SCTMFLDS(.11)=$G(DUZ,.5) 140 D NOW^%DTC S SCTMFLDS(.12)=% 141 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D 142 .S SCSELECT=$$SELPOS() 143 .D:$L(SCSELECT) ASTP ;prompt for position prompt 144 .S OK=1 145 QTASTM W !,"Team Assignment "_$S(OK:"made",1:"NOT made.") 146 S:$D(SDWLPCMM) SDWLPCMM=OK ; 446 147 Q 148 ASTP ;assign patient to PC practitioner 149 N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS 150 S OK=0 151 W !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment" 152 I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" 153 ;lookup to display only position and [practitioner] 154 IF SCSELECT="PRACT" D 155 .S DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W "" ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]""" 156 .S DIC("A")="POSITION's Current PRACTITIONER: " 157 .S DIC="^SCTM(404.52," 158 .;Must be from team, must be activation,must not have future inactivation 159 .S DIC("S")="I $$PRACSCR^SCMCQK1(Y)" 160 .S D="C" 161 ELSE D 162 .S DIC="^SCTM(404.57," 163 .S D="B" 164 .S DIC("A")="POSITION's Name: " 165 .S DIC("S")="I $$POSSCR^SCMCQK1(Y)" 166 S DIC(0)="AEMQZ" 167 D MIX^DIC1 168 G:Y<1 QTASTP 169 IF SCSELECT="PRACT" D 170 .S SCTP=$P(Y,U,2) 171 ELSE D 172 .S SCTP=$P(Y,U,1) 173 S SCASSDT=$$DATE("A") 174 G:SCASSDT<1 QTASTP 175 S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8) 176 I SCTMCT'<SCTMMAX D G QTASTP:$$WAITYN,QTASTP:'$$YESNO2 177 .W !,"This assignment will reach or exceeded the maximum set for this position." 178 .W !,"Currently assigned: "_SCTMCT 179 .W !,"Maximum set for position: "_SCTMMAX 180 G:'$$CONFIRM() QTASTP 181 ;setup fields 182 S SCTPFLDS(.03)=SCASSDT 183 S SCTPFLDS(.05)=1 ;pc pract role 184 S SCTPFLDS(.06)=$G(DUZ,.5) 185 D NOW^%DTC S SCTPFLDS(.07)=% 186 IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D 187 .S OK=1 188 .S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,0)) 189 .D:SCCL ENRCL 190 QTASTP W !,"Position Assignment "_$S(OK:"made",1:"NOT made.") 191 S:$D(SDWLPCMM) SDWLPCMM=OK ;446 192 Q 193 NAME(DFN) ;return patient name 194 Q $P($G(^DPT(DFN,0)),U,1) 195 POSITION(SCTP) ;return position name 196 Q $P($G(^SCTM(404.57,SCTP,0)),U,1) 197 TEAMNM(SCTM) ;return team name 198 Q $P($G(^SCTM(404.51,SCTM,0)),U,1) 199 CLINIC(SCCL) ;return clinic name 200 Q $P($G(^SC(+SCCL,0)),U,1) 201 YESNO() ; 202 N DIR,X,Y 203 S DIR(0)="Y",DIR("B")="YES" 204 D ^DIR 205 Q Y>0 206 YESNO1() ; added per SD*5.3*436 207 N DIR,X,Y 208 S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?" 209 S DIR("B")="NO" 210 D ^DIR 211 Q Y>0 212 YESNO2() ; 213 N DIR,X,Y 214 S DIR(0)="Y",DIR("B")="NO" 215 S DIR("A")="Do you wish to continue with the assignment (Yes/No)?" 216 D ^DIR 217 Q Y>0 218 CONFIRM() ;confirmation call 219 N DIR,X,Y 220 S DIR("A")="Are you sure (Yes/No)" 221 S DIR(0)="Y" 222 D ^DIR 223 Q +Y=1 224 SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE 225 N DIR,X,Y 226 W !,"Choose way to select PC POSITION Assignment: " 227 S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT" 228 S DIR("B")=1 229 D ^DIR 230 Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT") 231 DATE(TYPE) ;return date type=A or D 232 N DIR,X,Y 233 S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: " 234 S DIR(0)="DA^::EXP" 235 S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1") 236 X ^DD("DD") 237 S DIR("B")=Y 238 D ^DIR 239 Q Y 240 ACTCL(DFN,SCCL) ;is patient enrolled in clinic? 241 N SCXX 242 S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1) 243 Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1) 244 PRACSCR(SC40452) ;screen for for file 404.52 245 N SCP,SCNODE,OK 246 S SCP=$G(^SCTM(404.52,SC40452,0)) 247 S OK=0 248 G:'SCP QTPP 249 S SCNODE=$G(^SCTM(404.57,+SCP,0)) 250 S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0) 251 QTPP Q OK 252 POSSCR(SCTP) ;screen for file 404.57 253 N SCNODE 254 S SCNODE=$G(^SCTM(404.57,SCTP,0)) 255 Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0) 256 Q 257 WAITYN() ; 258 N %,OK,Y 259 I SCTMCT<SCTMMAX Q 0 260 N A,SC S A=$$ONWAIT^SCMCWAIT(DFN) I A W:(+A=3) !,$P(A,";",2) I $S($G(SCTP):A>1,1:1) Q 0 261 N DIR,X,Y 262 S DIR(0)="Y",DIR("B")="NO" 263 S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?" 264 D ^DIR 265 I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List" 266 Q Y>0 267 SC(DFN) ;Is patient 50 to 100% 268 D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49
Note:
See TracChangeset
for help on using the changeset viewer.
