SCMCQK ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 5/17/12 1:39pm
;;5.3;Scheduling;**148,177,297,563,598**;AUG 13, 1993;Build 12
;
;
; Reference/ICR
; ^DPT(DFN,.35)/10035
;
;
EN ; - main call
W !,"Primary Care Team/PC Assignment/Unassignment",!
W !,?6,"Prior to using this option, PCMM's Graphical User Interface (GUI)"
W !,?6,"must be used to:"
W !,?10,"1) Setup active primary care and non-primary care team(s)"
W !,?10,"2) Setup active PC and non-primary care Practitioner position(s)"
W !,?10,"3) Setup any necessary preceptor/preceptee relationships"
W !,?10,"4) Assign practitioner to position(s)"
W !!?6,"A patient can only have one PC team and one"
W !?6,"PC Position assignment on a given day. The patient must be"
W !?6,"assigned to a position's team to be assigned to the position."
W !!?6,"Note: You must use the PCMM GUI if the patient was:"
W !?10,"o unassigned from PC assignment today or in the future"
W !?10,"o assigned to a future PC assignment."
N DFN
F S DFN=$$PATIENT() Q:DFN<0 D PAT
Q
;
PAT ;process patient
Q:'$G(DFN)
N SCTPSTAT,SCTMSTAT,SCSTAT,SCTM,SCTP,SDDOD,SDDODRES,SDUSRANS
;If patient is deceased prompt user to continue SD*5.3*563
I $P($G(^DPT(DFN,.35)),U)'="" D I SDUSRANS'="Y" Q
.S SDDOD=$P(^DPT(DFN,.35),U)
.S SDDODRES=$$FMTE^XLFDT(SDDOD)
.W !!,"This Patient is deceased as of "_SDDODRES_". Would you like to continue?"
.S DIR(0)="SA^Y:YES;N:NO"
.S DIR("B")="NO"
.S DIR("?")="[Y]ES=continue with current patient, [N]o=select a new patient or quit"
.W ! D ^DIR K DIR S SDUSRANS=Y
.I $D(DIRUT) K DIRUT,DUOUT,DTOUT,X,Y Q
;End SD*5.3*563
W !,"Checking PC Team and Position Status...",!
;display PC info, check if patient has a current PC team
D PCMM^SCRPU4(DFN,DT)
D DSPL^SCMCQK2
N DATA
S DATA=$$IU^SCMCTSK1(DFN)
I $E(DATA)=1 I $D(^XUSEC("SC PCMM SETUP",+$G(DUZ))) D
.;If patient is deceased do not allow reactivation SD*5.3*598
.I $P($G(^DPT(DFN,.35)),U)'="" Q
.;If the team or position are not currently active do not allow reactivation SD*5.3*598
.I '$$ACTHISTB^SCAPMCU2(404.58,$P(DATA,"~",3))!('$$ACTHISTB^SCAPMCU2(404.59,$P(DATA,"~",5))) Q
.W !,"This patient was inactivated from "_$P(DATA,"~",2)_" TEAM"
.W !,$P(DATA,"~",4)_" Position"
.W !,"Do you wish to reactivate" S %=2 D YN^DICN
.I %=1 D FILEIN^SCMCTSK3(.DATA,+$P(DATA,"~",6))
W !,"Do you want to make a primary care assignment/unassignment" S %=1 D YN^DICN Q:%<0
I %=2 G NPC^SCMCQK2
;below functions return status^message^pointer
S SCTMSTAT=$$YSPTTMPC^SCMCTMU2(DFN,DT) ;ok to assign new PC team?
S SCTPSTAT=$$YSPTTPPC^SCMCTPU2(DFN,DT,1) ;ok to assign new PC prac?
;what is current/future PC assignment status?
S SCSTAT=$S((SCTMSTAT&SCTPSTAT):"NONE",('SCTMSTAT&SCTPSTAT):"TEAM",('SCTMSTAT&'SCTPSTAT):"BOTH",1:"ERROR") ;error if PC pract w/o PC team assignment
W:SCSTAT="NONE" !,"No current PC Team/PC Practitioner Assignments"
IF $S(SCTMSTAT:0,(SCTMSTAT["future"):1,1:0) W !,$P(SCTMSTAT,U,2) S SCSTAT="FUTURE"
IF $S(SCTPSTAT:0,(SCTPSTAT["future"):1,1:0) W !,$P(SCTPSTAT,U,2) S SCSTAT="FUTURE"
S SCTM=$P(SCTMSTAT,U,3)
S SCTP=$P(SCTPSTAT,U,3)
D @SCSTAT
D BREAK
Q
;
BREAK ;
N DIR,X,Y
S DIR(0)="EA",DIR("A",1)="",DIR("A")="Press enter to continue."
D ^DIR
Q
;
NONE ;
N SCASSDT
D ASTM^SCMCQK1
Q
TEAM ;
N DIR,X,Y,SCDISCH,SCASSDT,SCSELECT
S DIR(0)="SO^1:POSITION ASSIGNMENT - BY PRACTITIONER NAME;2:POSITION ASSIGNMENT - BY POSITION NAME;3:TEAM UNASSIGNMENT"
D ^DIR
IF $P(Y,U,1)=1!($P(Y,U,1)=2) D
.S SCSELECT=$S($P(Y,U,1)=1:"PRACT",1:"POSIT")
.D ASTP^SCMCQK1
ELSE D:$P(Y,U,1)=3 UNTM^SCMCQK1
Q
;
BOTH ;
N DIR,X,Y,SCDISCH
S DIR(0)="SO^1:PC ASSIGNMENT UNASSIGNMENT;2:TEAM UNASSIGNMENT"
D ^DIR
IF $P(Y,U,1)=1 D
.D UNTP^SCMCQK1
ELSE D:$P(Y,U,1)=2 UNTM^SCMCQK1
Q
;
FUTURE ;
W !,"This patient has future assignments for Primary Care"
W !,"Team and/or Practitioner"
W !!!,"You must use PCMM's Graphical User Interface to change"
Q
;
ERROR ;
W !,"This patient has NO active Primary Care Team, but does have"
W !,"an active PC Position Assignment"
W !!!,"You must use PCMM's Graphical User Interface to correct"
Q
;
PATIENT() ;Return Patient DFN or -1
;
N DIC,X,Y
W !!!
S DIC=2
S DIC(0)="AEMQZ"
D ^DIC
Q $S($D(DTOUT):-1,$D(DUOUT):-1,(Y<0):-1,1:+Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCQK 4375 printed Sep 23, 2025@20:17:36 Page 2
SCMCQK ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 5/17/12 1:39pm
+1 ;;5.3;Scheduling;**148,177,297,563,598**;AUG 13, 1993;Build 12
+2 ;
+3 ;
+4 ; Reference/ICR
+5 ; ^DPT(DFN,.35)/10035
+6 ;
+7 ;
EN ; - main call
+1 WRITE !,"Primary Care Team/PC Assignment/Unassignment",!
+2 WRITE !,?6,"Prior to using this option, PCMM's Graphical User Interface (GUI)"
+3 WRITE !,?6,"must be used to:"
+4 WRITE !,?10,"1) Setup active primary care and non-primary care team(s)"
+5 WRITE !,?10,"2) Setup active PC and non-primary care Practitioner position(s)"
+6 WRITE !,?10,"3) Setup any necessary preceptor/preceptee relationships"
+7 WRITE !,?10,"4) Assign practitioner to position(s)"
+8 WRITE !!?6,"A patient can only have one PC team and one"
+9 WRITE !?6,"PC Position assignment on a given day. The patient must be"
+10 WRITE !?6,"assigned to a position's team to be assigned to the position."
+11 WRITE !!?6,"Note: You must use the PCMM GUI if the patient was:"
+12 WRITE !?10,"o unassigned from PC assignment today or in the future"
+13 WRITE !?10,"o assigned to a future PC assignment."
+14 NEW DFN
+15 FOR
SET DFN=$$PATIENT()
if DFN<0
QUIT
DO PAT
+16 QUIT
+17 ;
PAT ;process patient
+1 if '$GET(DFN)
QUIT
+2 NEW SCTPSTAT,SCTMSTAT,SCSTAT,SCTM,SCTP,SDDOD,SDDODRES,SDUSRANS
+3 ;If patient is deceased prompt user to continue SD*5.3*563
+4 IF $PIECE($GET(^DPT(DFN,.35)),U)'=""
Begin DoDot:1
+5 SET SDDOD=$PIECE(^DPT(DFN,.35),U)
+6 SET SDDODRES=$$FMTE^XLFDT(SDDOD)
+7 WRITE !!,"This Patient is deceased as of "_SDDODRES_". Would you like to continue?"
+8 SET DIR(0)="SA^Y:YES;N:NO"
+9 SET DIR("B")="NO"
+10 SET DIR("?")="[Y]ES=continue with current patient, [N]o=select a new patient or quit"
+11 WRITE !
DO ^DIR
KILL DIR
SET SDUSRANS=Y
+12 IF $DATA(DIRUT)
KILL DIRUT,DUOUT,DTOUT,X,Y
QUIT
End DoDot:1
IF SDUSRANS'="Y"
QUIT
+13 ;End SD*5.3*563
+14 WRITE !,"Checking PC Team and Position Status...",!
+15 ;display PC info, check if patient has a current PC team
+16 DO PCMM^SCRPU4(DFN,DT)
+17 DO DSPL^SCMCQK2
+18 NEW DATA
+19 SET DATA=$$IU^SCMCTSK1(DFN)
+20 IF $EXTRACT(DATA)=1
IF $DATA(^XUSEC("SC PCMM SETUP",+$GET(DUZ)))
Begin DoDot:1
+21 ;If patient is deceased do not allow reactivation SD*5.3*598
+22 IF $PIECE($GET(^DPT(DFN,.35)),U)'=""
QUIT
+23 ;If the team or position are not currently active do not allow reactivation SD*5.3*598
+24 IF '$$ACTHISTB^SCAPMCU2(404.58,$PIECE(DATA,"~",3))!('$$ACTHISTB^SCAPMCU2(404.59,$PIECE(DATA,"~",5)))
QUIT
+25 WRITE !,"This patient was inactivated from "_$PIECE(DATA,"~",2)_" TEAM"
+26 WRITE !,$PIECE(DATA,"~",4)_" Position"
+27 WRITE !,"Do you wish to reactivate"
SET %=2
DO YN^DICN
+28 IF %=1
DO FILEIN^SCMCTSK3(.DATA,+$PIECE(DATA,"~",6))
End DoDot:1
+29 WRITE !,"Do you want to make a primary care assignment/unassignment"
SET %=1
DO YN^DICN
if %<0
QUIT
+30 IF %=2
GOTO NPC^SCMCQK2
+31 ;below functions return status^message^pointer
+32 ;ok to assign new PC team?
SET SCTMSTAT=$$YSPTTMPC^SCMCTMU2(DFN,DT)
+33 ;ok to assign new PC prac?
SET SCTPSTAT=$$YSPTTPPC^SCMCTPU2(DFN,DT,1)
+34 ;what is current/future PC assignment status?
+35 ;error if PC pract w/o PC team assignment
SET SCSTAT=$SELECT((SCTMSTAT&SCTPSTAT):"NONE",('SCTMSTAT&SCTPSTAT):"TEAM",('SCTMSTAT&'SCTPSTAT):"BOTH",1:"ERROR")
+36 if SCSTAT="NONE"
WRITE !,"No current PC Team/PC Practitioner Assignments"
+37 IF $SELECT(SCTMSTAT:0,(SCTMSTAT["future"):1,1:0)
WRITE !,$PIECE(SCTMSTAT,U,2)
SET SCSTAT="FUTURE"
+38 IF $SELECT(SCTPSTAT:0,(SCTPSTAT["future"):1,1:0)
WRITE !,$PIECE(SCTPSTAT,U,2)
SET SCSTAT="FUTURE"
+39 SET SCTM=$PIECE(SCTMSTAT,U,3)
+40 SET SCTP=$PIECE(SCTPSTAT,U,3)
+41 DO @SCSTAT
+42 DO BREAK
+43 QUIT
+44 ;
BREAK ;
+1 NEW DIR,X,Y
+2 SET DIR(0)="EA"
SET DIR("A",1)=""
SET DIR("A")="Press enter to continue."
+3 DO ^DIR
+4 QUIT
+5 ;
NONE ;
+1 NEW SCASSDT
+2 DO ASTM^SCMCQK1
+3 QUIT
TEAM ;
+1 NEW DIR,X,Y,SCDISCH,SCASSDT,SCSELECT
+2 SET DIR(0)="SO^1:POSITION ASSIGNMENT - BY PRACTITIONER NAME;2:POSITION ASSIGNMENT - BY POSITION NAME;3:TEAM UNASSIGNMENT"
+3 DO ^DIR
+4 IF $PIECE(Y,U,1)=1!($PIECE(Y,U,1)=2)
Begin DoDot:1
+5 SET SCSELECT=$SELECT($PIECE(Y,U,1)=1:"PRACT",1:"POSIT")
+6 DO ASTP^SCMCQK1
End DoDot:1
+7 IF '$TEST
if $PIECE(Y,U,1)=3
DO UNTM^SCMCQK1
+8 QUIT
+9 ;
BOTH ;
+1 NEW DIR,X,Y,SCDISCH
+2 SET DIR(0)="SO^1:PC ASSIGNMENT UNASSIGNMENT;2:TEAM UNASSIGNMENT"
+3 DO ^DIR
+4 IF $PIECE(Y,U,1)=1
Begin DoDot:1
+5 DO UNTP^SCMCQK1
End DoDot:1
+6 IF '$TEST
if $PIECE(Y,U,1)=2
DO UNTM^SCMCQK1
+7 QUIT
+8 ;
FUTURE ;
+1 WRITE !,"This patient has future assignments for Primary Care"
+2 WRITE !,"Team and/or Practitioner"
+3 WRITE !!!,"You must use PCMM's Graphical User Interface to change"
+4 QUIT
+5 ;
ERROR ;
+1 WRITE !,"This patient has NO active Primary Care Team, but does have"
+2 WRITE !,"an active PC Position Assignment"
+3 WRITE !!!,"You must use PCMM's Graphical User Interface to correct"
+4 QUIT
+5 ;
PATIENT() ;Return Patient DFN or -1
+1 ;
+2 NEW DIC,X,Y
+3 WRITE !!!
+4 SET DIC=2
+5 SET DIC(0)="AEMQZ"
+6 DO ^DIC
+7 QUIT $SELECT($DATA(DTOUT):-1,$DATA(DUOUT):-1,(Y<0):-1,1:+Y)
