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)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPMPSP 8689 printed Nov 22, 2024@17:52:34 Page 2
SCRPMPSP ;ALB/PDR - Team APIs:ACPTTP ; AUG 1998
+1 ;;5.3;Scheduling;**148,157,169,177**;AUG 13, 1993
+2 ;
ACPTTP(DFN,SCTP,SCFIELDA,SCACT,FASIEN,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
+1 ; input:
+2 ; DFN = pointer to PATIENT file (#2)
+3 ; SCTP = pointer to TEAM POSTION file (#404.57) (DESTINATION POSITION)
+4 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value for 404.43
+5 ; SCACT = date to activate [default=DT]
+6 ; FASIEN = "FROM" position assignment IEN
+7 ; SCERR = array NAME to store error messages.
+8 ; [ex. ^TMP("ORXX",$J)]
+9 ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
+10 ; SCMAINA= array of extra field entries for 404.42
+11 ;
+12 ; Output:
+13 ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
+14 ; SCERR() = Array of DIALOG file messages(errors) .
+15 ; Foramt:
+16 ; Subscript: Sequential # from 1 to n
+17 ; Piece Description
+18 ; 1 IEN of DIALOG file
+19 NEW SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCST,PATH
+20 NEW SCPTTPA,SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
+21 NEW SCLOCK,SCXLOCK,SCX
+22 ;
+23 ;
+24 IF '$$OKDATA
DO ERROR(1,FASIEN,5)
GOTO APTTPQ
+25 ;
+26 IF '$DATA(^XTMP("SCMC POS REASGN"))
Begin DoDot:1
+27 SET ^XTMP("SCMC POS REASGN",0)=DT_U_DT_U_"POS REASGN PROCESS LOCK"
+28 QUIT
End DoDot:1
+29 ;
+30 SET SCXLOCK=0
+31 SET SCLOCK="^XTMP(""SCMC POS REASGN"",DFN)"
+32 IF $DATA(@SCLOCK)
DO ERROR(10,FASIEN,7)
GOTO APTTPQ
+33 SET @SCLOCK=""
+34 SET SCXLOCK=1
+35 HANG 1
+36 ;
+37 ;
+38 DO INITVARS
+39 IF '$$GETPLST
DO ERROR(2,FASIEN,10)
GOTO APTTPQ
+40 ;
+41 ;bp/cmf 177 new begin
+42 SET SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
+43 IF SCX<1
DO ERROR($PIECE(SCX,U,2),FASIEN,11)
GOTO APTTPQ
+44 ;bp/cmf 177 new end
+45 ;
+46 ; Business rule processing
+47 ;
+48 ; case 1
+49 IF $$POSEXIST(.SCTM,SCTP,.SCPTTPA,.SCPTTMA)
Begin DoDot:1
+50 ; destin pos asgn exists
+51 IF '$$PCPCASN^SCRPM21U(FASIEN,SCTP)
Begin DoDot:2
+52 ; not PC to PC pos reasgn
+53 ;
+54 ; update pos asgn
+55 DO UPDATPOS^SCRPM21U(.SCPTTPA,SCERR)
+56 IF 'SCPTTPA
DO ERROR(3,SCPTTPA,12)
QUIT
+57 ;
+58 ; update tm asgn
+59 IF $$FUTMASN^SCRPM21U(SCPTTMA,SCACT)!$$FUTTMDIS^SCRPM21U(.SCPTTMA,SCACT)
Begin DoDot:3
+60 DO TMACTIV^SCRPM21U(.SCPTTMA,$$PCPOS)
+61 IF 'SCPTTMA
DO ERROR(4,SCPTTMA,20)
+62 QUIT
End DoDot:3
if 'SCPTTMA
QUIT
+63 ;
+64 ; dschrg source pos
+65 DO DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
+66 IF 'SCPTTPA
DO ERROR(5,SCPTTPA,30)
+67 QUIT
End DoDot:2
DO SETP(1.1)
QUIT
+68 ;
+69 ; PC to PC pos reasgn
+70 NEW SCFLAG
+71 SET SCFLAG=0
+72 NEW SCY
+73 SET SCY=0
+74 FOR
SET SCY=$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,SCY))
if 'SCY!(SCFLAG)
QUIT
Begin DoDot:2
+75 SET SCPTTPA=SCY
+76 SET SCPTTMA=$$GETPOSTM^SCRPM21U(SCPTTPA)
+77 IF '$DATA(^SCPT(404.43,SCPTTPA))
QUIT
+78 SET SCFLAG=$$DPOSPROB^SCRPM21U(SCPTTPA,SCACT)
+79 IF SCFLAG
QUIT
+80 IF '$DATA(^SCPT(404.42,SCPTTMA))
QUIT
+81 SET SCFLAG=$$DTMPROB^SCRPM21U(SCPTTMA,SCACT)
+82 QUIT
End DoDot:2
+83 if SCFLAG
QUIT
+84 ;
+85 ; create new destin tm, pos asgns
+86 DO CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
+87 IF 'SCPTTMA
DO ERROR(6,SCPTTMA,40)
QUIT
+88 DO CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
+89 IF 'SCPTTPA
DO ERROR(7,SCPTTPA,50)
QUIT
+90 ;
+91 ; take care of source bookkeeping
+92 DO XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
+93 IF 'SCPTTMA
DO ERROR(8,SCPTTMA,60)
QUIT
+94 DO DISTEAM^SCRPM21U($$SRCTEAM)
+95 IF 'SCPTTPA
DO ERROR(9,SCST,70)
QUIT
+96 QUIT
End DoDot:1
DO SETP(1)
GOTO APTTPQ
+97 ;
+98 ; case 2
+99 IF $$TMEXIST^SCRPM21U(DFN,SCTM,SCACT,.SCPTTMA)
Begin DoDot:1
+100 ; destin tm asgn exists
+101 IF $$PCPCASN^SCRPM21U(FASIEN,SCTP)
Begin DoDot:2
+102 ; PC to PC tm reassgn
+103 ;
+104 ; take care of destin bookkeeping
+105 if $$DTMPROB^SCRPM21U(SCPTTMA,SCACT)
QUIT
+106 ;
+107 ; create new destin tm, pos asgns
+108 DO CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
+109 IF 'SCPTTMA
DO ERROR(6,SCPTTMA,80)
QUIT
+110 DO CREATPOS^SCRPM21U(.SCPTTPA,.SCPTTMA)
+111 IF 'SCPTTPA
DO ERROR(7,SCPTTPA,100)
QUIT
+112 ;
+113 ; take care of source bookkeeping
+114 DO XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
+115 IF 'SCPTTMA
DO ERROR(8,SCPTTMA,105)
QUIT
+116 DO DISTEAM^SCRPM21U($$SRCTEAM)
+117 IF 'SCPTTPA
DO ERROR(9,SCST,107)
QUIT
+118 QUIT
End DoDot:2
DO SETP(2.1)
QUIT
+119 ;
+120 ;not PC to PC tm reassgn
+121 ; update tm asgn
+122 IF $$FUTMASN^SCRPM21U(.SCPTTMA,SCACT)!$$FUTTMDIS^SCRPM21U(.SCPTTMA,SCACT)
Begin DoDot:2
+123 DO TMACTIV^SCRPM21U(.SCPTTMA,$$PCPOS)
+124 IF 'SCPTTMA
DO ERROR(4,SCPTTMA,120)
+125 QUIT
End DoDot:2
if 'SCPTTMA
QUIT
+126 ;
+127 ; create pos asgn
+128 DO CREATPOS^SCRPM21U(.SCPTTPA,.SCPTTMA)
+129 IF 'SCPTTPA
DO ERROR(7,SCPTTPA,130)
+130 ;
+131 ; dschrg source pos
+132 DO DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
+133 IF 'SCPTTPA
DO ERROR(5,SCPTTPA,135)
+134 QUIT
End DoDot:1
DO SETP(2)
GOTO APTTPQ
+135 ;
+136 ; case 3
+137 ; no destin asgn
+138 IF $$PCPCASN^SCRPM21U(FASIEN,SCTP)
Begin DoDot:1
+139 ; PC to PC reasgn
+140 ;
+141 ; create new destin tm, pos asgns
+142 DO CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
+143 IF 'SCPTTMA
DO ERROR(6,SCPTTMA,140)
QUIT
+144 DO CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
+145 IF 'SCPTTPA
DO ERROR(7,SCPTTPA,160)
QUIT
+146 ;
+147 ; take care of source bookkeeping
+148 DO XALLPOS^SCRPM21U(FASIEN,.SCPTTPA)
+149 IF 'SCPTTPA
DO ERROR(8,SCPTTMA,180)
QUIT
+150 DO DISTEAM^SCRPM21U($$SRCTEAM)
+151 IF 'SCPTTPA
DO ERROR(9,SCST,185)
QUIT
+152 QUIT
End DoDot:1
DO SETP(3.1)
GOTO APTTPQ
+153 ;
+154 DO SETP(3)
+155 ; not PC to PC reasgn
+156 ;
+157 ; create new destin tm, pos asgns
+158 DO CREATETM^SCRPM21U(DFN,$$DSTTEAM,SCACT,.SCPTTMA)
+159 IF 'SCPTTMA
DO ERROR(6,SCPTTMA,187)
GOTO APTTPQ
+160 DO CREATPOS^SCRPM21U(.SCPTTPA,SCPTTMA)
+161 IF 'SCPTTPA
DO ERROR(7,SCPTTPA,190)
GOTO APTTPQ
+162 ;
+163 ; dschrg source pos
+164 DO DISPOS^SCRPM21U(FASIEN,.SCPTTPA)
+165 IF 'SCPTTPA
DO ERROR(5,SCPTTPA,200)
+166 ;
APTTPQ ; All done
+1 DO SAVPARMS
+2 IF SCXLOCK=1
KILL @SCLOCK
+3 QUIT +$GET(SCPTTPA)_U_+$GET(SCNEWTP)_U_+$GET(SCPTTMA)_U_+$PIECE($GET(SCPTTMA),U,2)_U_$GET(SCMESS)
+4 ;
+5 ;
OKDATA() ;setup/check variables
+1 NEW SCOK
+2 SET SCOK=1
+3 DO INIT^SCAPMCU1(.SCOK)
+4 IF '$DATA(^DPT(DFN,0))!('$DATA(^SCTM(404.57,SCTPTO,0)))
Begin DoDot:1
+5 SET SCPARM("PATIENT")=DFN
+6 SET SCPARM("POSITION")=SCTPTO
+7 DO ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",SCERR)
End DoDot:1
SET SCOK=0
+8 if '$GET(SCACT)
SET SCACT=DT
+9 if '$DATA(SCMAINA)
SET SCMAINA="SC40443A"
+10 QUIT SCOK
+11 ;
INITVARS ; INITIALIZE LOCAL VARIABLES
+1 ; destin tm ien
SET SCTM=$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
+2 SET SCAPTDT("BEGIN")=SCACT
+3 SET SCAPTDT("END")=3990101
+4 SET SCAPTDT("INCL")=0
+5 ; source tm ien
SET SCST=$$GETPOSTM^SCRPM21U(FASIEN)
+6 SET SCPTTMA=""
+7 SET SCMESS=""
+8 KILL @SCERR
+9 QUIT
+10 ;
GETPLST() ; get patient position list
+1 QUIT $$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE")
+2 ;
POSEXIST(SCTM,SCTP,POSAIEN,TMIEN) ;
+1 ; if active pos asgn, return ien
+2 NEW DISDT,SCX,SCY,SCFLAG
+3 SET TMIEN=""
+4 ;ptr to 404.51
SET SCTM=+$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
+5 ;
+6 SET SCFLAG=0
+7 SET POSAIEN=0
+8 ;
+9 SET SCX=0
+10 FOR
SET SCX=$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,SCX))
if 'SCX!(SCFLAG)
QUIT
Begin DoDot:1
+11 SET SCY=$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,SCX,0))
+12 SET DISDT=$PIECE(SCAPTTPO(SCY),U,6)
+13 ;pos is discharged
IF DISDT=SCACT
QUIT
+14 ; tm asgn ien
SET TMIEN=$$GETPOSTM^SCRPM21U(SCX)
+15 SET DISDT=$PIECE($GET(^SCPT(404.42,TMIEN,0)),U,9)
+16 ;tm is discharged
IF DISDT
IF DISDT'>SCACT
QUIT
+17 SET SCFLAG=1
+18 SET POSAIEN=SCX
+19 QUIT
End DoDot:1
+20 ;
+21 IF SCFLAG
QUIT POSAIEN
+22 QUIT 0_U_$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,0))
+23 ;
ERROR(TXT,IEN,ENUM) ; HANDLE ERRORS FOR REPORTING
+1 IF +TXT
SET TXT=$PIECE($TEXT(T+TXT),";;",2)
+2 SET SCMESS=" "_TXT_" [E#"_ENUM_"]"
+3 ; NVS - use below for more detailed ien and path data
+4 ;I $P(IEN,U,1)=0 S IEN=$P(IEN,U,2)
+5 ;S SCMESS=TXT_" [(IEN="_IEN_") E#"_ENUM_" PTH:"_$G(PATH)_"]"
+6 ;S ^TMP("PDR",$J,"POSREASGN",$H,DFN)=SCMESS
+7 QUIT
+8 ;
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.;;
+1 ;;
+2 ;
SAVPARMS ; save params for debugging
+1 ; NVS - comment out the quit to save path/variable data
+2 QUIT
+3 NEW S,F,NVP
+4 SET S=""
+5 ; get next occurence
SET S=$ORDER(^TMP("PDR",S),-1)+1
+6 ; initial params passed in
SET ^TMP("PDR",S,$JOB,"INIT")=DFN_U_SCTP_U_SCACT_U_FASIEN_U_SCYESTM
+7 SET F=""
SET NVP=""
+8 ; Get the params passed in for new pos
FOR
SET F=$ORDER(@SCFIELDA@(F))
if F=""
QUIT
SET NVP=NVP_F_"="_@SCFIELDA@(F)_U
+9 SET ^TMP("PDR",S,$JOB,"NPOS")=NVP
+10 SET F=""
SET NVP=""
+11 ; Get the params passed in for new TEAM
FOR
SET F=$ORDER(@SCMAINA@(F))
if F=""
QUIT
SET NVP=NVP_F_"="_@SCFIELDA@(F)_U
+12 SET ^TMP("PDR",S,$JOB,"NTEAM")=NVP
+13 ; conserve new pos and team assigns if present
SET ^TMP("PDR",S,$JOB,"NASSGN")=$GET(SCPTTPA)_U_$GET(SCPTTMA)_U_$GET(PATH)_U_$GET(SCMESS)_U_$HOROLOG
+14 QUIT
+15 ;
SETP(BR) ; SET PATH INDICATOR FOR DEBUGGING
+1 ; NVS - comment out the quit to save path/variable data
+2 QUIT
+3 SET PATH=$GET(PATH)_BR_"-"
+4 QUIT
+5 ;
SRCTEAM() ; return source tm ien
+1 ; value set in INITVARS
+2 QUIT SCST
+3 ;
DSTTEAM() ; return destin tm ien
+1 QUIT SCTM
+2 ;
PCPOS() ; IS THIS A PC POSITION?
+1 QUIT $GET(@SCFIELDA@(.05),0)
+2 ;
