Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCAPMC34

SCAPMC34.m

Go to the documentation of this file. 
  1. SCAPMC34  ;BP/DJB - Get PCP/AP Array For a Pt Tm Pos ; 5/24/99 12:39pm
  1.  ;;5.3;Scheduling;**177,212,1015**;May 01, 1999;Build 21
  1.  ;
  1. PRPTTPC(PTTMPOS,SCDATES,SCLIST,SCERR,SCALLHIS,ADJDATE) ;
  1.  ;Get provider array for a Patient Team Position Assignment (#404.43).
  1.  ;
  1.  ; Input: See PRPTTP^SCAPMC33
  1.  ;Output: See PRTP^SCAPMC8
  1.  ;
  1.  ;Returned: 1 if ok, 0 if error
  1.  ;
  1.  ;Declare variables
  1.  NEW EDATE,ND,OK,PRPTTPC,SDATE,TMPOSPTR
  1.  ;
  1.  ;Initialize variables
  1.  S OK=0
  1.  ;
  1.  ;Check input
  1.  I '$G(PTTMPOS) G QUIT
  1.  I '$D(^SCPT(404.43,PTTMPOS,0)) G QUIT
  1.  ;
  1.  ;Get data
  1.  S ND=$G(^SCPT(404.43,PTTMPOS,0)) ;Zero node of 404.43
  1.  S TMPOSPTR=$P(ND,U,2) ;...........Team Position IEN
  1.  I 'TMPOSPTR G QUIT
  1.  S SDATE=$P(ND,U,3) ;..............Assigned Date
  1.  S EDATE=$P(ND,U,4) ;..............Unassigned Date
  1.  ;
  1.  S OK=$$ADJUST1^SCAPMC33(SDATE,EDATE)
  1.  G:'OK QUIT
  1.  ;Get temporary array in PRPTTPC. It will be converted to @SCLIST.
  1.  S OK=$$PRTPC^SCAPMC(TMPOSPTR,.SCDATES,"PRPTTPC",.SCERR,.SCALLHIS,.ADJDATE)
  1.  G:'OK QUIT
  1.  G:'$D(PRPTTPC) QUIT
  1.  ;
  1.  ;alb/rpm - Patch 212 start
  1.  D ADJUST(EDATE) ;Convert array & adjust dates and unique ID subscript
  1.  ;alb/rpm - Patch 212 end
  1.  ;
  1. QUIT Q OK
  1.  ;
  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.
  1.  ;Add the Pt Tm Pos Assign IEN to unique ID string.
  1.  ;alb/rpm Patch 212 start
  1.  ; Input:
  1.  ;       SCUDATE - Pt Tm Pos Unassign date [default=""]
  1.  ;
  1.  ; Output:  None
  1.  ;alb/rpm Patch 212 end
  1.  ;
  1.  NEW DATA,ID,ID1,NUM,PREH,TYPE,TYPE1
  1.  Q:'$D(PRPTTPC)
  1.  ;
  1.  ;alb/rpm Patch 212 start
  1.  S SCUDATE=$G(SCUDATE,"")
  1.  ;alb/rpm Patch 212 end
  1.  ;
  1.  ;Loop thru returned array and make adjustments.
  1.  S NUM=0
  1.  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  ;
  1.  . S DATA=$G(PRPTTPC(NUM,TYPE,ID))
  1.  . ;
  1.  . ;alb/rpm Patch 212 start
  1.  . ;
  1.  . ;Adjust preceptor act/inact dates to represent preceptor
  1.  . ;assign/unassign dates.
  1.  . ;
  1.  . I $G(ADJDATE),TYPE="PREC" D
  1.  . . I $P(DATA,U,9)<$P(DATA,U,14) S $P(DATA,U,9)=$P(DATA,U,14)
  1.  . . I $P(DATA,U,15)]"",$P(DATA,U,10)="" S $P(DATA,U,10)=$P(DATA,U,15)
  1.  . ;
  1.  . ;Enable the date adjustment to work correctly when no Team Position
  1.  . ;Inactivation Date exists during a Patient Team Position Unassignment
  1.  . ;by stuffing the Patient Team Position Unassignment Date into the Team
  1.  . ;Position Inactivation Date field.  
  1.  . ;
  1.  . I $G(ADJDATE),SCUDATE]"",$P(DATA,U,10)="" S $P(DATA,U,10)=SCUDATE
  1.  . ;
  1.  . ;Continue only if the Act/Inact dates fall within Assign/Unassign
  1.  . ;dates
  1.  . ;
  1.  . I $G(ADJDATE),'$$DTCHK^SCAPU1(@SCDATES@("BEGIN"),@SCDATES@("END"),0,$P(DATA,U,9),$P(DATA,U,10)) Q
  1.  . ;
  1.  . ;alb/rpm Patch 212 end
  1.  . ;
  1.  . ;Adjust dates
  1.  . I $G(ADJDATE) D  ;
  1.  . . I $P(DATA,U,9)<@SCDATES@("BEGIN") D  ;Begin Date
  1.  . . . S $P(DATA,U,9)=@SCDATES@("BEGIN")
  1.  . . I @SCDATES@("END"),$P(DATA,U,10)>@SCDATES@("END") D  ;End Date
  1.  . . . S $P(DATA,U,10)=@SCDATES@("END")
  1.  . ;
  1.  . ;Add Patient Team Position Assign pointer to ID.
  1.  . S ID1=PTTMPOS_"-"_ID
  1.  . ;Mark subscript as AP or PCP
  1.  . S TYPE1=$S(ID["AP":"AP",1:"PCP")
  1.  . ;Build return array
  1.  . S @SCLIST@(PTTMPOS,TYPE1,ID1)=DATA
  1.  . Q
  1.  Q
  1.  ;
  1. PROV(PTTMPOS,SCDATE,SCTYPE,SCPIECE) ;Return a single node/piece for AP/PCP
  1.  ;
  1.  ;Input:
  1.  ;      PTTMPOS - Pointer to entry in PATIENT TEAM POSITION
  1.  ;                ASSIGNMENT file (#404.43).
  1.  ;       SCDATE - A single date.
  1.  ;       SCTYPE - AP:  Associate Provider
  1.  ;                PCP: Primary Care Provider
  1.  ;                Default=PCP
  1.  ;      SCPIECE - Enter number of piece of string you want displayed.
  1.  ;                If null, return entire string.
  1.  ;                See PRTP^SCAPMC8 for a description of the string
  1.  ;                pieces.
  1.  ;Return: Data specified by SCPIECE. See PRTP^SCAPMC8 for a
  1.  ;        description of the string pieces.
  1.  ;
  1.  NEW DATA,ERR,I,ID,IEN,PROV,RESULT,TMP,TYPE,ZDATE
  1.  ;
  1.  ;Initialize variables
  1.  I '$G(PTTMPOS) Q ""
  1.  I '$D(^SCPT(404.43,PTTMPOS,0)) Q ""
  1.  I '$G(SCDATE) Q ""
  1.  S ZDATE("BEGIN")=SCDATE
  1.  S ZDATE("END")=SCDATE
  1.  S ZDATE("INCL")=0
  1.  S:$G(SCTYPE)'="AP" SCTYPE="PCP"
  1.  S TYPE=$S(SCTYPE="PCP":"AP",1:"PCP")
  1.  S SCPIECE=$G(SCPIECE)
  1.  ;
  1.  S RESULT=$$PRPTTPC^SCAPMC(PTTMPOS,"ZDATE","PROV","ERR",1)
  1.  I 'RESULT Q ""
  1.  ;
  1.  ;Build temp array subscripted by 404.52 IEN
  1.  S PTTMPOS=0
  1.  F  S PTTMPOS=$O(PROV(PTTMPOS)) Q:'PTTMPOS  D  ;
  1.  . S ID=""
  1.  . F  S ID=$O(PROV(PTTMPOS,SCTYPE,ID)) Q:ID=""  D  ;
  1.  . . S IEN=$P(PROV(PTTMPOS,SCTYPE,ID),"^",11)
  1.  . . S TMP(IEN)=PTTMPOS_U_SCTYPE_U_ID
  1.  ;
  1.  ;If more than one node, delete all but one with highest 404.52 IEN.
  1.  S IEN=$O(TMP(""),-1) I 'IEN Q ""
  1.  S DATA=$G(TMP(IEN))
  1.  S DATA=$G(PROV($P(DATA,U,1),$P(DATA,U,2),$P(DATA,U,3)))
  1.  I SCPIECE S DATA=$P(DATA,U,SCPIECE)
  1.  Q DATA