- 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 Mar 13, 2025@21:47:32 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 ;