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