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

SCRPMTA.m

Go to the documentation of this file. 
  1. SCRPMTA ;ALB/REW/PDR - Team Reassignment APIs:APPTTM ; AUG 1998
  1.  ;;5.3;scheduling;**148,157**;aug 13, 1993
  1.  ; Reassign patient Team, called from RPC ='SC FILE PAT TM REASGN' (PTFILE^SCMRBK - PTFILE^SCMRBK)
  1.  ;
  1.  ;;1.0
  1.  ; MAKE A SINGLE PATIENT TEAM REASSIGNMENT
  1. ACPTTM(DFN,SCTMTO,SCFIELDA,SCACT,FASIEN,SCERR) ;add a patient to a team (pt tmassgn - #404.42)
  1.  ; input:
  1.  ;  DFN     = pointer to PATIENT file (#2)
  1.  ;  SCTMTO  = pointer to TEAM file (#404.51) "TO" Team
  1.  ;  SCFIELDA= array of additional fields to be added for 404.42
  1.  ;  SCACT   = date to activate [default=DT]
  1.  ;  FASIEN  = IEN of source team assignment
  1.  ;  SCERR = array NAME to store error messages.
  1.  ;          [ex. ^TMP("ORXX",$J)]
  1.  ;
  1.  ; Output:
  1.  ;  Returned = ien of 404.42 - 0 if none after^new?^Message
  1.  ;  SCERR() = Array of DIALOG file messages(errors) .
  1.  ;             Foramt:
  1.  ;               Subscript: Sequential # from 1 to n
  1.  ;               Piece     Description
  1.  ;                 1       IEN of DIALOG file
  1.  N SCPTTM,SCESEQ,SCPARM,SCIEN,SC,SCFLD,SCNEWTM,SCDTPAR,SCMESS
  1.  ;
  1.  ;
  1.  I '$$OKDATA D  G APTTMQ ;check/setup variables
  1.  . D ERROR("Failed initial data check","",10)
  1.  ; 
  1.  ; PROCESS REASSIGNMENT
  1.  ; get destination team assignment parameters if already existing assignment
  1.  I '$$GETTMPAR(DFN,SCTMTO,SCACT,.SCERR,.SCDTPAR,.SCPTTM) D  G APTTMQ ; BAIL if error 
  1.  . D ERROR("Unable to get list of team assignments for patient",FASIEN,20)
  1.  ; Make sure this reassignment doesn't set up more than 1 primary care team for PT
  1.  I $$INVALMOV(SCPTTM,FASIEN,SCDTPAR) D  G APTTMQ ; BAIL if error 
  1.  . D ERROR("Patient already has a primary care assignment",FASIEN,30)
  1.  ;
  1.  ; check for currently active destination assignment and discharge if so
  1.  I $$ACTIVDES(SCDTPAR,SCACT) D  G:SCPTTM APTTMQ ; BAIL OUT if discharge unsuccessfull
  1.  . I $$DISTMOK(DFN,SCPTTM,SCACT,DUZ,"Destination") S SCPTTM="" Q  ; going to create a new team
  1.  . D ERROR("Unable to discharge current destination assignment",SCPTTM,40)
  1.  ;
  1.  ; discharge source team
  1.  I '$$DISTMOK(DFN,FASIEN,SCACT,DUZ,"Source") D  G APTTMQ
  1.  . ; error messages setup within call to DISTMOK
  1.  . S SCPTTM=""
  1.  ;
  1.  ; Move the patient to destination team and create destination team if necessary
  1.  I '$$MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCDTPAR,.SCPTTM,DUZ) D  G APTTMQ
  1.  . D ERROR("Unable to move patient to destination team",FASIEN,50)
  1.  ;
  1. APTTMQ ;
  1.  ;B
  1.  Q +$G(SCPTTM)_U_+$G(SCNEWTM)_U_$G(SCMESS)
  1.  ;
  1.  ;-------------------- SUBS -------------------------------
  1.  ;
  1. PTTMACT(DFN,SCTMTO,SCDT,SCERR) ;what is patient/team assignment on a given date-time into the future? Return 404.42 ien or 0
  1.  N SCTMLST,SCOK,SCPTTMDT
  1.  S SCOK=0
  1.  S SCPTTMDT("BEGIN")=SCDT,SCPTTMDT("END")=3990101,SCPTTMDT("INCL")=0
  1.  IF $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR) S:$D(SCTMLST("SCTM",SCTMTO)) SCOK=$O(SCTMLST("SCTM",SCTMTO,0))
  1.  Q SCOK
  1.  ;
  1. OKDATA()        ;setup/check variables
  1.  N SCOK
  1.  S SCOK=1
  1.  D INIT^SCAPMCU1(.SCOK)
  1.  IF '$D(^DPT(DFN,0))!('$D(^SCTM(404.51,SCTMTO,0))) D  S SCOK=0
  1.  . S SCPARM("PATIENT")=DFN
  1.  . S SCPARM("TEAM")=SCTMTO
  1.  . D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
  1.  S:'$G(SCACT) SCACT=DT
  1.  Q SCOK
  1.  ;
  1. DISTMOK(DFN,TMIEN,SCACT,SCDUZ,SD) ; Discharge patient from Team Assignment
  1.  ; DFN = pointer to patient
  1.  ; TMIEN = Ptr to Team Assignment File 404.42 for Team being discharged
  1.  ; SCAT = Discharge Date
  1.  ; SCDUZ = DUZ of user making reassignment
  1.  ; SD = text indicating "source" or "destination" team
  1.  N SC,SCTEC,DISDAT
  1.  ;
  1.  Q:TMIEN="" TMIEN  ; Don't try to update this record if don't get IEN
  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,TMIEN,0)),U,2)'>$$PREVDAY(SCACT) S DISDAT=$$PREVDAY(SCACT)
  1.  ; Discharge Position assignments first, to prevent posibility of orphan positions
  1.  D DISCHPOS(DFN,TMIEN,DISDAT,SCERR,.SCTEC) ; Discharge from any position Assignments on this team
  1.  I SCTEC S SCTEC=$$INPTTM^SCAPMC(DFN,TMIEN,DISDAT,SCERR) ; Discharge from team Assignments
  1.  I 'SCTEC D ERROR("Unable to discharge "_SD_" team",FASIEN,500) Q 0 ; BAIL OUT
  1.  Q SCTEC
  1.  ;
  1. DISCHPOS(DFN,TMASGN,SCAT,SCERR,SCTEC) ;Discharge positition assignments
  1.  ; DFN = ptr to patient
  1.  ; TMASGN = ptr to team assignment
  1.  ; SCAT = discharge date
  1.  N POSASGN,EM,GD,OK
  1.  S (EM,GD)=""
  1.  S OK=1
  1.  S SCTEC=1 ; initialize successfull pos discharge since may not be any pos to discharge
  1.  S POSASGN=0
  1.  F  S POSASGN=$O(^SCPT(404.43,"B",TMASGN,POSASGN)) Q:POSASGN=""  D
  1.  . S SCTEC=$$INPTTP^SCAPMC(DFN,POSASGN,SCAT,SCERR) ; discharge position
  1.  . I SCTEC S GD=GD_POSASGN_","
  1.  . I 'SCTEC D
  1.  .. S EM=EM_POSASGN_","
  1.  .. S OK=0
  1.  I 'OK D
  1.  . I GD'="" D ERROR("able to discharge these source positions: "_GD_" unable to discharge these: "_EM,POSASGN,300) Q
  1.  . D ERROR("unable to discharge any of the team positions: "_EM,POSASGN,400)
  1.  Q
  1.  ;
  1. PREVDAY(DAY) ; GET PREVIOUS DAY
  1.  ; DAY = DATE IN FILEMAN FORMAT
  1.  N X,X1,X2
  1.  S X1=DAY,X2=-1
  1.  D C^%DTC
  1.  Q X
  1.  ;
  1. GETTMPAR(DFN,SCTMTO,SCDT,SCERR,SCTMPAR,SCPTTM) ; RETURN team parameters
  1.  ; SCTMPAR is returned as:
  1.  ;               Piece     Description
  1.  ;                 1       IEN of TEAM file entry
  1.  ;                 2       Name of team
  1.  ;                 3       IEN of file #404.42 (Pt Tm Assignment)
  1.  ;                 4       current effective date
  1.  ;                 5       current inactivate date (if any)
  1.  ;                 6       pointer to 403.47 (purpose)
  1.  ;                 7       Name of Purpose
  1.  ;                 8       Is this the pt's PC Team?
  1.  ;                 9       IEN of PC team assignment - added to record -PDR
  1.  N SCTMLST,SCPTTMDT,PCTM
  1.  S (SCPTTM,SCTMPAR,PCTM)="" ; initialize dest team IEN and dest team parameters
  1.  ; get a list of active or future active teams for this patient
  1.  S SCPTTMDT("BEGIN")=SCDT,SCPTTMDT("END")=3990101,SCPTTMDT("INCL")=0
  1.  I $$TMPT^SCAPMC3(DFN,"SCPTTMDT","","SCTMLST",.SCERR) D
  1.  . S PCTM=$$GETPCTM(.SCTMLST)  ; get the PC team if any for this patient
  1.  . S:$D(SCTMLST("SCTM",SCTMTO)) SCPTTM=$O(SCTMLST("SCTM",SCTMTO,0))
  1.  . I SCPTTM D  ; get the team parameters
  1.  .. S SCN=$O(SCTMLST("SCTM",SCTMTO,SCPTTM,"")) ; ordered list
  1.  .. S SCTMPAR=$G(SCTMLST(SCN)) ; basic team parameters
  1.  S $P(SCTMPAR,U,9)=+PCTM ; add ien of PC team as 9th piece
  1.  Q '$D(@SCERR)
  1.  ;
  1. GETPCTM(TMLIST) ; FIND THE PC TEAM FOR THIS PATIENT
  1.  N SN,PT
  1.  S (PT,SN)=0
  1.  F  S SN=$O(TMLIST(SN)) Q:'SN  D  Q:PT
  1.  . I $P(TMLIST(SN),U,8) S PT=$P(TMLIST(SN),U,3)
  1.  Q PT
  1.  ;
  1. FUASSN(SCDTPAR,SCDT) ; is there a future assignment?
  1.  Q $P(SCTMPAR,U,4)>SCDT
  1.  ;
  1. FUDISCHG(SCTMPAR,SCDT) ;IS THERE A FUTURE DISCHARGE?
  1.  Q $P(SCTMPAR,U,5)>SCDT
  1.  ;
  1. MOVPATOK(DFN,SCACT,SCTMTO,SCFIELDA,SCTMPAR,SCPTTM,SCDUZ) ; DID MOVE GO OK?
  1.  N SCFLD,SCED
  1.  S SCED=0
  1.  I SCPTTM D  ; setup for edit of existing dest assignment record
  1.  . S SCPTTM=SCPTTM_","  ; IENS format
  1.  . I $$FUASSN(SCTMPAR,SCACT) S SCED=1 ; the new assign date wil be entered below
  1.  . I $$FUDISCHG(SCTMPAR,SCACT) D  ; is there a future discharge for the dest team?
  1.  .. S SCED=1
  1.  .. S SC($J,404.42,SCPTTM,.09)="" ; remove discharge date
  1.  . I SCED D  ; editing the existing assignment - setup edit documentation fields
  1.  .. S SC($J,404.42,SCPTTM,.13)=@SCFIELDA@(.11) ; last edited by set to entered by
  1.  .. S SC($J,404.42,SCPTTM,.14)=@SCFIELDA@(.12) ; last edit time set to enter date/time
  1.  .. K @SCFIELDA@(.11) ; dispose of entered by (SCFIELDA array is set in SCMRBK)
  1.  .. K @SCFIELDA@(.12) ; dispose of entry date/time
  1.  ; 
  1.  I '(+SCPTTM) S SCPTTM="+1," ; setup for new team
  1.  ;
  1.  S SCFLD=0 ; add additional fields from workstation if any
  1.  F  S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD  D
  1.  . S SC($J,404.42,SCPTTM,SCFLD)=@SCFIELDA@(SCFLD)
  1.  ; core fields for new team assignment
  1.  S SC($J,404.42,SCPTTM,.01)=DFN
  1.  S SC($J,404.42,SCPTTM,.02)=SCACT
  1.  S SC($J,404.42,SCPTTM,.03)=SCTMTO
  1.  ;
  1.  I 'SCED D UPDATE^DIE("","SC($J)","SCIEN","SCERR") ; new entry
  1.  I SCED D FILE^DIE("","SC($J)","SCERR") ; edit existing entry
  1.  ;
  1.  IF $D(@SCERR) D
  1.  . K SCIEN
  1.  . S SCPTTM=""
  1.  ELSE  D
  1.  . I SCPTTM'="+1," Q  ; BAIL OUT - was edit to existing assignement record
  1.  . S SCPTTM=$G(SCIEN(1))  ; new assignment record set up
  1.  . S SCNEWTM=1
  1.  . D AFTERTM^SCMCDD1(SCPTTM)
  1.  Q '$D(@SCERR)
  1.  ;
  1. INVALMOV(DTMIEN,STMIEN,TMPAR) ; IS THIS A VALID REASSIGNMENT?
  1.  ; can't have a pc team reassignment if patient has an existing PC team assignment
  1.  ; and it is not 
  1.  ; 1: the src team (move from src to dest discharges src, result only 1 pc team) OR 
  1.  ; 2: the destination team (already existing assignment)
  1.  I $$PCASSGN,$$OTHPCTM(DTMIEN,STMIEN,TMPAR) Q 1
  1.  Q 0
  1.  ;
  1. PCASSGN() ; IS THE REASSIGNMENT DESTINATION TO BE PC?
  1.  Q @SCFIELDA@(.08)=1
  1.  ;
  1. OTHPCTM(DTMIEN,STMIEN,TMPAR) ; IS THERE ALREADY PC TEAM ASSIGNMENT?
  1.  I $P(TMPAR,U,9)=0 Q 0  ; no other primary care assignments
  1.  I 'DTMIEN Q $P(TMPAR,U,9)'=STMIEN  ; true if PC team is not source team
  1.  Q $P(TMPAR,U,9)'=DTMIEN  ; true if existing dest team assign is not pc team
  1.  ;
  1. ACTIVDES(SCDTPAR,SCACT) ; IS THE DESTINATION ASSIGNMENT ACTIVE?
  1.  ; SCDTPAR = Destination Team assignment parameter string
  1.  N DISDT,ASNDT
  1.  S DISDT=$P(SCDTPAR,U,5)
  1.  I DISDT="" S DISDT=9999999
  1.  S ASNDT=$P(SCDTPAR,U,4)
  1.  ; ACTIVE if assign date is not in future and 
  1.  ; there is no discharge date, or the discharge date is in the future 
  1.  I (ASNDT'>SCACT)&(DISDT>SCACT) Q 1
  1.  Q 0
  1.  ;
  1. ERROR(TXT,ID,ERN) ; ERROR PROCESSOR
  1.  S SCMESS=TXT_" IEN="_ID_" (ER#="_ERN_")"
  1.  S SCPTTM=0 ; return no assignment ien
  1.  ;S ^TMP("PDR",$J,$H,DFN)=SCMESS
  1.  Q