Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCMCQK

SCMCQK.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. ; Reference/ICR
  1. ; ^DPT(DFN,.35)/10035
  1. ;
  1. ;
  1. EN ; - main call
  1. W !,"Primary Care Team/PC Assignment/Unassignment",!
  1. W !,?6,"Prior to using this option, PCMM's Graphical User Interface (GUI)"
  1. W !,?6,"must be used to:"
  1. W !,?10,"1) Setup active primary care and non-primary care team(s)"
  1. W !,?10,"2) Setup active PC and non-primary care Practitioner position(s)"
  1. W !,?10,"3) Setup any necessary preceptor/preceptee relationships"
  1. W !,?10,"4) Assign practitioner to position(s)"
  1. W !!?6,"A patient can only have one PC team and one"
  1. W !?6,"PC Position assignment on a given day. The patient must be"
  1. W !?6,"assigned to a position's team to be assigned to the position."
  1. W !!?6,"Note: You must use the PCMM GUI if the patient was:"
  1. W !?10,"o unassigned from PC assignment today or in the future"
  1. W !?10,"o assigned to a future PC assignment."
  1. N DFN
  1. F S DFN=$$PATIENT() Q:DFN<0 D PAT
  1. Q
  1. ;
  1. PAT ;process patient
  1. Q:'$G(DFN)
  1. N SCTPSTAT,SCTMSTAT,SCSTAT,SCTM,SCTP,SDDOD,SDDODRES,SDUSRANS
  1. ;If patient is deceased prompt user to continue SD*5.3*563
  1. I $P($G(^DPT(DFN,.35)),U)'="" D I SDUSRANS'="Y" Q
  1. .S SDDOD=$P(^DPT(DFN,.35),U)
  1. .S SDDODRES=$$FMTE^XLFDT(SDDOD)
  1. .W !!,"This Patient is deceased as of "_SDDODRES_". Would you like to continue?"
  1. .S DIR(0)="SA^Y:YES;N:NO"
  1. .S DIR("B")="NO"
  1. .S DIR("?")="[Y]ES=continue with current patient, [N]o=select a new patient or quit"
  1. .W ! D ^DIR K DIR S SDUSRANS=Y
  1. .I $D(DIRUT) K DIRUT,DUOUT,DTOUT,X,Y Q
  1. ;End SD*5.3*563
  1. W !,"Checking PC Team and Position Status...",!
  1. ;display PC info, check if patient has a current PC team
  1. D PCMM^SCRPU4(DFN,DT)
  1. D DSPL^SCMCQK2
  1. N DATA
  1. S DATA=$$IU^SCMCTSK1(DFN)
  1. I $E(DATA)=1 I $D(^XUSEC("SC PCMM SETUP",+$G(DUZ))) D
  1. .;If patient is deceased do not allow reactivation SD*5.3*598
  1. .I $P($G(^DPT(DFN,.35)),U)'="" Q
  1. .;If the team or position are not currently active do not allow reactivation SD*5.3*598
  1. .I '$$ACTHISTB^SCAPMCU2(404.58,$P(DATA,"~",3))!('$$ACTHISTB^SCAPMCU2(404.59,$P(DATA,"~",5))) Q
  1. .W !,"This patient was inactivated from "_$P(DATA,"~",2)_" TEAM"
  1. .W !,$P(DATA,"~",4)_" Position"
  1. .W !,"Do you wish to reactivate" S %=2 D YN^DICN
  1. .I %=1 D FILEIN^SCMCTSK3(.DATA,+$P(DATA,"~",6))
  1. W !,"Do you want to make a primary care assignment/unassignment" S %=1 D YN^DICN Q:%<0
  1. I %=2 G NPC^SCMCQK2
  1. ;below functions return status^message^pointer
  1. S SCTMSTAT=$$YSPTTMPC^SCMCTMU2(DFN,DT) ;ok to assign new PC team?
  1. S SCTPSTAT=$$YSPTTPPC^SCMCTPU2(DFN,DT,1) ;ok to assign new PC prac?
  1. ;what is current/future PC assignment status?
  1. S SCSTAT=$S((SCTMSTAT&SCTPSTAT):"NONE",('SCTMSTAT&SCTPSTAT):"TEAM",('SCTMSTAT&'SCTPSTAT):"BOTH",1:"ERROR") ;error if PC pract w/o PC team assignment
  1. W:SCSTAT="NONE" !,"No current PC Team/PC Practitioner Assignments"
  1. IF $S(SCTMSTAT:0,(SCTMSTAT["future"):1,1:0) W !,$P(SCTMSTAT,U,2) S SCSTAT="FUTURE"
  1. IF $S(SCTPSTAT:0,(SCTPSTAT["future"):1,1:0) W !,$P(SCTPSTAT,U,2) S SCSTAT="FUTURE"
  1. S SCTM=$P(SCTMSTAT,U,3)
  1. S SCTP=$P(SCTPSTAT,U,3)
  1. D @SCSTAT
  1. D BREAK
  1. Q
  1. ;
  1. BREAK ;
  1. N DIR,X,Y
  1. S DIR(0)="EA",DIR("A",1)="",DIR("A")="Press enter to continue."
  1. D ^DIR
  1. Q
  1. ;
  1. NONE ;
  1. N SCASSDT
  1. D ASTM^SCMCQK1
  1. Q
  1. TEAM ;
  1. N DIR,X,Y,SCDISCH,SCASSDT,SCSELECT
  1. S DIR(0)="SO^1:POSITION ASSIGNMENT - BY PRACTITIONER NAME;2:POSITION ASSIGNMENT - BY POSITION NAME;3:TEAM UNASSIGNMENT"
  1. D ^DIR
  1. IF $P(Y,U,1)=1!($P(Y,U,1)=2) D
  1. .S SCSELECT=$S($P(Y,U,1)=1:"PRACT",1:"POSIT")
  1. .D ASTP^SCMCQK1
  1. ELSE D:$P(Y,U,1)=3 UNTM^SCMCQK1
  1. Q
  1. ;
  1. BOTH ;
  1. N DIR,X,Y,SCDISCH
  1. S DIR(0)="SO^1:PC ASSIGNMENT UNASSIGNMENT;2:TEAM UNASSIGNMENT"
  1. D ^DIR
  1. IF $P(Y,U,1)=1 D
  1. .D UNTP^SCMCQK1
  1. ELSE D:$P(Y,U,1)=2 UNTM^SCMCQK1
  1. Q
  1. ;
  1. FUTURE ;
  1. W !,"This patient has future assignments for Primary Care"
  1. W !,"Team and/or Practitioner"
  1. W !!!,"You must use PCMM's Graphical User Interface to change"
  1. Q
  1. ;
  1. ERROR ;
  1. W !,"This patient has NO active Primary Care Team, but does have"
  1. W !,"an active PC Position Assignment"
  1. W !!!,"You must use PCMM's Graphical User Interface to correct"
  1. Q
  1. ;
  1. PATIENT() ;Return Patient DFN or -1
  1. ;
  1. N DIC,X,Y
  1. W !!!
  1. S DIC=2
  1. S DIC(0)="AEMQZ"
  1. D ^DIC
  1. Q $S($D(DTOUT):-1,$D(DUOUT):-1,(Y<0):-1,1:+Y)