- 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 Jan 18, 2025@03:42:07 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 ;