2009-12-04 00:11:15 -05:00
|
|
|
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
|
|
|
|
|
;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77
|
|
|
|
|
;
|
|
|
|
|
;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
|
|
|
|
|
UNTP ;unassign patient from pc prac position
|
|
|
|
|
I '$G(SCTP) W !,"No position defined" Q
|
|
|
|
|
N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
|
|
|
|
|
S OK=0
|
|
|
|
|
W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
|
|
|
|
|
S SCDISCH=$$DATE("D")
|
|
|
|
|
G:SCDISCH<1 QTUNTP
|
|
|
|
|
G:'$$CONFIRM() QTUNTP
|
|
|
|
|
S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
|
|
|
|
|
G:OK'>0 QTUNTP
|
|
|
|
|
S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
|
|
|
|
|
I SCCL D DISCL
|
|
|
|
|
QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")
|
|
|
|
|
Q
|
|
|
|
|
ENRCL ;
|
|
|
|
|
N SCRESTA,SCREST,SCCLNM,SCTM
|
|
|
|
|
N SCCL
|
|
|
|
|
F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D
|
|
|
|
|
.Q:$$ACTCL(DFN,SCCL)
|
|
|
|
|
.W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic."
|
|
|
|
|
.;SCRESTA = Array of pt's teams causing restricted consults
|
|
|
|
|
.N SCRESTA
|
|
|
|
|
.S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
|
|
|
|
|
.I SCREST D
|
|
|
|
|
..N SCTM
|
|
|
|
|
..S SCCLNM=Y
|
|
|
|
|
..W !,?5,"Patient has restricted consults due to team assignment(s):"
|
|
|
|
|
..S SCTM=0
|
|
|
|
|
..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM)
|
|
|
|
|
.I SCREST&'$G(SCOKCONS) D G QTECL
|
|
|
|
|
..W !,?5,"This patient may only be enrolled in clinics via"
|
|
|
|
|
..W !,?15,"Edit Clinic Enrollment Data option"
|
|
|
|
|
.W !,"Do you wish to enroll the patient from this clinic on "
|
|
|
|
|
.S Y=SCASSDT X ^DD("DD") W Y,"?"
|
|
|
|
|
.I $$YESNO() D
|
|
|
|
|
..W !,"Clinic Enrollment"
|
|
|
|
|
..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made"
|
|
|
|
|
..E W "NOT made"
|
|
|
|
|
QTECL Q
|
|
|
|
|
DISCL ;
|
|
|
|
|
N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D
|
|
|
|
|
.Q:'$$ACTCL(DFN,SCCL)
|
|
|
|
|
.W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic."
|
|
|
|
|
.W !,"Do you wish to discharge the patient from this clinic on "
|
|
|
|
|
.S Y=SCDISCH X ^DD("DD") W Y,"?"
|
|
|
|
|
.Q:'$$YESNO()
|
|
|
|
|
.N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL
|
|
|
|
|
.N DFN D ^SDCD
|
|
|
|
|
QTDCL Q
|
|
|
|
|
UNTM ;
|
|
|
|
|
;assign patient from pc team (and pc position if possible)
|
|
|
|
|
N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
|
|
|
|
|
S OK=0
|
|
|
|
|
W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
|
|
|
|
|
W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]"
|
|
|
|
|
S SCDISCH=$$DATE("D")
|
|
|
|
|
G:SCDISCH<1 QTUNTM
|
|
|
|
|
G:'$$CONFIRM() QTUNTM
|
|
|
|
|
IF 'SCTPSTAT D G:OK2'>0 QTUNTM
|
|
|
|
|
.W !,"PC assignment unassigned."
|
|
|
|
|
.S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
|
|
|
|
|
.IF OK2>0 D
|
|
|
|
|
..W "made."
|
|
|
|
|
..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)
|
|
|
|
|
..D:SCCL DISCL
|
|
|
|
|
S OK3=$$ALLPOS()
|
|
|
|
|
IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D
|
|
|
|
|
.S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
|
|
|
|
|
ELSE D
|
|
|
|
|
.W !,"Future/Current Patient-Position Assignment exists"
|
|
|
|
|
QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.")
|
|
|
|
|
Q
|
|
|
|
|
ALLPOS() ;unassign all patient-positions for team
|
|
|
|
|
;not stand-alone - needs dfn,sctm
|
|
|
|
|
;return 1=No positions left assigned|0=At least 1 position assigned
|
|
|
|
|
N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2
|
|
|
|
|
S SCDT1("BEGIN")=SCDISCH+1
|
|
|
|
|
S SCDT1("END")=3990101
|
|
|
|
|
S SCDT1("INCL")=0 ;anytime from now to future
|
|
|
|
|
S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR)
|
|
|
|
|
S (SCTP,SCCNT)=0
|
|
|
|
|
W !,"Checking for other position assignments to team..."
|
|
|
|
|
F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D
|
|
|
|
|
.S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1)
|
|
|
|
|
.S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0))
|
|
|
|
|
.S SCNODE=SCPTTPX(SCLOC)
|
|
|
|
|
.S SCPTTP2(SCTP)=""
|
|
|
|
|
.W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8)
|
|
|
|
|
.IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D
|
|
|
|
|
..W !,?5,"Unassignment date already exists or unassignment after assignment date"
|
|
|
|
|
..W !,?15,"- Correct via PCMM GUI"
|
|
|
|
|
..S OK=0
|
|
|
|
|
W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)"
|
|
|
|
|
G:'OK!('SCCNT) QTALL
|
|
|
|
|
W !!,"About to unassign the above patient-position assignments"
|
|
|
|
|
IF '$$CONFIRM S OK=0 G QTALL
|
|
|
|
|
S SCTP=0
|
|
|
|
|
F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK
|
|
|
|
|
.S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
|
|
|
|
|
.W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI"
|
|
|
|
|
QTALL Q OK
|
|
|
|
|
ASTM ;assign patient to PC team
|
|
|
|
|
N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
|
|
|
|
|
S OK=0
|
|
|
|
|
W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team"
|
|
|
|
|
I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
|
|
|
|
|
S DIC="^SCTM(404.51,"
|
|
|
|
|
S DIC(0)="AEMQZ"
|
|
|
|
|
S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
|
|
|
|
|
;select from active teams that can be PC Teams
|
|
|
|
|
D ^DIC
|
|
|
|
|
G:Y<1 QTASTM
|
|
|
|
|
S SCTM=+Y
|
|
|
|
|
;The following logic to present warning message added per SD*5.3*436
|
|
|
|
|
I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM
|
|
|
|
|
.S SCFLAG=0
|
|
|
|
|
.W !!,"This team is closed to further patient assignments. While you are"
|
|
|
|
|
.W !,"not currently prevented from assigning this patient, you may want to"
|
|
|
|
|
.W !,"check before continuing."
|
|
|
|
|
.Q:'$$YESNO1() ; new function call per SD*5.3*436
|
|
|
|
|
.Q:'$$CONFIRM()
|
|
|
|
|
.S SCFLAG=1 W !
|
|
|
|
|
S SCASSDT=$$DATE("A")
|
|
|
|
|
G:SCASSDT<1 QTASTM
|
|
|
|
|
S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
|
|
|
|
|
S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)
|
|
|
|
|
I SCTMCT'<SCTMMAX D G QTASTM:$$WAITYN(),QTASTM:'$$YESNO2()
|
|
|
|
|
.W !,"This assignment will reach or exceeded the maximum set for this team."
|
|
|
|
|
.W !,"Currently assigned: "_SCTMCT
|
|
|
|
|
.W !,"Maximum set for team: "_SCTMMAX
|
|
|
|
|
I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM
|
|
|
|
|
S SCTM=+Y
|
|
|
|
|
;setup fields
|
|
|
|
|
S SCTMFLDS(.08)=1 ;primary care assignment
|
|
|
|
|
S SCTMFLDS(.11)=$G(DUZ,.5)
|
|
|
|
|
D NOW^%DTC S SCTMFLDS(.12)=%
|
|
|
|
|
IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D
|
|
|
|
|
.S SCSELECT=$$SELPOS()
|
|
|
|
|
.D:$L(SCSELECT) ASTP ;prompt for position prompt
|
|
|
|
|
.S OK=1
|
|
|
|
|
QTASTM W !,"Team Assignment "_$S(OK:"made",1:"NOT made.")
|
|
|
|
|
S:$D(SDWLPCMM) SDWLPCMM=OK ; 446
|
|
|
|
|
Q
|
|
|
|
|
ASTP ;assign patient to PC practitioner
|
|
|
|
|
N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
|
|
|
|
|
S OK=0
|
|
|
|
|
W !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment"
|
|
|
|
|
I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
|
|
|
|
|
;lookup to display only position and [practitioner]
|
|
|
|
|
IF SCSELECT="PRACT" D
|
|
|
|
|
.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),""]"""
|
|
|
|
|
.S DIC("A")="POSITION's Current PRACTITIONER: "
|
|
|
|
|
.S DIC="^SCTM(404.52,"
|
|
|
|
|
.;Must be from team, must be activation,must not have future inactivation
|
|
|
|
|
.S DIC("S")="I $$PRACSCR^SCMCQK1(Y)"
|
|
|
|
|
.S D="C"
|
|
|
|
|
ELSE D
|
|
|
|
|
.S DIC="^SCTM(404.57,"
|
|
|
|
|
.S D="B"
|
|
|
|
|
.S DIC("A")="POSITION's Name: "
|
|
|
|
|
.S DIC("S")="I $$POSSCR^SCMCQK1(Y)"
|
|
|
|
|
S DIC(0)="AEMQZ"
|
|
|
|
|
D MIX^DIC1
|
|
|
|
|
G:Y<1 QTASTP
|
|
|
|
|
IF SCSELECT="PRACT" D
|
|
|
|
|
.S SCTP=$P(Y,U,2)
|
|
|
|
|
ELSE D
|
|
|
|
|
.S SCTP=$P(Y,U,1)
|
|
|
|
|
S SCASSDT=$$DATE("A")
|
|
|
|
|
G:SCASSDT<1 QTASTP
|
|
|
|
|
S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8)
|
|
|
|
|
I SCTMCT'<SCTMMAX D G QTASTP:$$WAITYN,QTASTP:'$$YESNO2
|
|
|
|
|
.W !,"This assignment will reach or exceeded the maximum set for this position."
|
|
|
|
|
.W !,"Currently assigned: "_SCTMCT
|
|
|
|
|
.W !,"Maximum set for position: "_SCTMMAX
|
|
|
|
|
G:'$$CONFIRM() QTASTP
|
|
|
|
|
;setup fields
|
|
|
|
|
S SCTPFLDS(.03)=SCASSDT
|
|
|
|
|
S SCTPFLDS(.05)=1 ;pc pract role
|
|
|
|
|
S SCTPFLDS(.06)=$G(DUZ,.5)
|
|
|
|
|
D NOW^%DTC S SCTPFLDS(.07)=%
|
|
|
|
|
IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D
|
|
|
|
|
.S OK=1
|
|
|
|
|
.S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,0))
|
|
|
|
|
.D:SCCL ENRCL
|
|
|
|
|
QTASTP W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")
|
|
|
|
|
S:$D(SDWLPCMM) SDWLPCMM=OK ;446
|
|
|
|
|
Q
|
|
|
|
|
NAME(DFN) ;return patient name
|
|
|
|
|
Q $P($G(^DPT(DFN,0)),U,1)
|
|
|
|
|
POSITION(SCTP) ;return position name
|
|
|
|
|
Q $P($G(^SCTM(404.57,SCTP,0)),U,1)
|
|
|
|
|
TEAMNM(SCTM) ;return team name
|
|
|
|
|
Q $P($G(^SCTM(404.51,SCTM,0)),U,1)
|
|
|
|
|
CLINIC(SCCL) ;return clinic name
|
|
|
|
|
Q $P($G(^SC(+SCCL,0)),U,1)
|
|
|
|
|
YESNO() ;
|
|
|
|
|
N DIR,X,Y
|
|
|
|
|
S DIR(0)="Y",DIR("B")="YES"
|
|
|
|
|
D ^DIR
|
|
|
|
|
Q Y>0
|
|
|
|
|
YESNO1() ; added per SD*5.3*436
|
|
|
|
|
N DIR,X,Y
|
|
|
|
|
S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?"
|
|
|
|
|
S DIR("B")="NO"
|
|
|
|
|
D ^DIR
|
|
|
|
|
Q Y>0
|
|
|
|
|
YESNO2() ;
|
|
|
|
|
N DIR,X,Y
|
|
|
|
|
S DIR(0)="Y",DIR("B")="NO"
|
|
|
|
|
S DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
|
|
|
|
|
D ^DIR
|
|
|
|
|
Q Y>0
|
|
|
|
|
CONFIRM() ;confirmation call
|
|
|
|
|
N DIR,X,Y
|
|
|
|
|
S DIR("A")="Are you sure (Yes/No)"
|
|
|
|
|
S DIR(0)="Y"
|
|
|
|
|
D ^DIR
|
|
|
|
|
Q +Y=1
|
|
|
|
|
SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE
|
|
|
|
|
N DIR,X,Y
|
|
|
|
|
W !,"Choose way to select PC POSITION Assignment: "
|
|
|
|
|
S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
|
|
|
|
|
S DIR("B")=1
|
|
|
|
|
D ^DIR
|
|
|
|
|
Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
|
|
|
|
|
DATE(TYPE) ;return date type=A or D
|
|
|
|
|
N DIR,X,Y
|
|
|
|
|
S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: "
|
|
|
|
|
S DIR(0)="DA^::EXP"
|
|
|
|
|
S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
|
|
|
|
|
X ^DD("DD")
|
|
|
|
|
S DIR("B")=Y
|
|
|
|
|
D ^DIR
|
|
|
|
|
Q Y
|
|
|
|
|
ACTCL(DFN,SCCL) ;is patient enrolled in clinic?
|
|
|
|
|
N SCXX
|
|
|
|
|
S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1)
|
|
|
|
|
Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1)
|
|
|
|
|
PRACSCR(SC40452) ;screen for for file 404.52
|
|
|
|
|
N SCP,SCNODE,OK
|
|
|
|
|
S SCP=$G(^SCTM(404.52,SC40452,0))
|
|
|
|
|
S OK=0
|
|
|
|
|
G:'SCP QTPP
|
|
|
|
|
S SCNODE=$G(^SCTM(404.57,+SCP,0))
|
|
|
|
|
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)
|
|
|
|
|
QTPP Q OK
|
|
|
|
|
POSSCR(SCTP) ;screen for file 404.57
|
|
|
|
|
N SCNODE
|
|
|
|
|
S SCNODE=$G(^SCTM(404.57,SCTP,0))
|
|
|
|
|
Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
|
|
|
|
|
Q
|
|
|
|
|
WAITYN() ;
|
|
|
|
|
N %,OK,Y
|
|
|
|
|
I SCTMCT<SCTMMAX Q 0
|
|
|
|
|
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
|
|
|
|
|
N DIR,X,Y
|
|
|
|
|
S DIR(0)="Y",DIR("B")="NO"
|
|
|
|
|
S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?"
|
|
|
|
|
D ^DIR
|
|
|
|
|
I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List"
|
|
|
|
|
Q Y>0
|
|
|
|
|
SC(DFN) ;Is patient 50 to 100%
|
|
|
|
|
D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49
|
