SCAPMC33 ;BP/DJB - Get Provider Array For a Pt Tm Pos ; 5/24/99 12:39pm
;;5.3;Scheduling;**177**;May 01, 1999
;
PRPTTP(PTTMPOS,SCDATES,SCLIST,SCERR,SCALLHIS,ADJDATE) ;Get provider array for
;a Patient Team Position Assignment (#404.43).
;
; Input:
; PTTMPOS - Pointer to entry in PATIENT TEAM POSITION
; ASSIGNMENT file (#404.43).
; SCDATES("BEGIN") - Begin date to search (inclusive).
; Default 1=Assign Date field in file 404.43.
; Default 2=DT
; ("END" - End date to search (inclusive).
; Default 1=Unassign Date field in file 404.43.
; Default 2=DT
; ("INCL") - 1: Only use pracitioners who were on
; team for entire date range
; 0: Anytime in date range.
; Default=1.
; SCLIST - Array name to store returned data.
; SCERR - Array name to store error messages.
; Ex: ^TMP("ORXX",$J).
; SCALLHIS - 1: Return unfiltered sub-array in SCLIST
; ADJDATE - 1: Adjust Start/End dates of provider so they
; don't exceed Assign/Unassign dates of Patient
; Team Position Assignment.
;Output:
; SCLIST() - Array of practitioners. See PRTP^SCAPMC8
; SCERR() - Array of error msg. See PRTP^SCAPMC8
;Returned: 1 if ok, 0 if error
;
;Declare variables
NEW EDATE,ND,OK,SDATE,TMPOSPTR
;
;Initialize variables
S OK=0
I $D(SCERR) KILL @SCERR
;
;Check input
I '$G(PTTMPOS) G QUIT
I '$D(^SCPT(404.43,PTTMPOS,0)) G QUIT
;
;Get data
S ND=$G(^SCPT(404.43,PTTMPOS,0)) ;Zero node of 404.43
S TMPOSPTR=$P(ND,U,2) ;...........Team Position IEN
I 'TMPOSPTR G QUIT
S SDATE=$P(ND,U,3) ;..............Assigned Date
S EDATE=$P(ND,U,4) ;..............Unassigned Date
;
S OK=$$ADJUST1(SDATE,EDATE)
G:'OK QUIT
S OK=$$PRTP^SCAPMC(TMPOSPTR,.SCDATES,.SCLIST,.SCERR,1,.SCALLHIS)
G:'OK QUIT
G:'$D(SCLIST(0)) QUIT
;
I $G(ADJDATE) D ADJUST2 ;Adjust Start/End Dates.
;
QUIT Q OK
;
ADJUST1(SDATE,EDATE) ;Adjust SCDATES to Assign/Unassign Dates in 404.43.
;
NEW OK
S OK=0
;
;Set defaults
I '$G(@SCDATES@("BEGIN")) S @SCDATES@("BEGIN")=SDATE
I '$G(@SCDATES@("END")) S @SCDATES@("END")=EDATE
I '@SCDATES@("BEGIN") S @SCDATES@("BEGIN")=DT
I '@SCDATES@("END") S @SCDATES@("END")=DT
;
;Quit if requested date range is outside of 404.43 date range.
I SDATE,@SCDATES@("END")<SDATE G ADJQUIT
I EDATE,@SCDATES@("BEGIN")>EDATE G ADJQUIT
;
;Adjust requested date range if it is wider than 404.43 date range.
I SDATE>@SCDATES@("BEGIN") S @SCDATES@("BEGIN")=SDATE
I EDATE,@SCDATES@("END")>EDATE S @SCDATES@("END")=EDATE
S OK=1
ADJQUIT Q OK
;
ADJUST2 ;Adjust Assigned/Unassigned Dates in SCLIST array so they don't
;exceed requested date range..
;
NEW DATA,POSH,PREH
Q:'$D(@SCLIST)
;
;Position History
S POSH=0
F S POSH=$O(@SCLIST@(POSH)) Q:'POSH D ;
. S DATA=$G(@SCLIST@(POSH))
. ;
. ;Adjust Begin Date
. I $P(DATA,U,9)<@SCDATES@("BEGIN") D ;
. . ;Update main node
. . S $P(@SCLIST@(POSH),U,9)=@SCDATES@("BEGIN")
. . ;
. . ;Update "SCPR" node
. . K @SCLIST@("SCPR",$P(DATA,U,1),$P(DATA,U,3),$P(DATA,U,9),POSH)
. . S @SCLIST@("SCPR",$P(DATA,U,1),$P(DATA,U,3),@SCDATES@("BEGIN"),POSH)=""
. ;
. ;Adjust End Date
. I $P(DATA,U,10)>@SCDATES@("END") D ;
. . S $P(@SCLIST@(POSH),U,10)=@SCDATES@("END")
. ;
. ;Preceptor History
. S PREH=0
. F S PREH=$O(@SCLIST@(POSH,"PR",PREH)) Q:'PREH D ;
. . S DATA=$G(@SCLIST@(POSH,"PR",PREH))
. . ;
. . ;Adjust Begin Date
. . I $P(DATA,U,9)<@SCDATES@("BEGIN") D ;
. . . ;Update "PR" node
. . . S $P(@SCLIST@(POSH,"PR",PREH),U,9)=@SCDATES@("BEGIN")
. . . ;Update "SCPR" node
. . . K @SCLIST@(POSH,"SCPR",$P(DATA,U,1),$P(DATA,U,3),$P(DATA,U,9),PREH)
. . . S @SCLIST@(POSH,"SCPR",$P(DATA,U,1),$P(DATA,U,3),@SCDATES@("BEGIN"),PREH)=""
. . ;
. . ;Adjust End Date
. . I $P($G(@SCLIST@(POSH,"PR",PREH)),U,10)>@SCDATES@("END") D ;
. . . S $P(@SCLIST@(POSH,"PR",PREH),U,10)=@SCDATES@("END")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC33 4205 printed Sep 23, 2025@20:14:27 Page 2
SCAPMC33 ;BP/DJB - Get Provider Array For a Pt Tm Pos ; 5/24/99 12:39pm
+1 ;;5.3;Scheduling;**177**;May 01, 1999
+2 ;
PRPTTP(PTTMPOS,SCDATES,SCLIST,SCERR,SCALLHIS,ADJDATE) ;Get provider array for
+1 ;a Patient Team Position Assignment (#404.43).
+2 ;
+3 ; Input:
+4 ; PTTMPOS - Pointer to entry in PATIENT TEAM POSITION
+5 ; ASSIGNMENT file (#404.43).
+6 ; SCDATES("BEGIN") - Begin date to search (inclusive).
+7 ; Default 1=Assign Date field in file 404.43.
+8 ; Default 2=DT
+9 ; ("END" - End date to search (inclusive).
+10 ; Default 1=Unassign Date field in file 404.43.
+11 ; Default 2=DT
+12 ; ("INCL") - 1: Only use pracitioners who were on
+13 ; team for entire date range
+14 ; 0: Anytime in date range.
+15 ; Default=1.
+16 ; SCLIST - Array name to store returned data.
+17 ; SCERR - Array name to store error messages.
+18 ; Ex: ^TMP("ORXX",$J).
+19 ; SCALLHIS - 1: Return unfiltered sub-array in SCLIST
+20 ; ADJDATE - 1: Adjust Start/End dates of provider so they
+21 ; don't exceed Assign/Unassign dates of Patient
+22 ; Team Position Assignment.
+23 ;Output:
+24 ; SCLIST() - Array of practitioners. See PRTP^SCAPMC8
+25 ; SCERR() - Array of error msg. See PRTP^SCAPMC8
+26 ;Returned: 1 if ok, 0 if error
+27 ;
+28 ;Declare variables
+29 NEW EDATE,ND,OK,SDATE,TMPOSPTR
+30 ;
+31 ;Initialize variables
+32 SET OK=0
+33 IF $DATA(SCERR)
KILL @SCERR
+34 ;
+35 ;Check input
+36 IF '$GET(PTTMPOS)
GOTO QUIT
+37 IF '$DATA(^SCPT(404.43,PTTMPOS,0))
GOTO QUIT
+38 ;
+39 ;Get data
+40 ;Zero node of 404.43
SET ND=$GET(^SCPT(404.43,PTTMPOS,0))
+41 ;...........Team Position IEN
SET TMPOSPTR=$PIECE(ND,U,2)
+42 IF 'TMPOSPTR
GOTO QUIT
+43 ;..............Assigned Date
SET SDATE=$PIECE(ND,U,3)
+44 ;..............Unassigned Date
SET EDATE=$PIECE(ND,U,4)
+45 ;
+46 SET OK=$$ADJUST1(SDATE,EDATE)
+47 if 'OK
GOTO QUIT
+48 SET OK=$$PRTP^SCAPMC(TMPOSPTR,.SCDATES,.SCLIST,.SCERR,1,.SCALLHIS)
+49 if 'OK
GOTO QUIT
+50 if '$DATA(SCLIST(0))
GOTO QUIT
+51 ;
+52 ;Adjust Start/End Dates.
IF $GET(ADJDATE)
DO ADJUST2
+53 ;
QUIT QUIT OK
+1 ;
ADJUST1(SDATE,EDATE) ;Adjust SCDATES to Assign/Unassign Dates in 404.43.
+1 ;
+2 NEW OK
+3 SET OK=0
+4 ;
+5 ;Set defaults
+6 IF '$GET(@SCDATES@("BEGIN"))
SET @SCDATES@("BEGIN")=SDATE
+7 IF '$GET(@SCDATES@("END"))
SET @SCDATES@("END")=EDATE
+8 IF '@SCDATES@("BEGIN")
SET @SCDATES@("BEGIN")=DT
+9 IF '@SCDATES@("END")
SET @SCDATES@("END")=DT
+10 ;
+11 ;Quit if requested date range is outside of 404.43 date range.
+12 IF SDATE
IF @SCDATES@("END")<SDATE
GOTO ADJQUIT
+13 IF EDATE
IF @SCDATES@("BEGIN")>EDATE
GOTO ADJQUIT
+14 ;
+15 ;Adjust requested date range if it is wider than 404.43 date range.
+16 IF SDATE>@SCDATES@("BEGIN")
SET @SCDATES@("BEGIN")=SDATE
+17 IF EDATE
IF @SCDATES@("END")>EDATE
SET @SCDATES@("END")=EDATE
+18 SET OK=1
ADJQUIT QUIT OK
+1 ;
ADJUST2 ;Adjust Assigned/Unassigned Dates in SCLIST array so they don't
+1 ;exceed requested date range..
+2 ;
+3 NEW DATA,POSH,PREH
+4 if '$DATA(@SCLIST)
QUIT
+5 ;
+6 ;Position History
+7 SET POSH=0
+8 ;
FOR
SET POSH=$ORDER(@SCLIST@(POSH))
if 'POSH
QUIT
Begin DoDot:1
+9 SET DATA=$GET(@SCLIST@(POSH))
+10 ;
+11 ;Adjust Begin Date
+12 ;
IF $PIECE(DATA,U,9)<@SCDATES@("BEGIN")
Begin DoDot:2
+13 ;Update main node
+14 SET $PIECE(@SCLIST@(POSH),U,9)=@SCDATES@("BEGIN")
+15 ;
+16 ;Update "SCPR" node
+17 KILL @SCLIST@("SCPR",$PIECE(DATA,U,1),$PIECE(DATA,U,3),$PIECE(DATA,U,9),POSH)
+18 SET @SCLIST@("SCPR",$PIECE(DATA,U,1),$PIECE(DATA,U,3),@SCDATES@("BEGIN"),POSH)=""
End DoDot:2
+19 ;
+20 ;Adjust End Date
+21 ;
IF $PIECE(DATA,U,10)>@SCDATES@("END")
Begin DoDot:2
+22 SET $PIECE(@SCLIST@(POSH),U,10)=@SCDATES@("END")
End DoDot:2
+23 ;
+24 ;Preceptor History
+25 SET PREH=0
+26 ;
FOR
SET PREH=$ORDER(@SCLIST@(POSH,"PR",PREH))
if 'PREH
QUIT
Begin DoDot:2
+27 SET DATA=$GET(@SCLIST@(POSH,"PR",PREH))
+28 ;
+29 ;Adjust Begin Date
+30 ;
IF $PIECE(DATA,U,9)<@SCDATES@("BEGIN")
Begin DoDot:3
+31 ;Update "PR" node
+32 SET $PIECE(@SCLIST@(POSH,"PR",PREH),U,9)=@SCDATES@("BEGIN")
+33 ;Update "SCPR" node
+34 KILL @SCLIST@(POSH,"SCPR",$PIECE(DATA,U,1),$PIECE(DATA,U,3),$PIECE(DATA,U,9),PREH)
+35 SET @SCLIST@(POSH,"SCPR",$PIECE(DATA,U,1),$PIECE(DATA,U,3),@SCDATES@("BEGIN"),PREH)=""
End DoDot:3
+36 ;
+37 ;Adjust End Date
+38 ;
IF $PIECE($GET(@SCLIST@(POSH,"PR",PREH)),U,10)>@SCDATES@("END")
Begin DoDot:3
+39 SET $PIECE(@SCLIST@(POSH,"PR",PREH),U,10)=@SCDATES@("END")
End DoDot:3
End DoDot:2
End DoDot:1
+40 QUIT
