- 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 Feb 19, 2025@00:07:42 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)