SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02 ; 6/13/12 3:38pm
;;5.3;Scheduling;**148,177,231,264,436,297,446,524,535,563**;AUG 13, 1993;Build 45
;
;
; Reference/ICR
; ^DPT(DFN,.35)/10035
;
;
;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",DFN) ;SD*5.3*563 pass DFN
G:SCDISCH<1 QTUNTP
G:'$$CONFIRM() QTUNTP
S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) ; og/sd/524
G:OK'>0 QTUNTP
;comment out following lines in SD*5.3*535 - clinic enrollment no longer used
;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 ; no longer used with SD*5.3*535
Q
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 ; no longer used with SD*5.3*535
Q
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",DFN) ;SD*5.3*563 pass DFN
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 ;commented out in SD*5.3*535
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",DFN) ;SD*5.3*563 Pass DFN
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",DFN) ;SD*5.3*563 Pass DFN
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,DFN) ;type=A(Assignment) or D(Unassignment)
; Returns assignment/unassignment date or "^"
I '$G(DFN) Q -1
N DIR,X,Y,SDFLG,SDY
;SD*5.3*563 SDFLG=0 allow to proceed with date if prior to DOD
F D Q:SDFLG=0
.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 K DIR S SDY=Y
.I $D(DIRUT) K DIRUT,DUOUT,X,Y S SDFLG=0 Q
.D WARNMESS^SCMCQK1(SDY,DFN,.SDFLG)
Q SDY
ACTCL(DFN,SCCL) ;is patient enrolled in clinic? - not called with SD*5.3*535
Q
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
;
WARNMESS(SDY,DFN,SDFLG) ;SD*5.3*563
;If the patient is deceased warns the user to choose assignment
;date prior to the date of death
;SDY - Assignment/Unassignment date
;SDFLG=0 - Allow to proceed with the date if prior to DOD
;
N SDDODPAT,SDDODCF
S SDFLG=1
I $P($G(^DPT(DFN,.35)),U)="" S SDFLG=0 Q
I $P($G(^DPT(DFN,.35)),U)'="" D
.S SDDODPAT=$P($P(^DPT(DFN,.35),U),".")
.S SDDODCF=$$FMTE^XLFDT(SDDODPAT)
.I SDY<SDDODPAT S SDFLG=0 Q
.I SDY>=SDDODPAT D
..W !,"Patient is deceased as of "_SDDODCF_". Please use an earlier Assignment date."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCQK1 11210 printed Nov 22, 2024@17:51:13 Page 2
SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02 ; 6/13/12 3:38pm
+1 ;;5.3;Scheduling;**148,177,231,264,436,297,446,524,535,563**;AUG 13, 1993;Build 45
+2 ;
+3 ;
+4 ; Reference/ICR
+5 ; ^DPT(DFN,.35)/10035
+6 ;
+7 ;
+8 ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
UNTP ;unassign patient from pc prac position
+1 IF '$GET(SCTP)
WRITE !,"No position defined"
QUIT
+2 NEW OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+3 SET OK=0
+4 WRITE !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$PIECE($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
+5 ;SD*5.3*563 pass DFN
SET SCDISCH=$$DATE("D",DFN)
+6 if SCDISCH<1
GOTO QTUNTP
+7 if '$$CONFIRM()
GOTO QTUNTP
+8 ; og/sd/524
SET OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+9 if OK'>0
GOTO QTUNTP
+10 ;comment out following lines in SD*5.3*535 - clinic enrollment no longer used
+11 ;S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
+12 ;I SCCL D DISCL
QTUNTP WRITE !,"Position Unassignment "_$SELECT(OK:"made.",1:"NOT made.")
+1 QUIT
ENRCL ; no longer used with SD*5.3*535
+1 QUIT
+2 NEW SCRESTA,SCREST,SCCLNM,SCTM
+3 NEW SCCL
+4 FOR SCCL=0:0
SET SCCL=$ORDER(^SCTM(404.57,+$GET(SCTP),5,SCCL))
if 'SCCL
QUIT
Begin DoDot:1
+5 if $$ACTCL(DFN,SCCL)
QUIT
+6 WRITE !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic."
+7 ;SCRESTA = Array of pt's teams causing restricted consults
+8 NEW SCRESTA
+9 SET SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
+10 IF SCREST
Begin DoDot:2
+11 NEW SCTM
+12 SET SCCLNM=Y
+13 WRITE !,?5,"Patient has restricted consults due to team assignment(s):"
+14 SET SCTM=0
+15 FOR
SET SCTM=$ORDER(SCRESTA(SCTM))
if 'SCTM
QUIT
WRITE !,?10,SCRESTA(SCTM)
End DoDot:2
+16 IF SCREST&'$GET(SCOKCONS)
Begin DoDot:2
+17 WRITE !,?5,"This patient may only be enrolled in clinics via"
+18 WRITE !,?15,"Edit Clinic Enrollment Data option"
End DoDot:2
GOTO QTECL
+19 WRITE !,"Do you wish to enroll the patient from this clinic on "
+20 SET Y=SCASSDT
XECUTE ^DD("DD")
WRITE Y,"?"
+21 IF $$YESNO()
Begin DoDot:2
+22 WRITE !,"Clinic Enrollment"
+23 IF $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER")
WRITE " made"
+24 IF '$TEST
WRITE "NOT made "
End DoDot:2
End DoDot:1
QTECL QUIT
DISCL ; no longer used with SD*5.3*535
+1 QUIT
+2 NEW SCCL
FOR SCCL=0:0
SET SCCL=$ORDER(^SCTM(404.57,+$GET(SCTP),5,SCCL))
if 'SCCL
QUIT
Begin DoDot:1
+3 if '$$ACTCL(DFN,SCCL)
QUIT
+4 WRITE !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic."
+5 WRITE !,"Do you wish to discharge the patient from this clinic on "
+6 SET Y=SCDISCH
XECUTE ^DD("DD")
WRITE Y,"?"
+7 if '$$YESNO()
QUIT
+8 NEW SDFN,SDCLN
SET SDFN=DFN
SET SDCLN=SCCL
+9 NEW DFN
DO ^SDCD
End DoDot:1
QTDCL QUIT
UNTM ;
+1 ;assign patient from pc team (and pc position if possible)
+2 NEW OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
+3 SET OK=0
+4 WRITE !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
+5 if 'SCTPSTAT
WRITE !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]"
+6 ;SD*5.3*563 pass DFN
SET SCDISCH=$$DATE("D",DFN)
+7 if SCDISCH<1
GOTO QTUNTM
+8 if '$$CONFIRM()
GOTO QTUNTM
+9 IF 'SCTPSTAT
Begin DoDot:1
+10 WRITE !,"PC assignment unassigned."
+11 SET OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+12 IF OK2>0
Begin DoDot:2
+13 WRITE "made."
+14 SET SCCL=$PIECE(^SCTM(404.57,SCTP,0),U,9)
+15 ;D:SCCL DISCL ;commented out in SD*5.3*535
End DoDot:2
End DoDot:1
if OK2'>0
GOTO QTUNTM
+16 SET OK3=$$ALLPOS()
+17 IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH)
Begin DoDot:1
+18 SET OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 WRITE !,"Future/Current Patient-Position Assignment exists"
End DoDot:1
QTUNTM WRITE !,"Team Unassignment "_$SELECT(OK:"made",1:"NOT made.")
+1 QUIT
ALLPOS() ;unassign all patient-positions for team
+1 ;not stand-alone - needs dfn,sctm
+2 ;return 1=No positions left assigned|0=At least 1 position assigned
+3 NEW OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2
+4 SET SCDT1("BEGIN")=SCDISCH+1
+5 SET SCDT1("END")=3990101
+6 ;anytime from now to future
SET SCDT1("INCL")=0
+7 SET OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR)
+8 SET (SCTP,SCCNT)=0
+9 WRITE !,"Checking for other position assignments to team..."
+10 FOR
SET SCTP=$ORDER(SCPTTPX("SCTP",SCTM,SCTP))
if 'SCTP
QUIT
SET SCCNT=SCCNT+1
Begin DoDot:1
+11 SET SCPTTPI=$ORDER(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1)
+12 SET SCLOC=$ORDER(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0))
+13 SET SCNODE=SCPTTPX(SCLOC)
+14 SET SCPTTP2(SCTP)=""
+15 WRITE !,?3,$PIECE(SCNODE,U,2)," ",$PIECE(SCNODE,U,8)
+16 IF $PIECE(SCNODE,U,6)!(SCDISCH'>$PIECE(SCNODE,U,5))
Begin DoDot:2
+17 WRITE !,?5,"Unassignment date already exists or unassignment after assignment date"
+18 WRITE !,?15,"- Correct via PCMM GUI"
+19 SET OK=0
End DoDot:2
End DoDot:1
+20 WRITE !,?5,$SELECT(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)"
+21 if 'OK!('SCCNT)
GOTO QTALL
+22 WRITE !!,"About to unassign the above patient-position assignments"
+23 IF '$$CONFIRM
SET OK=0
GOTO QTALL
+24 SET SCTP=0
+25 FOR
SET SCTP=$ORDER(SCPTTP2(SCTP))
if 'SCTP
QUIT
Begin DoDot:1
+26 SET OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
+27 if 'OK
WRITE !,?10,"Problem with unassignment, correct via PCMM GUI"
End DoDot:1
if 'OK
QUIT
QTALL QUIT OK
ASTM ;assign patient to PC team
+1 NEW DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+2 SET OK=0
+3 WRITE !!,"About to Assign "_$$NAME(DFN)_" to a primary care team"
+4 IF $$SC(DFN)
WRITE !!,"********** This patient is 50 percent or greater service-connected ************"
+5 SET DIC="^SCTM(404.51,"
+6 SET DIC(0)="AEMQZ"
+7 SET DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
+8 ;select from active teams that can be PC Teams
+9 DO ^DIC
+10 if Y<1
GOTO QTASTM
+11 SET SCTM=+Y
+12 ;The following logic to present warning message added per SD*5.3*436
+13 IF $PIECE($GET(^SCTM(404.51,SCTM,0)),U,10)
Begin DoDot:1
+14 SET SCFLAG=0
+15 WRITE !!,"This team is closed to further patient assignments. While you are"
+16 WRITE !,"not currently prevented from assigning this patient, you may want to"
+17 WRITE !,"check before continuing."
+18 ; new function call per SD*5.3*436
if '$$YESNO1()
QUIT
+19 if '$$CONFIRM()
QUIT
+20 SET SCFLAG=1
WRITE !
End DoDot:1
if 'SCFLAG
GOTO QTASTM
+21 ;SD*5.3*563 Pass DFN
SET SCASSDT=$$DATE("A",DFN)
+22 if SCASSDT<1
GOTO QTASTM
+23 SET SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
+24 SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SCTM),"^",8)
+25 IF SCTMCT'<SCTMMAX
Begin DoDot:1
+26 WRITE !,"This assignment will reach or exceeded the maximum set for this team."
+27 WRITE !,"Currently assigned: "_SCTMCT
+28 WRITE !,"Maximum set for team: "_SCTMMAX
End DoDot:1
if $$WAITYN()
GOTO QTASTM
if '$$YESNO2()
GOTO QTASTM
+29 IF SCTMCT<SCTMMAX
IF '$$CONFIRM()
GOTO QTASTM
+30 SET SCTM=+Y
+31 ;setup fields
+32 ;primary care assignment
SET SCTMFLDS(.08)=1
+33 SET SCTMFLDS(.11)=$GET(DUZ,.5)
+34 DO NOW^%DTC
SET SCTMFLDS(.12)=%
+35 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME")
Begin DoDot:1
+36 SET SCSELECT=$$SELPOS()
+37 ;prompt for position prompt
if $LENGTH(SCSELECT)
DO ASTP
+38 SET OK=1
End DoDot:1
QTASTM WRITE !,"Team Assignment "_$SELECT(OK:"made",1:"NOT made.")
+1 ; 446
if $DATA(SDWLPCMM)
SET SDWLPCMM=OK
+2 QUIT
ASTP ;assign patient to PC practitioner
+1 NEW DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
+2 SET OK=0
+3 WRITE !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment"
+4 IF $$SC(DFN)
WRITE !!,"********** This patient is 50 percent or greater service-connected ************"
+5 ;lookup to display only position and [practitioner]
+6 IF SCSELECT="PRACT"
Begin DoDot:1
+7 SET DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W "" ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""
+8 SET DIC("A")="POSITION's Current PRACTITIONER: "
+9 SET DIC="^SCTM(404.52,"
+10 ;Must be from team, must be activation,must not have future inactivation
+11 SET DIC("S")="I $$PRACSCR^SCMCQK1(Y)"
+12 SET D="C"
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 SET DIC="^SCTM(404.57,"
+15 SET D="B"
+16 SET DIC("A")="POSITION's Name: "
+17 SET DIC("S")="I $$POSSCR^SCMCQK1(Y)"
End DoDot:1
+18 SET DIC(0)="AEMQZ"
+19 DO MIX^DIC1
+20 if Y<1
GOTO QTASTP
+21 IF SCSELECT="PRACT"
Begin DoDot:1
+22 SET SCTP=$PIECE(Y,U,2)
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 SET SCTP=$PIECE(Y,U,1)
End DoDot:1
+25 ;SD*5.3*563 Pass DFN
SET SCASSDT=$$DATE("A",DFN)
+26 if SCASSDT<1
GOTO QTASTP
+27 SET SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP)
SET SCTMMAX=+$PIECE($GET(^SCTM(404.57,SCTP,0)),U,8)
+28 IF SCTMCT'<SCTMMAX
Begin DoDot:1
+29 WRITE !,"This assignment will reach or exceeded the maximum set for this position."
+30 WRITE !,"Currently assigned: "_SCTMCT
+31 WRITE !,"Maximum set for position: "_SCTMMAX
End DoDot:1
if $$WAITYN
GOTO QTASTP
if '$$YESNO2
GOTO QTASTP
+32 if '$$CONFIRM()
GOTO QTASTP
+33 ;setup fields
+34 SET SCTPFLDS(.03)=SCASSDT
+35 ;pc pract role
SET SCTPFLDS(.05)=1
+36 SET SCTPFLDS(.06)=$GET(DUZ,.5)
+37 DO NOW^%DTC
SET SCTPFLDS(.07)=%
+38 IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0)
Begin DoDot:1
+39 SET OK=1
+40 SET SCCL=$ORDER(^SCTM(404.57,+$GET(SCTP),5,0))
+41 if SCCL
DO ENRCL
End DoDot:1
QTASTP WRITE !,"Position Assignment "_$SELECT(OK:"made",1:"NOT made.")
+1 ;446
if $DATA(SDWLPCMM)
SET SDWLPCMM=OK
+2 QUIT
NAME(DFN) ;return patient name
+1 QUIT $PIECE($GET(^DPT(DFN,0)),U,1)
POSITION(SCTP) ;return position name
+1 QUIT $PIECE($GET(^SCTM(404.57,SCTP,0)),U,1)
TEAMNM(SCTM) ;return team name
+1 QUIT $PIECE($GET(^SCTM(404.51,SCTM,0)),U,1)
CLINIC(SCCL) ;return clinic name
+1 QUIT $PIECE($GET(^SC(+SCCL,0)),U,1)
YESNO() ;
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
+3 DO ^DIR
+4 QUIT Y>0
YESNO1() ; added per SD*5.3*436
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to assign this patient now (Yes/No)?"
+3 SET DIR("B")="NO"
+4 DO ^DIR
+5 QUIT Y>0
YESNO2() ;
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
+3 SET DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
+4 DO ^DIR
+5 QUIT Y>0
CONFIRM() ;confirmation call
+1 NEW DIR,X,Y
+2 SET DIR("A")="Are you sure (Yes/No)"
+3 SET DIR(0)="Y"
+4 DO ^DIR
+5 QUIT +Y=1
SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE
+1 NEW DIR,X,Y
+2 WRITE !,"Choose way to select PC POSITION Assignment: "
+3 SET DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
+4 SET DIR("B")=1
+5 DO ^DIR
+6 QUIT $SELECT(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
DATE(TYPE,DFN) ;type=A(Assignment) or D(Unassignment)
+1 ; Returns assignment/unassignment date or "^"
+2 IF '$GET(DFN)
QUIT -1
+3 NEW DIR,X,Y,SDFLG,SDY
+4 ;SD*5.3*563 SDFLG=0 allow to proceed with date if prior to DOD
+5 FOR
Begin DoDot:1
+6 SET DIR("A")=$SELECT(TYPE="A":"Assignment",1:"Unassignment")_" date: "
+7 SET DIR(0)="DA^::EXP"
+8 SET Y=$SELECT($DATA(SCDISCH):SCDISCH,$DATA(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
+9 XECUTE ^DD("DD")
+10 SET DIR("B")=Y
+11 DO ^DIR
KILL DIR
SET SDY=Y
+12 IF $DATA(DIRUT)
KILL DIRUT,DUOUT,X,Y
SET SDFLG=0
QUIT
+13 DO WARNMESS^SCMCQK1(SDY,DFN,.SDFLG)
End DoDot:1
if SDFLG=0
QUIT
+14 QUIT SDY
ACTCL(DFN,SCCL) ;is patient enrolled in clinic? - not called with SD*5.3*535
+1 QUIT
+2 NEW SCXX
+3 SET SCXX=$ORDER(^DPT(DFN,"DE","B",SCCL,9999),-1)
+4 QUIT $SELECT('SCXX:0,($PIECE(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1)
PRACSCR(SC40452) ;screen for for file 404.52
+1 NEW SCP,SCNODE,OK
+2 SET SCP=$GET(^SCTM(404.52,SC40452,0))
+3 SET OK=0
+4 if 'SCP
GOTO QTPP
+5 SET SCNODE=$GET(^SCTM(404.57,+SCP,0))
+6 SET OK=$SELECT($PIECE(SCNODE,U,2)'=SCTM:0,'$PIECE(SCNODE,U,4):0,($ORDER(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$PIECE(SCP,U,2)):0,($ORDER(^SCTM(404.52,"AIDT",+SCP,0,-$PIECE(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)
QTPP QUIT OK
POSSCR(SCTP) ;screen for file 404.57
+1 NEW SCNODE
+2 SET SCNODE=$GET(^SCTM(404.57,SCTP,0))
+3 QUIT $SELECT($PIECE(SCNODE,U,2)'=SCTM:0,'$PIECE(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
+4 QUIT
WAITYN() ;
+1 NEW %,OK,Y
+2 IF SCTMCT<SCTMMAX
QUIT 0
+3 NEW A,SC
SET A=$$ONWAIT^SCMCWAIT(DFN)
IF A
if (+A=3)
WRITE !,$PIECE(A,";",2)
IF $SELECT($GET(SCTP):A>1,1:1)
QUIT 0
+4 NEW DIR,X,Y
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
+6 SET DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?"
+7 DO ^DIR
+8 IF Y=1
SET Y=$$WAITS^SCMCWAIT(DFN,SCTM,$GET(SCTP),$GET(SC))
IF Y>0
WRITE !,"Patient Placed on Wait List"
+9 QUIT Y>0
SC(DFN) ;Is patient 50 to 100%
+1 DO ELIG^VADPT
QUIT $PIECE($GET(VAEL(3)),U,2)>49
+2 ;
WARNMESS(SDY,DFN,SDFLG) ;SD*5.3*563
+1 ;If the patient is deceased warns the user to choose assignment
+2 ;date prior to the date of death
+3 ;SDY - Assignment/Unassignment date
+4 ;SDFLG=0 - Allow to proceed with the date if prior to DOD
+5 ;
+6 NEW SDDODPAT,SDDODCF
+7 SET SDFLG=1
+8 IF $PIECE($GET(^DPT(DFN,.35)),U)=""
SET SDFLG=0
QUIT
+9 IF $PIECE($GET(^DPT(DFN,.35)),U)'=""
Begin DoDot:1
+10 SET SDDODPAT=$PIECE($PIECE(^DPT(DFN,.35),U),".")
+11 SET SDDODCF=$$FMTE^XLFDT(SDDODPAT)
+12 IF SDY<SDDODPAT
SET SDFLG=0
QUIT
+13 IF SDY>=SDDODPAT
Begin DoDot:2
+14 WRITE !,"Patient is deceased as of "_SDDODCF_". Please use an earlier Assignment date."
End DoDot:2
End DoDot:1
+15 QUIT
