SCMCMU ;ALB/MJK - PCMM Mass Team/Position Unassignment Utility ; 10 Jul 98
;;5.3;Scheduling;**148**;AUG 13, 1993
;
EN ; -- entry point for mass unassignment (mu)
;
N SCMUTYPE,SCTEAM,SCPOS,SCABORT,SCDATE,SCDIS,SCTPDIS
;
S (SCTEAM,SCPOS,SCDIS)=0
S SCABORT=-1
;
; -- get type of md (team or position)
S SCMUTYPE=$$TYPE()
IF SCMUTYPE=SCABORT G ENQ
;
; -- get effective date
S SCDATE=$$DATE()
IF SCDATE=SCABORT G ENQ
;
; -- get team
S SCTEAM=$$TEAM(SCDATE)
IF SCTEAM=SCABORT G ENQ
;
; -- get position if position md
IF SCMUTYPE="T" D IF SCDIS=SCABORT G ENQ
. S SCDIS=$$TMDIS(SCTEAM,SCDATE,.SCTPDIS)
;
; -- get position if position md
IF SCMUTYPE="P" D IF SCPOS=SCABORT!(SCDIS=SCABORT) G ENQ
. S SCPOS=$$POS(SCTEAM,SCDATE)
. S SCDIS=$$TPDIS(SCPOS,.SCTPDIS)
;
; -- call lm routine
D EN^SCMCMU1(SCTEAM,SCPOS,.SCTPDIS,SCMUTYPE,SCDATE)
;
ENQ Q
;
TYPE() ; -- get type of mu
N DIR,DIRUT,Y
S DIR(0)="SABM^T:Team;P:Position"
S DIR("A")="Select Type of Mass Unassignment: "
S DIR("B")="Team"
D ^DIR
Q $S($D(DIRUT):-1,1:Y)
;
DATE() ; -- get effective date
N DIR,DIRUT,Y
S DIR(0)="DA^::EX"
S DIR("A")="Effective Date: "
S DIR("B")="T-1"
D ^DIR
Q $S($D(DIRUT):-1,1:Y)
;
TEAM(SCDATE) ; -- get team
N DIC,Y,SCDTE
D DATE^SCMCMU1(SCDATE,.SCDTE)
S DIC("S")="IF +$$ACTHIST^SCAPMCU2(404.58,+Y,SCDTE)=1"
S DIC="^SCTM(404.51,",DIC(0)="AEQM"
D ^DIC
Q +Y
;
POS(SCTEAM,SCDATE) ; -- get position for team
N DIC,Y,SCDTE,SCPOS,SCPOSI,I
D DATE^SCMCMU1(SCDATE,.SCDTE)
S SCPOS=$NA(^TMP("SCMU",$J,"POSITION"))
K @SCPOS
IF '$$TPTM^SCAPMC24(SCTEAM,SCDTE,"","",SCPOS) S Y=-1 G POSQ
S I=0 F S I=$O(@SCPOS@(I)) Q:'I S SCPOSI(+@SCPOS@(I))=""
S DIC="^SCTM(404.57,"
S DIC(0)="AEQM"
S DIC("S")="IF $D(SCPOSI(+Y)),$P(^(0),U,2)=+SCTEAM,+$$ACTHIST^SCAPMCU2(404.59,+Y,SCDTE)=1"
D ^DIC
POSQ K @SCPOS
Q +Y
;
TMDIS(SCTEAM,SCDATE,SCTPDIS) ; -- discharge patient from clinics
N DIR,Y,SCDTE,SCPOS,SCPOSI,I,SCOK,SCCL,SCCLNM,SCPOS0,SCTEAMNM
S SCOK=1
D DATE^SCMCMU1(SCDATE,.SCDTE)
W !!,">>> Checking to see if any team positions are associated with clinics..."
S SCPOS=$NA(^TMP("SCMU",$J,"POSITION"))
K @SCPOS
IF '$$TPTM^SCAPMC24(SCTEAM,SCDTE,"","",SCPOS) S Y=-1 G TMDISQ
S I=0 F S I=$O(@SCPOS@(I)) Q:'I S SCPOSI(+@SCPOS@(I))=""
K @SCPOS
S SCPOS=0
F S SCPOS=$O(SCPOSI(SCPOS)) Q:'SCPOS D Q:SCOK=SCABORT
. S SCPOS0=$G(^SCTM(404.57,+SCPOS,0))
. S SCCL=+$P(SCPOS0,U,9)
. IF 'SCCL Q
. S SCCLNM=$P($G(^SC(SCCL,0)),U)
. S SCTEAMNM=$P($G(^SCTM(404.51,SCTEAM,0),"Unknown"),U)
. S DIR(0)="YA"
. S DIR("A",1)="----------------------------------------------------------------------------"
. S DIR("A",2)=" Team : "_SCTEAMNM
. S DIR("A",3)=" Position : "_$P(SCPOS0,U)
. S DIR("A",4)=" Associated Clinic: "_SCCLNM
. S DIR("A",5)=" "
. S DIR("A")=">>> Do you want to discharge patients from this clinic? (Yes/No) "
. D ^DIR
. IF $D(DIRUT) S SCOK=SCABORT Q
. IF Y=1 S SCTPDIS(SCPOS)=1
. Q
TMDISQ Q SCOK
;
TPDIS(SCPOS,SCTPDIS) ; -- discharge patient from clinic
N SCPOS0,SCCL,SCCL0,DIR,DIRUT,Y,SCOK
S SCOK=1
S SCPOS0=$G(^SCTM(404.57,+SCPOS,0))
S SCCL=+$P(SCPOS0,U,9)
IF 'SCCL S Y=0 G TPDISQ
S SCCLNM=$P($G(^SC(SCCL,0)),U)
S DIR(0)="YA"
S DIR("A",1)=" "
S DIR("A")="Also discharge patients from the '"_SCCLNM_"' clinic? (Yes/No) "
D ^DIR
IF $D(DIRUT) S SCOK=SCABORT
IF Y=1 S SCTPDIS(+SCPOS)=1
TPDISQ Q SCOK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMU 3523 printed Dec 13, 2024@02:40:58 Page 2
SCMCMU ;ALB/MJK - PCMM Mass Team/Position Unassignment Utility ; 10 Jul 98
+1 ;;5.3;Scheduling;**148**;AUG 13, 1993
+2 ;
EN ; -- entry point for mass unassignment (mu)
+1 ;
+2 NEW SCMUTYPE,SCTEAM,SCPOS,SCABORT,SCDATE,SCDIS,SCTPDIS
+3 ;
+4 SET (SCTEAM,SCPOS,SCDIS)=0
+5 SET SCABORT=-1
+6 ;
+7 ; -- get type of md (team or position)
+8 SET SCMUTYPE=$$TYPE()
+9 IF SCMUTYPE=SCABORT
GOTO ENQ
+10 ;
+11 ; -- get effective date
+12 SET SCDATE=$$DATE()
+13 IF SCDATE=SCABORT
GOTO ENQ
+14 ;
+15 ; -- get team
+16 SET SCTEAM=$$TEAM(SCDATE)
+17 IF SCTEAM=SCABORT
GOTO ENQ
+18 ;
+19 ; -- get position if position md
+20 IF SCMUTYPE="T"
Begin DoDot:1
+21 SET SCDIS=$$TMDIS(SCTEAM,SCDATE,.SCTPDIS)
End DoDot:1
IF SCDIS=SCABORT
GOTO ENQ
+22 ;
+23 ; -- get position if position md
+24 IF SCMUTYPE="P"
Begin DoDot:1
+25 SET SCPOS=$$POS(SCTEAM,SCDATE)
+26 SET SCDIS=$$TPDIS(SCPOS,.SCTPDIS)
End DoDot:1
IF SCPOS=SCABORT!(SCDIS=SCABORT)
GOTO ENQ
+27 ;
+28 ; -- call lm routine
+29 DO EN^SCMCMU1(SCTEAM,SCPOS,.SCTPDIS,SCMUTYPE,SCDATE)
+30 ;
ENQ QUIT
+1 ;
TYPE() ; -- get type of mu
+1 NEW DIR,DIRUT,Y
+2 SET DIR(0)="SABM^T:Team;P:Position"
+3 SET DIR("A")="Select Type of Mass Unassignment: "
+4 SET DIR("B")="Team"
+5 DO ^DIR
+6 QUIT $SELECT($DATA(DIRUT):-1,1:Y)
+7 ;
DATE() ; -- get effective date
+1 NEW DIR,DIRUT,Y
+2 SET DIR(0)="DA^::EX"
+3 SET DIR("A")="Effective Date: "
+4 SET DIR("B")="T-1"
+5 DO ^DIR
+6 QUIT $SELECT($DATA(DIRUT):-1,1:Y)
+7 ;
TEAM(SCDATE) ; -- get team
+1 NEW DIC,Y,SCDTE
+2 DO DATE^SCMCMU1(SCDATE,.SCDTE)
+3 SET DIC("S")="IF +$$ACTHIST^SCAPMCU2(404.58,+Y,SCDTE)=1"
+4 SET DIC="^SCTM(404.51,"
SET DIC(0)="AEQM"
+5 DO ^DIC
+6 QUIT +Y
+7 ;
POS(SCTEAM,SCDATE) ; -- get position for team
+1 NEW DIC,Y,SCDTE,SCPOS,SCPOSI,I
+2 DO DATE^SCMCMU1(SCDATE,.SCDTE)
+3 SET SCPOS=$NAME(^TMP("SCMU",$JOB,"POSITION"))
+4 KILL @SCPOS
+5 IF '$$TPTM^SCAPMC24(SCTEAM,SCDTE,"","",SCPOS)
SET Y=-1
GOTO POSQ
+6 SET I=0
FOR
SET I=$ORDER(@SCPOS@(I))
if 'I
QUIT
SET SCPOSI(+@SCPOS@(I))=""
+7 SET DIC="^SCTM(404.57,"
+8 SET DIC(0)="AEQM"
+9 SET DIC("S")="IF $D(SCPOSI(+Y)),$P(^(0),U,2)=+SCTEAM,+$$ACTHIST^SCAPMCU2(404.59,+Y,SCDTE)=1"
+10 DO ^DIC
POSQ KILL @SCPOS
+1 QUIT +Y
+2 ;
TMDIS(SCTEAM,SCDATE,SCTPDIS) ; -- discharge patient from clinics
+1 NEW DIR,Y,SCDTE,SCPOS,SCPOSI,I,SCOK,SCCL,SCCLNM,SCPOS0,SCTEAMNM
+2 SET SCOK=1
+3 DO DATE^SCMCMU1(SCDATE,.SCDTE)
+4 WRITE !!,">>> Checking to see if any team positions are associated with clinics..."
+5 SET SCPOS=$NAME(^TMP("SCMU",$JOB,"POSITION"))
+6 KILL @SCPOS
+7 IF '$$TPTM^SCAPMC24(SCTEAM,SCDTE,"","",SCPOS)
SET Y=-1
GOTO TMDISQ
+8 SET I=0
FOR
SET I=$ORDER(@SCPOS@(I))
if 'I
QUIT
SET SCPOSI(+@SCPOS@(I))=""
+9 KILL @SCPOS
+10 SET SCPOS=0
+11 FOR
SET SCPOS=$ORDER(SCPOSI(SCPOS))
if 'SCPOS
QUIT
Begin DoDot:1
+12 SET SCPOS0=$GET(^SCTM(404.57,+SCPOS,0))
+13 SET SCCL=+$PIECE(SCPOS0,U,9)
+14 IF 'SCCL
QUIT
+15 SET SCCLNM=$PIECE($GET(^SC(SCCL,0)),U)
+16 SET SCTEAMNM=$PIECE($GET(^SCTM(404.51,SCTEAM,0),"Unknown"),U)
+17 SET DIR(0)="YA"
+18 SET DIR("A",1)="----------------------------------------------------------------------------"
+19 SET DIR("A",2)=" Team : "_SCTEAMNM
+20 SET DIR("A",3)=" Position : "_$PIECE(SCPOS0,U)
+21 SET DIR("A",4)=" Associated Clinic: "_SCCLNM
+22 SET DIR("A",5)=" "
+23 SET DIR("A")=">>> Do you want to discharge patients from this clinic? (Yes/No) "
+24 DO ^DIR
+25 IF $DATA(DIRUT)
SET SCOK=SCABORT
QUIT
+26 IF Y=1
SET SCTPDIS(SCPOS)=1
+27 QUIT
End DoDot:1
if SCOK=SCABORT
QUIT
TMDISQ QUIT SCOK
+1 ;
TPDIS(SCPOS,SCTPDIS) ; -- discharge patient from clinic
+1 NEW SCPOS0,SCCL,SCCL0,DIR,DIRUT,Y,SCOK
+2 SET SCOK=1
+3 SET SCPOS0=$GET(^SCTM(404.57,+SCPOS,0))
+4 SET SCCL=+$PIECE(SCPOS0,U,9)
+5 IF 'SCCL
SET Y=0
GOTO TPDISQ
+6 SET SCCLNM=$PIECE($GET(^SC(SCCL,0)),U)
+7 SET DIR(0)="YA"
+8 SET DIR("A",1)=" "
+9 SET DIR("A")="Also discharge patients from the '"_SCCLNM_"' clinic? (Yes/No) "
+10 DO ^DIR
+11 IF $DATA(DIRUT)
SET SCOK=SCABORT
+12 IF Y=1
SET SCTPDIS(+SCPOS)=1
TPDISQ QUIT SCOK
+1 ;
