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. ;