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

SCRPMPSP.m

Go to the documentation of this file. 
  1. SCRPMPSP        ;ALB/PDR - Team APIs:ACPTTP ; AUG 1998
  1.  ;;5.3;Scheduling;**148,157,169,177**;AUG 13, 1993
  1.  ;
  1. ACPTTP(DFN,SCTP,SCFIELDA,SCACT,FASIEN,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
  1.  ; input:
  1.  ;  DFN     = pointer to PATIENT file (#2)
  1.  ;  SCTP    = pointer to TEAM POSTION file (#404.57) (DESTINATION POSITION)
  1.  ;  SCFIELDA= array of extra field entries - scfielda('fld#')=value for 404.43
  1.  ;  SCACT   = date to activate [default=DT]
  1.  ;  FASIEN  = "FROM" position assignment IEN
  1.  ;  SCERR = array NAME to store error messages.
  1.  ;          [ex. ^TMP("ORXX",$J)]
  1.  ;  SCYESTM = Should team assignment be made, if none active now?[1=YES]
  1.  ;  SCMAINA= array of extra field entries for 404.42
  1.  ;
  1.  ; Output:
  1.  ;  Returned = ien of 404.43^new?^404.42 ien (new entries only)^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 SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCST,PATH
  1.  N SCPTTPA,SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
  1.  N SCLOCK,SCXLOCK,SCX
  1.  ;
  1.  ;
  1.  I '$$OKDATA D ERROR(1,FASIEN,5) G APTTPQ
  1.  ;
  1.  I '$D(^XTMP("SCMC POS REASGN")) D
  1.  . S ^XTMP("SCMC POS REASGN",0)=DT_U_DT_U_"POS REASGN PROCESS LOCK"
  1.  . Q
  1.  ;
  1.  S SCXLOCK=0
  1.  S SCLOCK="^XTMP(""SCMC POS REASGN"",DFN)"
  1.  I $D(@SCLOCK) D ERROR(10,FASIEN,7) G APTTPQ
  1.  S @SCLOCK=""
  1.  S SCXLOCK=1
  1.  H 1
  1.  ;
  1.         ;
  1.  D INITVARS
  1.  I '$$GETPLST D ERROR(2,FASIEN,10) G APTTPQ
  1.  ;
  1.  ;bp/cmf 177 new begin
  1.  S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
  1.  I SCX<1 D ERROR($P(SCX,U,2),FASIEN,11) G APTTPQ
  1.  ;bp/cmf 177 new end
  1.  ;
  1.  ; Business rule processing
  1.  ;
  1.  ; case 1
  1.  I $$POSEXIST(.SCTM,SCTP,.SCPTTPA,.SCPTTMA) D  D SETP(1) G APTTPQ
  1.  . ; destin pos asgn exists
  1.  . I '$$PCPCASN^SCRPM21U(FASIEN,SCTP) D  D SETP(1.1) Q
  1.  .. ; not PC to PC pos reasgn
  1.  .. ;
  1.  .. ; update pos asgn
  1.  .. D UPDATPOS^SCRPM21U(.SCPTTPA,SCERR)
  1.  .. I 'SCPTTPA D ERROR(3,SCPTTPA,12) Q
  1.  .. ;
  1.  .. ; update tm asgn
  1.  .. I $$FUTMASN^SCRPM21U(SCPTTMA,SCACT)!$$FUTTMDIS^SCRPM21U(.SCPTTMA,SCACT) D  Q:'SCPTTMA
  1.  ... D TMACTIV^SCRPM21U(.SCPTTMA,$$PCPOS)
  1.  ... I 'SCPTTMA D ERROR(4,SCPTTMA,20)
  1.  ... Q
  1.  .. ;
  1.  .. ; dschrg source pos
  1.  .. D DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
  1.  .. I 'SCPTTPA D ERROR(5,SCPTTPA,30)
  1.  .. Q
  1.  . ;
  1.  . ;  PC to PC pos reasgn
  1.  . N SCFLAG
  1.  . S SCFLAG=0
  1.  . N SCY
  1.  . S SCY=0
  1.  . F  S SCY=$O(SCAPTTPO("SCTP",SCTM,SCTP,SCY)) Q:'SCY!(SCFLAG)  D
  1.  .. S SCPTTPA=SCY
  1.  .. S SCPTTMA=$$GETPOSTM^SCRPM21U(SCPTTPA)
  1.  .. I '$D(^SCPT(404.43,SCPTTPA)) Q
  1.  .. S SCFLAG=$$DPOSPROB^SCRPM21U(SCPTTPA,SCACT)
  1.  .. I SCFLAG Q
  1.  .. I '$D(^SCPT(404.42,SCPTTMA)) Q
  1.  .. S SCFLAG=$$DTMPROB^SCRPM21U(SCPTTMA,SCACT)
  1.  .. Q
  1.  . Q:SCFLAG
  1.  . ;
  1.  . ; create new destin tm, pos asgns
  1.  . D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
  1.  . I 'SCPTTMA D ERROR(6,SCPTTMA,40) Q
  1.  . D CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
  1.  . I 'SCPTTPA D ERROR(7,SCPTTPA,50) Q
  1.  . ;
  1.  . ; take care of source bookkeeping
  1.  . D XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
  1.  . I 'SCPTTMA D ERROR(8,SCPTTMA,60) Q
  1.  . D DISTEAM^SCRPM21U($$SRCTEAM)
  1.  . I 'SCPTTPA D ERROR(9,SCST,70) Q
  1.  . Q
  1.  ;
  1.  ; case 2
  1.  I $$TMEXIST^SCRPM21U(DFN,SCTM,SCACT,.SCPTTMA) D  D SETP(2) G APTTPQ
  1.  . ; destin tm asgn exists
  1.  . I $$PCPCASN^SCRPM21U(FASIEN,SCTP) D  D SETP(2.1) Q
  1.  .. ; PC to PC tm reassgn
  1.  .. ;
  1.  .. ; take care of destin bookkeeping
  1.  .. Q:$$DTMPROB^SCRPM21U(SCPTTMA,SCACT)
  1.  .. ;
  1.  .. ; create new destin tm, pos asgns
  1.  .. D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
  1.  .. I 'SCPTTMA D ERROR(6,SCPTTMA,80) Q
  1.  .. D CREATPOS^SCRPM21U(.SCPTTPA,.SCPTTMA)
  1.  .. I 'SCPTTPA D ERROR(7,SCPTTPA,100) Q
  1.  .. ;
  1.  .. ; take care of source bookkeeping
  1.  .. D XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
  1.  .. I 'SCPTTMA D ERROR(8,SCPTTMA,105) Q
  1.  .. D DISTEAM^SCRPM21U($$SRCTEAM)
  1.  .. I 'SCPTTPA D ERROR(9,SCST,107) Q
  1.  .. Q
  1.  . ;
  1.  . ;not PC to PC tm reassgn
  1.  . ; update tm asgn 
  1.  . I $$FUTMASN^SCRPM21U(.SCPTTMA,SCACT)!$$FUTTMDIS^SCRPM21U(.SCPTTMA,SCACT) D  Q:'SCPTTMA
  1.  .. D TMACTIV^SCRPM21U(.SCPTTMA,$$PCPOS)
  1.  .. I 'SCPTTMA D ERROR(4,SCPTTMA,120)
  1.  .. Q
  1.  . ;
  1.  . ; create pos asgn
  1.  . D CREATPOS^SCRPM21U(.SCPTTPA,.SCPTTMA)
  1.  . I 'SCPTTPA D ERROR(7,SCPTTPA,130)
  1.  . ;
  1.  . ; dschrg source pos
  1.  . D DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
  1.  . I 'SCPTTPA D ERROR(5,SCPTTPA,135)
  1.  . Q
  1.  ;
  1.  ; case 3 
  1.  ; no destin asgn
  1.  I $$PCPCASN^SCRPM21U(FASIEN,SCTP) D  D SETP(3.1) G APTTPQ
  1.  . ; PC to PC reasgn
  1.  . ;
  1.  . ; create new destin tm, pos asgns
  1.  . D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
  1.  . I 'SCPTTMA D ERROR(6,SCPTTMA,140) Q
  1.  . D CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
  1.  . I 'SCPTTPA D ERROR(7,SCPTTPA,160)  Q
  1.  . ;
  1.  . ; take care of source bookkeeping
  1.  . D XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
  1.  . I 'SCPTTPA D ERROR(8,SCPTTMA,180) Q
  1.  . D DISTEAM^SCRPM21U($$SRCTEAM)
  1.  . I 'SCPTTPA D ERROR(9,SCST,185) Q
  1.  . Q
  1.  ;
  1.  D SETP(3)
  1.  ; not PC to PC reasgn
  1.  ;
  1.  ; create new destin tm, pos asgns
  1.  D CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
  1.  I 'SCPTTMA D ERROR(6,SCPTTMA,187) G APTTPQ
  1.  D CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
  1.  I 'SCPTTPA D ERROR(7,SCPTTPA,190) G APTTPQ
  1.  ;
  1.  ; dschrg source pos
  1.  D DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
  1.  I 'SCPTTPA D ERROR(5,SCPTTPA,200)
  1.  ;
  1. APTTPQ ; All done
  1.  D SAVPARMS
  1.  I SCXLOCK=1 K @SCLOCK
  1.  Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
  1.  ;
  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.57,SCTPTO,0))) D  S SCOK=0
  1.  . S SCPARM("PATIENT")=DFN
  1.  . S SCPARM("POSITION")=SCTPTO
  1.  . D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",SCERR)
  1.  S:'$G(SCACT) SCACT=DT
  1.  S:'$D(SCMAINA) SCMAINA="SC40443A"
  1.  Q SCOK
  1.  ;
  1. INITVARS        ; INITIALIZE LOCAL VARIABLES
  1.  S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2) ; destin tm ien
  1.  S SCAPTDT("BEGIN")=SCACT
  1.  S SCAPTDT("END")=3990101
  1.  S SCAPTDT("INCL")=0
  1.  S SCST=$$GETPOSTM^SCRPM21U(FASIEN) ; source tm ien
  1.  S SCPTTMA=""
  1.  S SCMESS=""
  1.  K @SCERR
  1.  Q
  1.  ;
  1. GETPLST() ; get patient position list
  1.  Q $$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE")
  1.  ;
  1. POSEXIST(SCTM,SCTP,POSAIEN,TMIEN) ;
  1.  ; if active pos asgn, return ien
  1.  N DISDT,SCX,SCY,SCFLAG
  1.  S TMIEN=""
  1.  S SCTM=+$P($G(^SCTM(404.57,SCTP,0)),U,2)  ;ptr to 404.51
  1.  ;
  1.  S SCFLAG=0
  1.  S POSAIEN=0
  1.  ;
  1.  S SCX=0
  1.  F  S SCX=$O(SCAPTTPO("SCTP",SCTM,SCTP,SCX)) Q:'SCX!(SCFLAG)  D
  1.  . S SCY=$O(SCAPTTPO("SCTP",SCTM,SCTP,SCX,0))
  1.  . S DISDT=$P(SCAPTTPO(SCY),U,6)
  1.  . I DISDT=SCACT Q  ;pos is discharged
  1.  . S TMIEN=$$GETPOSTM^SCRPM21U(SCX) ; tm asgn ien
  1.  . S DISDT=$P($G(^SCPT(404.42,TMIEN,0)),U,9)
  1.  . I DISDT,DISDT'>SCACT Q  ;tm is discharged
  1.  . S SCFLAG=1
  1.  . S POSAIEN=SCX
  1.  . Q
  1.  ;
  1.  I SCFLAG Q POSAIEN
  1.  Q 0_U_$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
  1.  ;
  1. ERROR(TXT,IEN,ENUM)     ; HANDLE ERRORS FOR REPORTING
  1.  I +TXT S TXT=$P($T(T+TXT),";;",2)
  1.  S SCMESS=" "_TXT_" [E#"_ENUM_"]"
  1.  ; NVS - use below for more detailed ien and path data
  1.  ;I $P(IEN,U,1)=0 S IEN=$P(IEN,U,2)
  1.  ;S SCMESS=TXT_" [(IEN="_IEN_") E#"_ENUM_" PTH:"_$G(PATH)_"]"
  1.  ;S ^TMP("PDR",$J,"POSREASGN",$H,DFN)=SCMESS
  1.  Q
  1.  ;
  1. T ;;
  1. 1 ;;Data Integrity error.;;
  1. 2 ;;Unable to get positions list.;;
  1. 3 ;;Unable to activate existing position.;;
  1. 4 ;;Unable to activate existing team.;;
  1. 5 ;;Unable to discharge source position.;;
  1. 6 ;;Unable to create destination team.;;
  1. 7 ;;Unable to create destination position.;;
  1. 8 ;;Unable to discharge all positions for PC source team.;;
  1. 9 ;;Unable to discharge PC source team.;;
  1. 10 ;;Patient is being reassigned by another PCMM process.;;
  1.  ;;
  1.  ;
  1. SAVPARMS ; save params for debugging
  1.  ; NVS - comment out the quit to save path/variable data
  1.  Q
  1.  N S,F,NVP
  1.  S S=""
  1.  S S=$O(^TMP("PDR",S),-1)+1 ; get next occurence
  1.  S ^TMP("PDR",S,$J,"INIT")=DFN_U_SCTP_U_SCACT_U_FASIEN_U_SCYESTM ; initial params passed in
  1.  S F="",NVP=""
  1.  F  S F=$O(@SCFIELDA@(F)) Q:F=""  S NVP=NVP_F_"="_@SCFIELDA@(F)_U  ; Get the params passed in for new pos
  1.  S ^TMP("PDR",S,$J,"NPOS")=NVP
  1.  S F="",NVP=""
  1.  F  S F=$O(@SCMAINA@(F)) Q:F=""  S NVP=NVP_F_"="_@SCFIELDA@(F)_U  ; Get the params passed in for new TEAM
  1.  S ^TMP("PDR",S,$J,"NTEAM")=NVP
  1.  S ^TMP("PDR",S,$J,"NASSGN")=$G(SCPTTPA)_U_$G(SCPTTMA)_U_$G(PATH)_U_$G(SCMESS)_U_$H ; conserve new pos and team assigns if present
  1.  Q
  1.  ;
  1. SETP(BR) ; SET PATH INDICATOR FOR DEBUGGING
  1.  ; NVS - comment out the quit to save path/variable data
  1.  Q
  1.  S PATH=$G(PATH)_BR_"-"
  1.  Q
  1.  ;
  1. SRCTEAM()       ; return source tm ien
  1.  ; value set in INITVARS
  1.  Q SCST
  1.  ;
  1. DSTTEAM()       ; return destin tm ien
  1.  Q SCTM
  1.  ;
  1. PCPOS() ; IS THIS A PC POSITION?
  1.  Q $G(@SCFIELDA@(.05),0)
  1.  ;