SCAPMC8C ;BP/DJB - Convert Practitioners List to PCP/AP ; 8/4/00 2:28pm
;;5.3;Scheduling;**177,224,1015**;AUG 13, 1993;Build 21
;;1.0
;
PRTPC(SCTP,SCDATES,SCLIST,SCERR,SCALLHIS,ADJUSTDT) ;Convert list of providers
;for a position, to a list of PROV-U/PROV-P/PRECs.
; PROV-U - Unprecepted provider (PCP)
; PROV-P - Precepted provider (AP)
; PREC - Preceptor (PCP)
;
; Input:
; SCTP - IEN of TEAM POSITION [required]
; SCDATES - See PRTP^SCAPMC8
; SCLIST - Array NAME for output
; SCERR - Array NAME to store error messages.
; Example: ^TMP("ORXX",$J).
; SCALLHIS - 1: Return unfiltered sub-array in SCLIST
; ADJUSTDT - 1:Adjust Start/End dates if provider if is both
; precepted & unprecepted for different times periods.
;
;Output:
; SCLIST(scn,"PROV-U"/"PROV-P"/"PREC",n) = array of practitioners
; Format: See PRTP^SCAPMC8
; SCERR() - See PRTP^SCAPMC8
;
;Returned: 1 if ok, 0 if error
;
NEW RESULT,PRTPC
;
S ADJUSTDT=$G(ADJUSTDT)
;
;Get list of practioners for a team position.
S RESULT=$$PRTP^SCAPMC(.SCTP,.SCDATES,"PRTPC",.SCERR,1,.SCALLHIS)
I 'RESULT G QUIT
I '$D(PRTPC(0)) G QUIT
;
D ADJUST ;Process returned array
QUIT Q RESULT
;
ADJUST ;Convert returned array to PROV-P/PROV-U/PREC array.
;Adjust Start/End dates if provider is both precepted & unprecepted.
;
NEW DATA,DATA1,ID,NUM,NUM1
NEW ADJEDATE,ADJSDATE,EDATE,SDATE,SDATE1
;
;Loop thru array
S NUM=0
F S NUM=$O(PRTPC(NUM)) Q:'NUM D ;
. KILL SDATE ;Initialize SDATE array
. S DATA=$G(PRTPC(NUM))
. ;If no preceptor nodes set PCP node.
. ;Place a zero in "404.53 IEN" subscript.
. S ID=$P(DATA,U,11)_"-0-PCP"
. I '$D(PRTPC(NUM,"PR")) S @SCLIST@(NUM,"PROV-U",ID)=DATA Q
. S SDATE=$P(DATA,U,9) ;...Position History Start Date
. S EDATE=$P(DATA,U,10) ;..Position History End Date
. ;
. ;Loop thru "PR" nodes to find preceptor
. S NUM1=0
. F S NUM1=$O(PRTPC(NUM,"PR",NUM1)) Q:'NUM1 D ;
. . S DATA1=$G(PRTPC(NUM,"PR",NUM1))
. . ;Compare piece 9 & piece 14. Use later date.
. . ; Piece 9 - Date provider assigned
. . ; Piece 14 - Date position assigned.
. . S SDATE1=$P(DATA1,U,9)
. . I $P(DATA1,U,14)>SDATE1 S SDATE1=$P(DATA1,U,14)
. . ;Set temp array to later find earliest preceptor Start Date.
. . ;
. . ;alb/rpm;Patch 224;Filter preceptors outside requested date range
. . Q:'$$DTCHK^SCAPU1(@SCDATES@("BEGIN"),@SCDATES@("END"),0,SDATE1,$P(DATA1,U,10))
. . ;
. . I SDATE1 S SDATE(SDATE1)=""
. . ;
. . ;Set preceptor as PCP.
. . S ID=$P(DATA1,U,11)_"-"_$P(DATA1,U,16)_"-PCP"
. . S @SCLIST@(NUM,"PREC",ID)=DATA1
. . Q
. ;Get earliest preceptor Start Date
. S SDATE1=$O(SDATE(0))
. ;
. ;If position date is not earlier than preceptor date, it's all AP.
. S ID=$P(DATA,U,11)_"-0-AP"
. I SDATE'<SDATE1 S @SCLIST@(NUM,"PROV-P",ID)=DATA Q
. ;
. ;If postion Start/End Dates are both earlier than preceptor date,
. ;then it's all PCP.
. S ID=$P(DATA,U,11)_"-0-PCP"
. I EDATE,EDATE<SDATE1 S @SCLIST@(NUM,"PROV-U",ID)=DATA Q
. ;
. ;Set PCP and AP portions
. ;
. ;Set PCP portion
. S ID=$P(DATA,U,11)_"-0-PCP"
. S ADJSDATE=SDATE ;.....................Adjusted Start Date
. S ADJEDATE=$$FMADD^XLFDT(SDATE1,-1) ;..Adjusted End Date
. I ADJUSTDT S $P(DATA,U,10)=ADJEDATE ;..Adjust End Date
. D ;After AP/PCP split, recheck Start/End Dates.
. . I ADJSDATE,ADJSDATE>@SCDATES@("END") Q ;
. . I ADJEDATE,ADJEDATE<@SCDATES@("BEGIN") Q ;
. . S @SCLIST@(NUM,"PROV-U",ID)=DATA
. ;
. ;Set AP portion
. S ID=$P(DATA,U,11)_"-0-AP"
. S ADJSDATE=SDATE1 ;..Adjusted Start Date
. I $P(DATA,U,15),$P(DATA,U,15)<EDATE S EDATE=$P(DATA,U,15)
. S ADJEDATE=EDATE ;...Adjusted End Date
. I ADJUSTDT D ;......Adjust Start/End dates
. . S $P(DATA,U,9)=ADJSDATE
. . S $P(DATA,U,10)=ADJEDATE
. D ;After AP/PCP split, recheck Start/End Dates.
. . I ADJSDATE,ADJSDATE>@SCDATES@("END") Q ;
. . I ADJEDATE,ADJEDATE<@SCDATES@("BEGIN") Q ;
. . S @SCLIST@(NUM,"PROV-P",ID)=DATA
;
Q
SCAPMC8C ;BP/DJB - Convert Practitioners List to PCP/AP ; 8/4/00 2:28pm
+1 ;;5.3;Scheduling;**177,224,1015**;AUG 13, 1993;Build 21
+2 ;;1.0
+3 ;
PRTPC(SCTP,SCDATES,SCLIST,SCERR,SCALLHIS,ADJUSTDT) ;Convert list of providers
+1 ;for a position, to a list of PROV-U/PROV-P/PRECs.
+2 ; PROV-U - Unprecepted provider (PCP)
+3 ; PROV-P - Precepted provider (AP)
+4 ; PREC - Preceptor (PCP)
+5 ;
+6 ; Input:
+7 ; SCTP - IEN of TEAM POSITION [required]
+8 ; SCDATES - See PRTP^SCAPMC8
+9 ; SCLIST - Array NAME for output
+10 ; SCERR - Array NAME to store error messages.
+11 ; Example: ^TMP("ORXX",$J).
+12 ; SCALLHIS - 1: Return unfiltered sub-array in SCLIST
+13 ; ADJUSTDT - 1:Adjust Start/End dates if provider if is both
+14 ; precepted & unprecepted for different times periods.
+15 ;
+16 ;Output:
+17 ; SCLIST(scn,"PROV-U"/"PROV-P"/"PREC",n) = array of practitioners
+18 ; Format: See PRTP^SCAPMC8
+19 ; SCERR() - See PRTP^SCAPMC8
+20 ;
+21 ;Returned: 1 if ok, 0 if error
+22 ;
+23 NEW RESULT,PRTPC
+24 ;
+25 SET ADJUSTDT=$GET(ADJUSTDT)
+26 ;
+27 ;Get list of practioners for a team position.
+28 SET RESULT=$$PRTP^SCAPMC(.SCTP,.SCDATES,"PRTPC",.SCERR,1,.SCALLHIS)
+29 IF 'RESULT
GOTO QUIT
+30 IF '$DATA(PRTPC(0))
GOTO QUIT
+31 ;
+32 ;Process returned array
DO ADJUST
QUIT QUIT RESULT
+1 ;
ADJUST ;Convert returned array to PROV-P/PROV-U/PREC array.
+1 ;Adjust Start/End dates if provider is both precepted & unprecepted.
+2 ;
+3 NEW DATA,DATA1,ID,NUM,NUM1
+4 NEW ADJEDATE,ADJSDATE,EDATE,SDATE,SDATE1
+5 ;
+6 ;Loop thru array
+7 SET NUM=0
+8 ;
FOR
SET NUM=$ORDER(PRTPC(NUM))
IF 'NUM
QUIT
Begin DoDot:1
+9 ;Initialize SDATE array
KILL SDATE
+10 SET DATA=$GET(PRTPC(NUM))
+11 ;If no preceptor nodes set PCP node.
+12 ;Place a zero in "404.53 IEN" subscript.
+13 SET ID=$PIECE(DATA,U,11)_"-0-PCP"
+14 IF '$DATA(PRTPC(NUM,"PR"))
SET @SCLIST@(NUM,"PROV-U",ID)=DATA
QUIT
+15 ;...Position History Start Date
SET SDATE=$PIECE(DATA,U,9)
+16 ;..Position History End Date
SET EDATE=$PIECE(DATA,U,10)
+17 ;
+18 ;Loop thru "PR" nodes to find preceptor
+19 SET NUM1=0
+20 ;
FOR
SET NUM1=$ORDER(PRTPC(NUM,"PR",NUM1))
IF 'NUM1
QUIT
Begin DoDot:2
+21 SET DATA1=$GET(PRTPC(NUM,"PR",NUM1))
+22 ;Compare piece 9 & piece 14. Use later date.
+23 ; Piece 9 - Date provider assigned
+24 ; Piece 14 - Date position assigned.
+25 SET SDATE1=$PIECE(DATA1,U,9)
+26 IF $PIECE(DATA1,U,14)>SDATE1
SET SDATE1=$PIECE(DATA1,U,14)
+27 ;Set temp array to later find earliest preceptor Start Date.
+28 ;
+29 ;alb/rpm;Patch 224;Filter preceptors outside requested date range
+30 IF '$$DTCHK^SCAPU1(@SCDATES@("BEGIN"),@SCDATES@("END"),0,SDATE1,$PIECE(DATA1,U,10))
QUIT
+31 ;
+32 IF SDATE1
SET SDATE(SDATE1)=""
+33 ;
+34 ;Set preceptor as PCP.
+35 SET ID=$PIECE(DATA1,U,11)_"-"_$PIECE(DATA1,U,16)_"-PCP"
+36 SET @SCLIST@(NUM,"PREC",ID)=DATA1
+37 QUIT
End DoDot:2
+38 ;Get earliest preceptor Start Date
+39 SET SDATE1=$ORDER(SDATE(0))
+40 ;
+41 ;If position date is not earlier than preceptor date, it's all AP.
+42 SET ID=$PIECE(DATA,U,11)_"-0-AP"
+43 IF SDATE'<SDATE1
SET @SCLIST@(NUM,"PROV-P",ID)=DATA
QUIT
+44 ;
+45 ;If postion Start/End Dates are both earlier than preceptor date,
+46 ;then it's all PCP.
+47 SET ID=$PIECE(DATA,U,11)_"-0-PCP"
+48 IF EDATE
IF EDATE<SDATE1
SET @SCLIST@(NUM,"PROV-U",ID)=DATA
QUIT
+49 ;
+50 ;Set PCP and AP portions
+51 ;
+52 ;Set PCP portion
+53 SET ID=$PIECE(DATA,U,11)_"-0-PCP"
+54 ;.....................Adjusted Start Date
SET ADJSDATE=SDATE
+55 ;..Adjusted End Date
SET ADJEDATE=$$FMADD^XLFDT(SDATE1,-1)
+56 ;..Adjust End Date
IF ADJUSTDT
SET $PIECE(DATA,U,10)=ADJEDATE
+57 ;After AP/PCP split, recheck Start/End Dates.
Begin DoDot:2
+58 ;
IF ADJSDATE
IF ADJSDATE>@SCDATES@("END")
QUIT
+59 ;
IF ADJEDATE
IF ADJEDATE<@SCDATES@("BEGIN")
QUIT
+60 SET @SCLIST@(NUM,"PROV-U",ID)=DATA
End DoDot:2
+61 ;
+62 ;Set AP portion
+63 SET ID=$PIECE(DATA,U,11)_"-0-AP"
+64 ;..Adjusted Start Date
SET ADJSDATE=SDATE1
+65 IF $PIECE(DATA,U,15)
IF $PIECE(DATA,U,15)<EDATE
SET EDATE=$PIECE(DATA,U,15)
+66 ;...Adjusted End Date
SET ADJEDATE=EDATE
+67 ;......Adjust Start/End dates
IF ADJUSTDT
Begin DoDot:2
+68 SET $PIECE(DATA,U,9)=ADJSDATE
+69 SET $PIECE(DATA,U,10)=ADJEDATE
End DoDot:2
+70 ;After AP/PCP split, recheck Start/End Dates.
Begin DoDot:2
+71 ;
IF ADJSDATE
IF ADJSDATE>@SCDATES@("END")
QUIT
+72 ;
IF ADJEDATE
IF ADJEDATE<@SCDATES@("BEGIN")
QUIT
+73 SET @SCLIST@(NUM,"PROV-P",ID)=DATA
End DoDot:2
End DoDot:1
+74 ;
+75 QUIT
