SCAPMC34 ;BP/DJB - Get PCP/AP Array For a Pt Tm Pos ; 5/24/99 12:39pm
;;5.3;Scheduling;**177,212**;May 01, 1999
;
PRPTTPC(PTTMPOS,SCDATES,SCLIST,SCERR,SCALLHIS,ADJDATE) ;
;Get provider array for a Patient Team Position Assignment (#404.43).
;
; Input: See PRPTTP^SCAPMC33
;Output: See PRTP^SCAPMC8
;
;Returned: 1 if ok, 0 if error
;
;Declare variables
NEW EDATE,ND,OK,PRPTTPC,SDATE,TMPOSPTR
;
;Initialize variables
S OK=0
;
;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^SCAPMC33(SDATE,EDATE)
G:'OK QUIT
;Get temporary array in PRPTTPC. It will be converted to @SCLIST.
S OK=$$PRTPC^SCAPMC(TMPOSPTR,.SCDATES,"PRPTTPC",.SCERR,.SCALLHIS,.ADJDATE)
G:'OK QUIT
G:'$D(PRPTTPC) QUIT
;
;alb/rpm - Patch 212 start
D ADJUST(EDATE) ;Convert array & adjust dates and unique ID subscript
;alb/rpm - Patch 212 end
;
QUIT Q OK
;
ADJUST(SCUDATE) ;Convert PROV-P/PROV-U/PREC array to AP/PCP array. Adjust Start/End
;dates in SCLIST array so they don't exceed requested date range.
;Add the Pt Tm Pos Assign IEN to unique ID string.
;alb/rpm Patch 212 start
; Input:
; SCUDATE - Pt Tm Pos Unassign date [default=""]
;
; Output: None
;alb/rpm Patch 212 end
;
NEW DATA,ID,ID1,NUM,PREH,TYPE,TYPE1
Q:'$D(PRPTTPC)
;
;alb/rpm Patch 212 start
S SCUDATE=$G(SCUDATE,"")
;alb/rpm Patch 212 end
;
;Loop thru returned array and make adjustments.
S NUM=0
F S NUM=$O(PRPTTPC(NUM)) Q:'NUM S TYPE="" F S TYPE=$O(PRPTTPC(NUM,TYPE)) Q:TYPE="" S ID="" F S ID=$O(PRPTTPC(NUM,TYPE,ID)) Q:ID="" D ;
. S DATA=$G(PRPTTPC(NUM,TYPE,ID))
. ;
. ;alb/rpm Patch 212 start
. ;
. ;Adjust preceptor act/inact dates to represent preceptor
. ;assign/unassign dates.
. ;
. I $G(ADJDATE),TYPE="PREC" D
. . I $P(DATA,U,9)<$P(DATA,U,14) S $P(DATA,U,9)=$P(DATA,U,14)
. . I $P(DATA,U,15)]"",$P(DATA,U,10)="" S $P(DATA,U,10)=$P(DATA,U,15)
. ;
. ;Enable the date adjustment to work correctly when no Team Position
. ;Inactivation Date exists during a Patient Team Position Unassignment
. ;by stuffing the Patient Team Position Unassignment Date into the Team
. ;Position Inactivation Date field.
. ;
. I $G(ADJDATE),SCUDATE]"",$P(DATA,U,10)="" S $P(DATA,U,10)=SCUDATE
. ;
. ;Continue only if the Act/Inact dates fall within Assign/Unassign
. ;dates
. ;
. I $G(ADJDATE),'$$DTCHK^SCAPU1(@SCDATES@("BEGIN"),@SCDATES@("END"),0,$P(DATA,U,9),$P(DATA,U,10)) Q
. ;
. ;alb/rpm Patch 212 end
. ;
. ;Adjust dates
. I $G(ADJDATE) D ;
. . I $P(DATA,U,9)<@SCDATES@("BEGIN") D ;Begin Date
. . . S $P(DATA,U,9)=@SCDATES@("BEGIN")
. . I @SCDATES@("END"),$P(DATA,U,10)>@SCDATES@("END") D ;End Date
. . . S $P(DATA,U,10)=@SCDATES@("END")
. ;
. ;Add Patient Team Position Assign pointer to ID.
. S ID1=PTTMPOS_"-"_ID
. ;Mark subscript as AP or PCP
. S TYPE1=$S(ID["AP":"AP",1:"PCP")
. ;Build return array
. S @SCLIST@(PTTMPOS,TYPE1,ID1)=DATA
. Q
Q
;
PROV(PTTMPOS,SCDATE,SCTYPE,SCPIECE) ;Return a single node/piece for AP/PCP
;
;Input:
; PTTMPOS - Pointer to entry in PATIENT TEAM POSITION
; ASSIGNMENT file (#404.43).
; SCDATE - A single date.
; SCTYPE - AP: Associate Provider
; PCP: Primary Care Provider
; Default=PCP
; SCPIECE - Enter number of piece of string you want displayed.
; If null, return entire string.
; See PRTP^SCAPMC8 for a description of the string
; pieces.
;Return: Data specified by SCPIECE. See PRTP^SCAPMC8 for a
; description of the string pieces.
;
NEW DATA,ERR,I,ID,IEN,PROV,RESULT,TMP,TYPE,ZDATE
;
;Initialize variables
I '$G(PTTMPOS) Q ""
I '$D(^SCPT(404.43,PTTMPOS,0)) Q ""
I '$G(SCDATE) Q ""
S ZDATE("BEGIN")=SCDATE
S ZDATE("END")=SCDATE
S ZDATE("INCL")=0
S:$G(SCTYPE)'="AP" SCTYPE="PCP"
S TYPE=$S(SCTYPE="PCP":"AP",1:"PCP")
S SCPIECE=$G(SCPIECE)
;
S RESULT=$$PRPTTPC^SCAPMC(PTTMPOS,"ZDATE","PROV","ERR",1)
I 'RESULT Q ""
;
;Build temp array subscripted by 404.52 IEN
S PTTMPOS=0
F S PTTMPOS=$O(PROV(PTTMPOS)) Q:'PTTMPOS D ;
. S ID=""
. F S ID=$O(PROV(PTTMPOS,SCTYPE,ID)) Q:ID="" D ;
. . S IEN=$P(PROV(PTTMPOS,SCTYPE,ID),"^",11)
. . S TMP(IEN)=PTTMPOS_U_SCTYPE_U_ID
;
;If more than one node, delete all but one with highest 404.52 IEN.
S IEN=$O(TMP(""),-1) I 'IEN Q ""
S DATA=$G(TMP(IEN))
S DATA=$G(PROV($P(DATA,U,1),$P(DATA,U,2),$P(DATA,U,3)))
I SCPIECE S DATA=$P(DATA,U,SCPIECE)
Q DATA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC34 4854 printed Apr 09, 2024@22:04:11 Page 2
SCAPMC34 ;BP/DJB - Get PCP/AP Array For a Pt Tm Pos ; 5/24/99 12:39pm
+1 ;;5.3;Scheduling;**177,212**;May 01, 1999
+2 ;
PRPTTPC(PTTMPOS,SCDATES,SCLIST,SCERR,SCALLHIS,ADJDATE) ;
+1 ;Get provider array for a Patient Team Position Assignment (#404.43).
+2 ;
+3 ; Input: See PRPTTP^SCAPMC33
+4 ;Output: See PRTP^SCAPMC8
+5 ;
+6 ;Returned: 1 if ok, 0 if error
+7 ;
+8 ;Declare variables
+9 NEW EDATE,ND,OK,PRPTTPC,SDATE,TMPOSPTR
+10 ;
+11 ;Initialize variables
+12 SET OK=0
+13 ;
+14 ;Check input
+15 IF '$GET(PTTMPOS)
GOTO QUIT
+16 IF '$DATA(^SCPT(404.43,PTTMPOS,0))
GOTO QUIT
+17 ;
+18 ;Get data
+19 ;Zero node of 404.43
SET ND=$GET(^SCPT(404.43,PTTMPOS,0))
+20 ;...........Team Position IEN
SET TMPOSPTR=$PIECE(ND,U,2)
+21 IF 'TMPOSPTR
GOTO QUIT
+22 ;..............Assigned Date
SET SDATE=$PIECE(ND,U,3)
+23 ;..............Unassigned Date
SET EDATE=$PIECE(ND,U,4)
+24 ;
+25 SET OK=$$ADJUST1^SCAPMC33(SDATE,EDATE)
+26 if 'OK
GOTO QUIT
+27 ;Get temporary array in PRPTTPC. It will be converted to @SCLIST.
+28 SET OK=$$PRTPC^SCAPMC(TMPOSPTR,.SCDATES,"PRPTTPC",.SCERR,.SCALLHIS,.ADJDATE)
+29 if 'OK
GOTO QUIT
+30 if '$DATA(PRPTTPC)
GOTO QUIT
+31 ;
+32 ;alb/rpm - Patch 212 start
+33 ;Convert array & adjust dates and unique ID subscript
DO ADJUST(EDATE)
+34 ;alb/rpm - Patch 212 end
+35 ;
QUIT QUIT OK
+1 ;
ADJUST(SCUDATE) ;Convert PROV-P/PROV-U/PREC array to AP/PCP array. Adjust Start/End
+1 ;dates in SCLIST array so they don't exceed requested date range.
+2 ;Add the Pt Tm Pos Assign IEN to unique ID string.
+3 ;alb/rpm Patch 212 start
+4 ; Input:
+5 ; SCUDATE - Pt Tm Pos Unassign date [default=""]
+6 ;
+7 ; Output: None
+8 ;alb/rpm Patch 212 end
+9 ;
+10 NEW DATA,ID,ID1,NUM,PREH,TYPE,TYPE1
+11 if '$DATA(PRPTTPC)
QUIT
+12 ;
+13 ;alb/rpm Patch 212 start
+14 SET SCUDATE=$GET(SCUDATE,"")
+15 ;alb/rpm Patch 212 end
+16 ;
+17 ;Loop thru returned array and make adjustments.
+18 SET NUM=0
+19 ;
FOR
SET NUM=$ORDER(PRPTTPC(NUM))
if 'NUM
QUIT
SET TYPE=""
FOR
SET TYPE=$ORDER(PRPTTPC(NUM,TYPE))
if TYPE=""
QUIT
SET ID=""
FOR
SET ID=$ORDER(PRPTTPC(NUM,TYPE,ID))
if ID=""
QUIT
Begin DoDot:1
+20 SET DATA=$GET(PRPTTPC(NUM,TYPE,ID))
+21 ;
+22 ;alb/rpm Patch 212 start
+23 ;
+24 ;Adjust preceptor act/inact dates to represent preceptor
+25 ;assign/unassign dates.
+26 ;
+27 IF $GET(ADJDATE)
IF TYPE="PREC"
Begin DoDot:2
+28 IF $PIECE(DATA,U,9)<$PIECE(DATA,U,14)
SET $PIECE(DATA,U,9)=$PIECE(DATA,U,14)
+29 IF $PIECE(DATA,U,15)]""
IF $PIECE(DATA,U,10)=""
SET $PIECE(DATA,U,10)=$PIECE(DATA,U,15)
End DoDot:2
+30 ;
+31 ;Enable the date adjustment to work correctly when no Team Position
+32 ;Inactivation Date exists during a Patient Team Position Unassignment
+33 ;by stuffing the Patient Team Position Unassignment Date into the Team
+34 ;Position Inactivation Date field.
+35 ;
+36 IF $GET(ADJDATE)
IF SCUDATE]""
IF $PIECE(DATA,U,10)=""
SET $PIECE(DATA,U,10)=SCUDATE
+37 ;
+38 ;Continue only if the Act/Inact dates fall within Assign/Unassign
+39 ;dates
+40 ;
+41 IF $GET(ADJDATE)
IF '$$DTCHK^SCAPU1(@SCDATES@("BEGIN"),@SCDATES@("END"),0,$PIECE(DATA,U,9),$PIECE(DATA,U,10))
QUIT
+42 ;
+43 ;alb/rpm Patch 212 end
+44 ;
+45 ;Adjust dates
+46 ;
IF $GET(ADJDATE)
Begin DoDot:2
+47 ;Begin Date
IF $PIECE(DATA,U,9)<@SCDATES@("BEGIN")
Begin DoDot:3
+48 SET $PIECE(DATA,U,9)=@SCDATES@("BEGIN")
End DoDot:3
+49 ;End Date
IF @SCDATES@("END")
IF $PIECE(DATA,U,10)>@SCDATES@("END")
Begin DoDot:3
+50 SET $PIECE(DATA,U,10)=@SCDATES@("END")
End DoDot:3
End DoDot:2
+51 ;
+52 ;Add Patient Team Position Assign pointer to ID.
+53 SET ID1=PTTMPOS_"-"_ID
+54 ;Mark subscript as AP or PCP
+55 SET TYPE1=$SELECT(ID["AP":"AP",1:"PCP")
+56 ;Build return array
+57 SET @SCLIST@(PTTMPOS,TYPE1,ID1)=DATA
+58 QUIT
End DoDot:1
+59 QUIT
+60 ;
PROV(PTTMPOS,SCDATE,SCTYPE,SCPIECE) ;Return a single node/piece for AP/PCP
+1 ;
+2 ;Input:
+3 ; PTTMPOS - Pointer to entry in PATIENT TEAM POSITION
+4 ; ASSIGNMENT file (#404.43).
+5 ; SCDATE - A single date.
+6 ; SCTYPE - AP: Associate Provider
+7 ; PCP: Primary Care Provider
+8 ; Default=PCP
+9 ; SCPIECE - Enter number of piece of string you want displayed.
+10 ; If null, return entire string.
+11 ; See PRTP^SCAPMC8 for a description of the string
+12 ; pieces.
+13 ;Return: Data specified by SCPIECE. See PRTP^SCAPMC8 for a
+14 ; description of the string pieces.
+15 ;
+16 NEW DATA,ERR,I,ID,IEN,PROV,RESULT,TMP,TYPE,ZDATE
+17 ;
+18 ;Initialize variables
+19 IF '$GET(PTTMPOS)
QUIT ""
+20 IF '$DATA(^SCPT(404.43,PTTMPOS,0))
QUIT ""
+21 IF '$GET(SCDATE)
QUIT ""
+22 SET ZDATE("BEGIN")=SCDATE
+23 SET ZDATE("END")=SCDATE
+24 SET ZDATE("INCL")=0
+25 if $GET(SCTYPE)'="AP"
SET SCTYPE="PCP"
+26 SET TYPE=$SELECT(SCTYPE="PCP":"AP",1:"PCP")
+27 SET SCPIECE=$GET(SCPIECE)
+28 ;
+29 SET RESULT=$$PRPTTPC^SCAPMC(PTTMPOS,"ZDATE","PROV","ERR",1)
+30 IF 'RESULT
QUIT ""
+31 ;
+32 ;Build temp array subscripted by 404.52 IEN
+33 SET PTTMPOS=0
+34 ;
FOR
SET PTTMPOS=$ORDER(PROV(PTTMPOS))
if 'PTTMPOS
QUIT
Begin DoDot:1
+35 SET ID=""
+36 ;
FOR
SET ID=$ORDER(PROV(PTTMPOS,SCTYPE,ID))
if ID=""
QUIT
Begin DoDot:2
+37 SET IEN=$PIECE(PROV(PTTMPOS,SCTYPE,ID),"^",11)
+38 SET TMP(IEN)=PTTMPOS_U_SCTYPE_U_ID
End DoDot:2
End DoDot:1
+39 ;
+40 ;If more than one node, delete all but one with highest 404.52 IEN.
+41 SET IEN=$ORDER(TMP(""),-1)
IF 'IEN
QUIT ""
+42 SET DATA=$GET(TMP(IEN))
+43 SET DATA=$GET(PROV($PIECE(DATA,U,1),$PIECE(DATA,U,2),$PIECE(DATA,U,3)))
+44 IF SCPIECE
SET DATA=$PIECE(DATA,U,SCPIECE)
+45 QUIT DATA
