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

SCRPM21U.m

Go to the documentation of this file. 
  1. SCRPM21U ;ALB/PDR - POSITION REASSIGNMENT UTILITIES ; AUG 1998
  1.  ;;5.3;Scheduling;**148,157**;Aug 13, 1993
  1.  ;
  1. PREVDAY(DAY)    ; GET PREVIOUS DAY
  1.  N X,X1,X2
  1.  S X1=DAY,X2=-1
  1.  D C^%DTC
  1.  Q X
  1.  ;
  1. PCPCASN(FASIEN,SCTP)    ; IS THIS A PRIMARY CARE to PRIMARY CARE ASSIGNMENT?
  1.  ; FASIEN = Pointer to source Position assignment SCPT(404.43)
  1.  ; SCTP   = Destination position pointer to Position DEF file SCTM(404.57)
  1.  N SPPC,DPPC,STPC,SCST
  1.  ; Exclude the case where source = destination team
  1.  ;
  1.  S SCST=$P($G(^SCPT(404.43,FASIEN,0)),U,2) ; pointer to position DEF file
  1.  S SCST=$P($G(^SCTM(404.57,SCST,0)),U,2) ; pointer to team DEF file
  1.  I SCST="" Q 0  ; this is really an error condition
  1.  I SCST=$P($G(^SCTM(404.57,SCTP,0)),U,2) Q 0  ; source and dest teams are the same
  1.  ;
  1.  ; Both source and destination positions are (or will be) primary care.
  1.  ;
  1.  ; test source position is a pc position, and the new position is too
  1.  S SPPC=$P($G(^SCPT(404.43,FASIEN,0)),U,5)>0 ; source position is primary care
  1.  S DPPC=@SCFIELDA@(.05)>0 ; destination position is primary care
  1.  S STPC=$$GETPOSTM(FASIEN)
  1.  S STPC=$P($G(^SCPT(404.42,STPC,0)),U,8)=1 ; source team is primary care
  1.  ; if source pos and dest pos are PC OR source team and dest pos are PC then is a pc to pc assignment
  1.  Q (SPPC&DPPC)!(STPC&DPPC)
  1.  ;
  1. UPDATPOS(POSAIEN,SCERR) ; UPDATE EXISTING POSITION ASSIGNMENT PARAMETERS, AND ENSURE NO FUTURE DISCHARGE
  1.  N SC,SCFLD,ENTFLD
  1.  S ENTFLD=",.06,.07,"
  1.  S SC($J,404.43,(+POSAIEN)_",",.08)=DUZ ; last edited by
  1.  S SC($J,404.43,(+POSAIEN)_",",.09)=SCNOW ; last edit date/time
  1.  S SC($J,404.43,(+POSAIEN)_",",.03)=SCACT ; set new activity date for existing position assgn
  1.  S SC($J,404.43,(+POSAIEN)_",",.04)="" ; ensure no future discharge
  1.  IF $D(SCFIELDA) D
  1.  . S SCFLD=0
  1.  . F  S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD  D
  1.  .. Q:ENTFLD[","_SCFLD_","  ; don't want ENTRY user and ENTRY date time for edit
  1.  .. S SC($J,404.43,(+POSAIEN)_",",SCFLD)=@SCFIELDA@(SCFLD)
  1.  D FILE^DIE("","SC($J)",SCERR) ; update position assignment paramaeters
  1.  I $D(@SCERR) S POSAIEN=0_U_POSAIEN
  1.  Q
  1.  ;
  1. TMEXIST(DFN,SCTM,SCSD,TMAIEN) ;
  1.  ; returns 1 if current/future assignment exists else 0
  1.  ; conserves IEN of the des tm asgn if it exists
  1.  N SCRESULT,SCSDT,SCX,SCTMLIST,SCTMERR
  1.  S (SCRESULT,TMAIEN)=0
  1.  ;
  1.  ;;set date variables for $$tmpt
  1.  S SCSDT("BEGIN")=$G(SCSD,DT)
  1.  S SCSDT("END")=$$FMADD^XLFDT(SCSDT("BEGIN"),36500)
  1.  ;
  1.  ;;look for current asgn first
  1.  S SCX=$$TMPT(1)
  1.  S TMAIEN=$O(SCTMLIST("SCTM",SCTM,0))
  1.  I +TMAIEN S SCRESULT=1 G TMXISTQ
  1.  ;
  1.  ;;look for nearest future legit asgn/dschrg
  1.  S SCX=$$TMPT(0)
  1.  I '+$O(SCTMLIST("SCTM",SCTM,0)) G TMXISTQ
  1.  ;
  1.  F  S TMAIEN=$O(SCTMLIST("SCTM",SCTM,TMAIEN)) Q:'TMAIEN  D
  1.  .S SCX=$O(SCTMLIST("SCTM",SCTM,TMAIEN,0))
  1.  .S SCX=$P(SCTMLIST(SCX),U,4,5)
  1.  .Q:$P(SCX,U,2)<+SCX
  1.  .S SCTMLIST("SCTM","BYDATE",+SCX,TMAIEN)=""
  1.  .Q
  1.  ;
  1.  S SCX=$O(SCTMLIST("SCTM","BYDATE",""))
  1.  I +SCX D
  1.  .S TMAIEN=$O(SCTMLIST("SCTM","BYDATE",SCX,""))
  1.  .S SCRESULT=1
  1.  .Q
  1.  ;
  1. TMXISTQ S TMAIEN=+TMAIEN
  1.  Q +SCRESULT
  1.  ;
  1. TMPT(SCX) ;
  1.  S SCSDT("INCL")=SCX
  1.  K SCTMLIST
  1.  K SCTMERR
  1.  Q $$TMPT^SCAPMC(DFN,"SCSDT","","SCTMLIST","SCTMERR")
  1.  ;
  1. DELPOS(DISIEN,POSAIEN)  ; DELETE a position
  1.  ; DISIEN = SOURCE POSITION TO DISCHARGE
  1.  ; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
  1.  S DIK="^SCPT(404.43,"
  1.  S DA=DISIEN
  1.  ;
  1.  IF DIK]"",$D(@(DIK_DA_",0)")) D ^DIK
  1.  E  S POSAIEN=0_U_POSAIEN
  1.  Q
  1.  ;
  1. DISPOS(DISIEN,POSAIEN)  ; DISCHARGE a position
  1.  ; DISIEN = SOURCE POSITION TO DISCHARGE
  1.  ; POSAIEN = CURRENT DESTINATION POSITION IEN - USED JUST AS AN ERROR INDICATOR HERE
  1.  N DISDAT
  1.  S DISDAT=SCACT  ; init discharge date
  1.  I $P($G(^SCPT(404.43,DISIEN,0)),U,3)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
  1.  S STEC=$$INPTTP^SCAPMC(DFN,DISIEN,DISDAT,SCERR)
  1.  I 'STEC S POSAIEN=0_U_POSAIEN
  1.  Q
  1.  ;
  1. CREATPOS(POSAIEN,TMAIEN)        ; CREATE A POSITION
  1.  N SCIEN
  1.  S POSAIEN="" ; initialize position IEN
  1.  IF $D(SCFIELDA) D
  1.  . S SCFLD=0
  1.  . F  S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD  D
  1.  .. S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
  1.  S SC($J,404.43,"+1,",.01)=TMAIEN
  1.  S SC($J,404.43,"+1,",.02)=SCTP
  1.  S SC($J,404.43,"+1,",.03)=SCACT
  1.  D UPDATE^DIE("","SC($J)","SCIEN",SCERR) ; create new position
  1.  IF $D(@SCERR) K SCIEN
  1.  ELSE  D
  1.  . S POSAIEN=+$G(SCIEN(1))
  1.  . S SCNEWTP=1
  1.  . D AFTERTP^SCMCDD1(POSAIEN)
  1.  Q
  1.  ;
  1. DELTEAM(TMAIEN) ; DELETE A TEAM ASSIGNMENT
  1.  S DIK="^SCPT(404.42,"
  1.  S DA=TMAIEN
  1.  ;
  1.  IF DIK]"",$D(@(DIK_DA_",0)")) D ^DIK
  1.  E  S TMAIEN=0_U_TMAIEN
  1.  Q
  1.  ;
  1. DISTEAM(TMAIEN) ; DISCHARGE A TEAM ASSIGNMENT
  1.  ; TMAIEN = SOURCE TEAM IEN
  1.  N DISDAT,SCPREVDT,SCNODE
  1.  S DISDAT=SCACT  ; init discharge date
  1.  ; discharge for previous day if assignment date prior to today
  1.  I $P($G(^SCPT(404.42,TMAIEN,0)),U,9)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
  1.  N SCTEC
  1.  S SCTEC=$$INPTTM^SCAPMC(DFN,TMAIEN,DISDAT,SCERR) ; Discharge from team Assignments
  1.  I 'SCTEC S TMAIEN=0_U_TMAIEN
  1.  Q
  1.  ;
  1. CREATETM(DFN,SCTMTO,SCACT,TMAIEN)       ; CREATE A TEAM ASSIGNMENT
  1.  N SCTM,SCIEN
  1.  S TMAIEN="+1,"
  1.  ; set team assignment type (i.e PC (1) or non-PC (99))
  1.  S:$D(@SCFIELDA@(.05)) SCTM($J,404.42,TMAIEN,.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
  1.  ; set team user entering
  1.  S:$D(@SCFIELDA@(.06)) SCTM($J,404.42,TMAIEN,.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
  1.  ; set team Date/time entered
  1.  S:$D(@SCFIELDA@(.07)) SCTM($J,404.42,TMAIEN,.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
  1.  ; set team last edited by
  1.  ;S:$D(@SCFIELDA@(.08)) SCTM($J,404.42,TMAIEN,.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
  1.  ; set team date/time last edited
  1.  ;S:$D(@SCFIELDA@(.09)) SCTM($J,404.42,TMAIEN,.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
  1.  S SCTM($J,404.42,TMAIEN,.01)=DFN
  1.  S SCTM($J,404.42,TMAIEN,.02)=SCACT
  1.  S SCTM($J,404.42,TMAIEN,.03)=SCTMTO
  1.  D UPDATE^DIE("","SCTM($J)","SCIEN",SCERR) ; new entry
  1.  IF $D(@SCERR) D
  1.  . K SCIEN
  1.  . S TMAIEN=""
  1.  ELSE  D
  1.  . S TMAIEN=$G(SCIEN(1))  ; new assignment record set up
  1.  . S SCNEWTM=1
  1.  . D AFTERTM^SCMCDD1(TMAIEN)
  1.  Q
  1.  ;
  1. TMACTIV(TMAIEN,PCPOS)   ; CHANGE FUTURE ACTIVE DATE TO CURRENT DATE
  1.  ; PCPOS - flag that indicates whether or not team should be activated as a PC Team
  1.  ;  the team definition is assumed to support PC service at this point
  1.  ; also remove future discharge date if present
  1.  S SC($J,404.42,(+TMAIEN)_",",.14)=SCNOW ; date time last edited
  1.  S SC($J,404.42,(+TMAIEN)_",",.13)=DUZ ; last edited by
  1.  S SC($J,404.42,(+TMAIEN)_",",.02)=SCACT  ; assigned date
  1.  S SC($J,404.42,(+TMAIEN)_",",.09)=""     ; discharge date
  1.  I PCPOS S SC($J,404.42,(+TMAIEN)_",",.08)=1 ;
  1.  D FILE^DIE("","SC($J)",SCERR) ; update TEAM assignment
  1.  I $D(@SCERR) S TMAIEN=0_U_TMAIEN
  1.  Q
  1.  ;
  1. XALLPOS(FASIEN,POSAIEN) ; DISCHARGE ALL POSITIONS FROM THE "from" TEAM
  1.  ; FASIEN = source position assignment IEN
  1.  ; POSAIEN = destination position assignment IEN, used just for error reporting here
  1.  ; this only occurs when the "from" pos and "to" pos are both Primary care,
  1.  ; or the "from" team is PC and the "to" pos is PC.
  1.  ; Rational is that a patient can't have more than one PC team
  1.  ;
  1.  ; use FASIEN to get team assignment, then find all positions for this team assignment,
  1.  ; and discharge them
  1.  N POSASGN,TMASGN,DISDAT,SCX,SCFLAG
  1.  S DISDAT=SCACT  ; init discharge date
  1.  ; discharge for previous day if assignment date prior to today
  1.  S SCX=$$PREVDAY(SCACT)
  1.  I $P($G(^SCPT(404.43,FASIEN,0)),U,3)'>SCX S DISDAT=SCX
  1.  S SCFLAG=0
  1.  S TMASGN=+$P($G(^SCPT(404.43,FASIEN,0)),U,1)
  1.  I TMASGN D 
  1.  .S POSASGN=0
  1.  .F  S POSASGN=$O(^SCPT(404.43,"B",TMASGN,POSASGN)) Q:POSASGN=""  D
  1.  ..S SCX=+$P($G(^SCPT(404.43,POSASGN,0)),U,4)       ;already discharged?
  1.  ..I SCX,SCX<SCACT Q                                ;leave past alone!
  1.  ..K @SCERR
  1.  ..S STEC=$$INPTTP^SCAPMC(DFN,POSASGN,DISDAT,SCERR) ;discharge position
  1.  ..I $D(@SCERR) S SCFLAG=1
  1.  ..Q
  1.  .Q
  1.  I ('TMASGN)!(SCFLAG) S POSAIEN=0_U_POSAIEN
  1.  Q
  1.  ;
  1. GETPOSTM(POSAIEN)       ; RETURN THE TEAM ASSIGNMENT FOR A POSITION
  1.  Q $P($G(^SCPT(404.43,POSAIEN,0)),U,1)
  1.  ;
  1. FUPOSASN(POSAIEN,SCACT) ; IS THIS A FUTURE POSITION ASSIGNMENT?
  1.  Q $P($G(^SCPT(404.43,POSAIEN,0)),U,3)>SCACT
  1.  ;
  1. FUTMASN(TMAIEN,SCACT)   ; IS THIS A FUTURE TEAM ASSIGNMENT?
  1.  Q $P($G(^SCPT(404.42,TMAIEN,0)),U,2)>SCACT
  1.  ;
  1. FUTTMDIS(TMAIEN,SCACT)  ; IS THERE A FUTURE TEAM DISCHARGE?
  1.  Q $P($G(^SCPT(404.42,TMAIEN,0)),U,9)>SCACT
  1.  ;
  1. DPOSPROB(SCPTTPA,SCACT) ; handle disposition of existing destination POSITION
  1.  I $$FUPOSASN(.SCPTTPA,SCACT) D  Q:'SCPTTPA  ; BAIL OUT
  1.  . D DELPOS(SCPTTPA,.SCPTTPA) ; DELETE future non-PC position assignment
  1.  . I 'SCPTTPA D ERROR^SCRPMPSP("Unable to DELETE non-PC position assignment for existing dest team",SCPTTPA,20) Q   ; BAIL OUT
  1.  ELSE  D
  1.  . D DISPOS(SCPTTPA,.SCPTTPA)  ; else if current non-pc assignment discharge it
  1.  . I 'SCPTTPA D ERROR^SCRPMPSP("Unable to discharge non-PC position assignment with existing dest team",SCPTTPA,25) Q   ; BAIL OUT
  1.  Q 'SCPTTPA
  1.  ;
  1. DTMPROB(SCPTTMA,SCACT)  ; HANDLE DISPOSITION OF EXISTING DESTINATION TEAM
  1.  I $$FUTMASN(.SCPTTMA,SCACT) D  Q:'SCPTTMA  ; BAIL OUT
  1.  . D DELTEAM(.SCPTTMA) ; DELETE future dest NON-PC team assign
  1.  . I 'SCPTTMA D ERROR^SCRPMPSP("Unable to DELETE non-PC team assignment for existing dest team",SCPTTMA,30)
  1.  ELSE  D 
  1.  . D DISTEAM(.SCPTTMA)  ; discharge current non-pc team assignment
  1.  . I 'SCPTTMA D ERROR^SCRPMPSP("Unable to discharge non-PC team assignment for existing dest team",SCPTTMA,35) Q   ; BAIL OUT
  1.  Q 'SCPTTMA