SCAPMC19 ;ALB/REW - Team API's ; 12 Jan 99 9:10 AM
;;5.3;Scheduling;**41,174**;AUG 13, 1993
;;1.0
ACPRTP(SC200,SCTP,SCFIELDA,SCEFF,SCERR) ; assign practitioner to position
; input:
; SC200 = New Person File (#200) Pointer
; SCTP = Pointer To Team Position File (#404.57)
; SCFIELDA= array of extra field entries - scfielda('fld#')=value
; -Note: Only used if BRAND NEW POSITION - team fields (404.57)
; SCEFF = date to activate/inactivate [default=DT]
; SCERR = array NAME to store error messages.
; [ex. ^TMP("ORXX",$J)]
;
; Output:
; SCERR() = Array of DIALOG file messages(errors) .
; Foramt:
; Subscript: Sequential # from 1 to n
; Piece Description
; 1 IEN of DIALOG file
;
; 1 2 3 4 5
; Returned: status^histien^actdt^inactdt^sctm
;
;
N SCTPDTS,SCXX,SCOK,SCHIST,SCACTP,SCSTATUS
N SCPTAIEN,SCESEQ,SCPARM,SCIEN
G:'$$OKDATA() QT
S SCSTATUS=$G(@SCFIELDA@(.04))
S SCTPDTS("BEGIN")=SCEFF
S SCTPDTS("END")=3990101
;for inactive check for any activity in future
;for active check for continuous activity in future
S SCTPDTS("INCL")='SCSTATUS
S SCOK=0
IF "^1^0^"'[(U_SCSTATUS_U) D G QT
.S SCOK=-1
.S SCPARM("POSITION")=$G(SCTP,"Undefined")
.S SCPARM("PRACTITIONER")=$G(SC200,"Undefined")
.S SCPARM("MESSAGE")="Required Field: #.04 = "_SCSTATUS
.D ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
;is position already active or will be in future?
S SCHIST=$P($$ACTHIST^SCAPMCU2(404.52,SCTP,"SCTPDTS",.SCERR,"SCXX"),U,1,4)
;inactivation must be after activation date
IF ('SCSTATUS)&($P(SCHIST,U,3)'<SCEFF) D G QT
. S SCPARM("PRACTITIONER")=$G(SC200,"Undefined")
. S SCPARM("POSITION")=$G(SCTP,"Undefined")
. S SCPARM("MESSAGE")="Inactivation Date must not be equal to Inactivation Date"
. D ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
;must inactivate same practitioner who was last activated
S SCOLD200=$P($G(^SCTM(404.52,+$P(SCHIST,U,2),0)),U,3)
IF ('SCSTATUS)&(SCOLD200&(SCOLD200'=SC200)) D G QT
. S SCOK=-1
. S SCPARM("PRACTITIONER")=$G(SC200,"Undefined")
. S SCPARM("MESSAGE")="Inactivation must be for same practitioner who was last activated"
. D ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
IF (+SCHIST+SCSTATUS)=1!('$D(^SCTM(404.52,"B",SCTP))) D ;procede if not at state now
.S SC($J,404.52,"+1,",.01)=SCTP
.S SC($J,404.52,"+1,",.02)=SCEFF
.S SC($J,404.52,"+1,",.03)=SC200
.IF $D(SCFIELDA) D
..S SCFLD=0
..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
...S SC($J,404.52,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
.D UPDATE^DIE("","SC($J)","SCIEN",.SCERR)
.IF '$G(@SCERR@(0))<1 D
.S:SCSTATUS SCHIST=SCSTATUS_U_SCIEN(1)_U_SCEFF_U
.S:'SCSTATUS SCHIST=SCSTATUS_U_SCIEN(1)_U_$P(SCHIST,U,3)_U_SCEFF
.S SCOK=1
QT Q SCOK_U_$G(SCHIST)
;
OKDATA() ;
;setup/check variables for acTP call
N SCOK,SCFLD
S SCOK=1
D INIT^SCAPMCU1(.SCOK)
S:'$G(SCEFF) SCEFF=DT
IF '$D(^VA(200,+$G(SC200),0)) D
. S SCPARM("PRACTITIONER")=$G(SC200,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045201,.SCPARM,"",.SCERR)
IF '$D(^SCTM(404.57,+$G(SCTP),0)) D
. S SCPARM("POSITION")=$G(SCTP,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045701,.SCPARM,"",.SCERR)
F SCFLD=.04,.05 IF '($D(@SCFIELDA@(SCFLD))#2) D
. S SCPARM("PRACTITIONER")=$G(SC200,"Undefined")
. S SCPARM("MESSAGE")="Undefined history fields"
. D ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
Q SCOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC19 3511 printed Nov 22, 2024@17:47:51 Page 2
SCAPMC19 ;ALB/REW - Team API's ; 12 Jan 99 9:10 AM
+1 ;;5.3;Scheduling;**41,174**;AUG 13, 1993
+2 ;;1.0
ACPRTP(SC200,SCTP,SCFIELDA,SCEFF,SCERR) ; assign practitioner to position
+1 ; input:
+2 ; SC200 = New Person File (#200) Pointer
+3 ; SCTP = Pointer To Team Position File (#404.57)
+4 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value
+5 ; -Note: Only used if BRAND NEW POSITION - team fields (404.57)
+6 ; SCEFF = date to activate/inactivate [default=DT]
+7 ; SCERR = array NAME to store error messages.
+8 ; [ex. ^TMP("ORXX",$J)]
+9 ;
+10 ; Output:
+11 ; SCERR() = Array of DIALOG file messages(errors) .
+12 ; Foramt:
+13 ; Subscript: Sequential # from 1 to n
+14 ; Piece Description
+15 ; 1 IEN of DIALOG file
+16 ;
+17 ; 1 2 3 4 5
+18 ; Returned: status^histien^actdt^inactdt^sctm
+19 ;
+20 ;
+21 NEW SCTPDTS,SCXX,SCOK,SCHIST,SCACTP,SCSTATUS
+22 NEW SCPTAIEN,SCESEQ,SCPARM,SCIEN
+23 if '$$OKDATA()
GOTO QT
+24 SET SCSTATUS=$GET(@SCFIELDA@(.04))
+25 SET SCTPDTS("BEGIN")=SCEFF
+26 SET SCTPDTS("END")=3990101
+27 ;for inactive check for any activity in future
+28 ;for active check for continuous activity in future
+29 SET SCTPDTS("INCL")='SCSTATUS
+30 SET SCOK=0
+31 IF "^1^0^"'[(U_SCSTATUS_U)
Begin DoDot:1
+32 SET SCOK=-1
+33 SET SCPARM("POSITION")=$GET(SCTP,"Undefined")
+34 SET SCPARM("PRACTITIONER")=$GET(SC200,"Undefined")
+35 SET SCPARM("MESSAGE")="Required Field: #.04 = "_SCSTATUS
+36 DO ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
End DoDot:1
GOTO QT
+37 ;is position already active or will be in future?
+38 SET SCHIST=$PIECE($$ACTHIST^SCAPMCU2(404.52,SCTP,"SCTPDTS",.SCERR,"SCXX"),U,1,4)
+39 ;inactivation must be after activation date
+40 IF ('SCSTATUS)&($PIECE(SCHIST,U,3)'<SCEFF)
Begin DoDot:1
+41 SET SCPARM("PRACTITIONER")=$GET(SC200,"Undefined")
+42 SET SCPARM("POSITION")=$GET(SCTP,"Undefined")
+43 SET SCPARM("MESSAGE")="Inactivation Date must not be equal to Inactivation Date"
+44 DO ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
End DoDot:1
GOTO QT
+45 ;must inactivate same practitioner who was last activated
+46 SET SCOLD200=$PIECE($GET(^SCTM(404.52,+$PIECE(SCHIST,U,2),0)),U,3)
+47 IF ('SCSTATUS)&(SCOLD200&(SCOLD200'=SC200))
Begin DoDot:1
+48 SET SCOK=-1
+49 SET SCPARM("PRACTITIONER")=$GET(SC200,"Undefined")
+50 SET SCPARM("MESSAGE")="Inactivation must be for same practitioner who was last activated"
+51 DO ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
End DoDot:1
GOTO QT
+52 ;procede if not at state now
IF (+SCHIST+SCSTATUS)=1!('$DATA(^SCTM(404.52,"B",SCTP)))
Begin DoDot:1
+53 SET SC($JOB,404.52,"+1,",.01)=SCTP
+54 SET SC($JOB,404.52,"+1,",.02)=SCEFF
+55 SET SC($JOB,404.52,"+1,",.03)=SC200
+56 IF $DATA(SCFIELDA)
Begin DoDot:2
+57 SET SCFLD=0
+58 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:3
+59 SET SC($JOB,404.52,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:3
End DoDot:2
+60 DO UPDATE^DIE("","SC($J)","SCIEN",.SCERR)
+61 IF '$GET(@SCERR@(0))<1
Begin DoDot:2
End DoDot:2
+62 if SCSTATUS
SET SCHIST=SCSTATUS_U_SCIEN(1)_U_SCEFF_U
+63 if 'SCSTATUS
SET SCHIST=SCSTATUS_U_SCIEN(1)_U_$PIECE(SCHIST,U,3)_U_SCEFF
+64 SET SCOK=1
End DoDot:1
QT QUIT SCOK_U_$GET(SCHIST)
+1 ;
OKDATA() ;
+1 ;setup/check variables for acTP call
+2 NEW SCOK,SCFLD
+3 SET SCOK=1
+4 DO INIT^SCAPMCU1(.SCOK)
+5 if '$GET(SCEFF)
SET SCEFF=DT
+6 IF '$DATA(^VA(200,+$GET(SC200),0))
Begin DoDot:1
+7 SET SCPARM("PRACTITIONER")=$GET(SC200,"Undefined")
+8 DO ERR^SCAPMCU1(.SCESEQ,4045201,.SCPARM,"",.SCERR)
End DoDot:1
+9 IF '$DATA(^SCTM(404.57,+$GET(SCTP),0))
Begin DoDot:1
+10 SET SCPARM("POSITION")=$GET(SCTP,"Undefined")
+11 DO ERR^SCAPMCU1(.SCESEQ,4045701,.SCPARM,"",.SCERR)
End DoDot:1
+12 FOR SCFLD=.04,.05
IF '($DATA(@SCFIELDA@(SCFLD))#2)
Begin DoDot:1
+13 SET SCPARM("PRACTITIONER")=$GET(SC200,"Undefined")
+14 SET SCPARM("MESSAGE")="Undefined history fields"
+15 DO ERR^SCAPMCU1(.SCESEQ,4045200,.SCPARM,"",.SCERR)
End DoDot:1
+16 QUIT SCOK
