| 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
|
|---|
