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

SCMCMU.m

Go to the documentation of this file.
  1. SCMCMU ;ALB/MJK - PCMM Mass Team/Position Unassignment Utility ; 10 Jul 98
  1. ;;5.3;Scheduling;**148**;AUG 13, 1993
  1. ;
  1. EN ; -- entry point for mass unassignment (mu)
  1. ;
  1. N SCMUTYPE,SCTEAM,SCPOS,SCABORT,SCDATE,SCDIS,SCTPDIS
  1. ;
  1. S (SCTEAM,SCPOS,SCDIS)=0
  1. S SCABORT=-1
  1. ;
  1. ; -- get type of md (team or position)
  1. S SCMUTYPE=$$TYPE()
  1. IF SCMUTYPE=SCABORT G ENQ
  1. ;
  1. ; -- get effective date
  1. S SCDATE=$$DATE()
  1. IF SCDATE=SCABORT G ENQ
  1. ;
  1. ; -- get team
  1. S SCTEAM=$$TEAM(SCDATE)
  1. IF SCTEAM=SCABORT G ENQ
  1. ;
  1. ; -- get position if position md
  1. IF SCMUTYPE="T" D IF SCDIS=SCABORT G ENQ
  1. . S SCDIS=$$TMDIS(SCTEAM,SCDATE,.SCTPDIS)
  1. ;
  1. ; -- get position if position md
  1. IF SCMUTYPE="P" D IF SCPOS=SCABORT!(SCDIS=SCABORT) G ENQ
  1. . S SCPOS=$$POS(SCTEAM,SCDATE)
  1. . S SCDIS=$$TPDIS(SCPOS,.SCTPDIS)
  1. ;
  1. ; -- call lm routine
  1. D EN^SCMCMU1(SCTEAM,SCPOS,.SCTPDIS,SCMUTYPE,SCDATE)
  1. ;
  1. ENQ Q
  1. ;
  1. TYPE() ; -- get type of mu
  1. N DIR,DIRUT,Y
  1. S DIR(0)="SABM^T:Team;P:Position"
  1. S DIR("A")="Select Type of Mass Unassignment: "
  1. S DIR("B")="Team"
  1. D ^DIR
  1. Q $S($D(DIRUT):-1,1:Y)
  1. ;
  1. DATE() ; -- get effective date
  1. N DIR,DIRUT,Y
  1. S DIR(0)="DA^::EX"
  1. S DIR("A")="Effective Date: "
  1. S DIR("B")="T-1"
  1. D ^DIR
  1. Q $S($D(DIRUT):-1,1:Y)
  1. ;
  1. TEAM(SCDATE) ; -- get team
  1. N DIC,Y,SCDTE
  1. D DATE^SCMCMU1(SCDATE,.SCDTE)
  1. S DIC("S")="IF +$$ACTHIST^SCAPMCU2(404.58,+Y,SCDTE)=1"
  1. S DIC="^SCTM(404.51,",DIC(0)="AEQM"
  1. D ^DIC
  1. Q +Y
  1. ;
  1. POS(SCTEAM,SCDATE) ; -- get position for team
  1. N DIC,Y,SCDTE,SCPOS,SCPOSI,I
  1. D DATE^SCMCMU1(SCDATE,.SCDTE)
  1. S SCPOS=$NA(^TMP("SCMU",$J,"POSITION"))
  1. K @SCPOS
  1. IF '$$TPTM^SCAPMC24(SCTEAM,SCDTE,"","",SCPOS) S Y=-1 G POSQ
  1. S I=0 F S I=$O(@SCPOS@(I)) Q:'I S SCPOSI(+@SCPOS@(I))=""
  1. S DIC="^SCTM(404.57,"
  1. S DIC(0)="AEQM"
  1. S DIC("S")="IF $D(SCPOSI(+Y)),$P(^(0),U,2)=+SCTEAM,+$$ACTHIST^SCAPMCU2(404.59,+Y,SCDTE)=1"
  1. D ^DIC
  1. POSQ K @SCPOS
  1. Q +Y
  1. ;
  1. TMDIS(SCTEAM,SCDATE,SCTPDIS) ; -- discharge patient from clinics
  1. N DIR,Y,SCDTE,SCPOS,SCPOSI,I,SCOK,SCCL,SCCLNM,SCPOS0,SCTEAMNM
  1. S SCOK=1
  1. D DATE^SCMCMU1(SCDATE,.SCDTE)
  1. W !!,">>> Checking to see if any team positions are associated with clinics..."
  1. S SCPOS=$NA(^TMP("SCMU",$J,"POSITION"))
  1. K @SCPOS
  1. IF '$$TPTM^SCAPMC24(SCTEAM,SCDTE,"","",SCPOS) S Y=-1 G TMDISQ
  1. S I=0 F S I=$O(@SCPOS@(I)) Q:'I S SCPOSI(+@SCPOS@(I))=""
  1. K @SCPOS
  1. S SCPOS=0
  1. F S SCPOS=$O(SCPOSI(SCPOS)) Q:'SCPOS D Q:SCOK=SCABORT
  1. . S SCPOS0=$G(^SCTM(404.57,+SCPOS,0))
  1. . S SCCL=+$P(SCPOS0,U,9)
  1. . IF 'SCCL Q
  1. . S SCCLNM=$P($G(^SC(SCCL,0)),U)
  1. . S SCTEAMNM=$P($G(^SCTM(404.51,SCTEAM,0),"Unknown"),U)
  1. . S DIR(0)="YA"
  1. . S DIR("A",1)="----------------------------------------------------------------------------"
  1. . S DIR("A",2)=" Team : "_SCTEAMNM
  1. . S DIR("A",3)=" Position : "_$P(SCPOS0,U)
  1. . S DIR("A",4)=" Associated Clinic: "_SCCLNM
  1. . S DIR("A",5)=" "
  1. . S DIR("A")=">>> Do you want to discharge patients from this clinic? (Yes/No) "
  1. . D ^DIR
  1. . IF $D(DIRUT) S SCOK=SCABORT Q
  1. . IF Y=1 S SCTPDIS(SCPOS)=1
  1. . Q
  1. TMDISQ Q SCOK
  1. ;
  1. TPDIS(SCPOS,SCTPDIS) ; -- discharge patient from clinic
  1. N SCPOS0,SCCL,SCCL0,DIR,DIRUT,Y,SCOK
  1. S SCOK=1
  1. S SCPOS0=$G(^SCTM(404.57,+SCPOS,0))
  1. S SCCL=+$P(SCPOS0,U,9)
  1. IF 'SCCL S Y=0 G TPDISQ
  1. S SCCLNM=$P($G(^SC(SCCL,0)),U)
  1. S DIR(0)="YA"
  1. S DIR("A",1)=" "
  1. S DIR("A")="Also discharge patients from the '"_SCCLNM_"' clinic? (Yes/No) "
  1. D ^DIR
  1. IF $D(DIRUT) S SCOK=SCABORT
  1. IF Y=1 S SCTPDIS(+SCPOS)=1
  1. TPDISQ Q SCOK
  1. ;