source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCAPMC34.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1SCAPMC34 ;BP/DJB - Get PCP/AP Array For a Pt Tm Pos ; 5/24/99 12:39pm
2 ;;5.3;Scheduling;**177,212**;May 01, 1999
3 ;
4PRPTTPC(PTTMPOS,SCDATES,SCLIST,SCERR,SCALLHIS,ADJDATE) ;
5 ;Get provider array for a Patient Team Position Assignment (#404.43).
6 ;
7 ; Input: See PRPTTP^SCAPMC33
8 ;Output: See PRTP^SCAPMC8
9 ;
10 ;Returned: 1 if ok, 0 if error
11 ;
12 ;Declare variables
13 NEW EDATE,ND,OK,PRPTTPC,SDATE,TMPOSPTR
14 ;
15 ;Initialize variables
16 S OK=0
17 ;
18 ;Check input
19 I '$G(PTTMPOS) G QUIT
20 I '$D(^SCPT(404.43,PTTMPOS,0)) G QUIT
21 ;
22 ;Get data
23 S ND=$G(^SCPT(404.43,PTTMPOS,0)) ;Zero node of 404.43
24 S TMPOSPTR=$P(ND,U,2) ;...........Team Position IEN
25 I 'TMPOSPTR G QUIT
26 S SDATE=$P(ND,U,3) ;..............Assigned Date
27 S EDATE=$P(ND,U,4) ;..............Unassigned Date
28 ;
29 S OK=$$ADJUST1^SCAPMC33(SDATE,EDATE)
30 G:'OK QUIT
31 ;Get temporary array in PRPTTPC. It will be converted to @SCLIST.
32 S OK=$$PRTPC^SCAPMC(TMPOSPTR,.SCDATES,"PRPTTPC",.SCERR,.SCALLHIS,.ADJDATE)
33 G:'OK QUIT
34 G:'$D(PRPTTPC) QUIT
35 ;
36 ;alb/rpm - Patch 212 start
37 D ADJUST(EDATE) ;Convert array & adjust dates and unique ID subscript
38 ;alb/rpm - Patch 212 end
39 ;
40QUIT Q OK
41 ;
42ADJUST(SCUDATE) ;Convert PROV-P/PROV-U/PREC array to AP/PCP array. Adjust Start/End
43 ;dates in SCLIST array so they don't exceed requested date range.
44 ;Add the Pt Tm Pos Assign IEN to unique ID string.
45 ;alb/rpm Patch 212 start
46 ; Input:
47 ; SCUDATE - Pt Tm Pos Unassign date [default=""]
48 ;
49 ; Output: None
50 ;alb/rpm Patch 212 end
51 ;
52 NEW DATA,ID,ID1,NUM,PREH,TYPE,TYPE1
53 Q:'$D(PRPTTPC)
54 ;
55 ;alb/rpm Patch 212 start
56 S SCUDATE=$G(SCUDATE,"")
57 ;alb/rpm Patch 212 end
58 ;
59 ;Loop thru returned array and make adjustments.
60 S NUM=0
61 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 ;
62 . S DATA=$G(PRPTTPC(NUM,TYPE,ID))
63 . ;
64 . ;alb/rpm Patch 212 start
65 . ;
66 . ;Adjust preceptor act/inact dates to represent preceptor
67 . ;assign/unassign dates.
68 . ;
69 . I $G(ADJDATE),TYPE="PREC" D
70 . . I $P(DATA,U,9)<$P(DATA,U,14) S $P(DATA,U,9)=$P(DATA,U,14)
71 . . I $P(DATA,U,15)]"",$P(DATA,U,10)="" S $P(DATA,U,10)=$P(DATA,U,15)
72 . ;
73 . ;Enable the date adjustment to work correctly when no Team Position
74 . ;Inactivation Date exists during a Patient Team Position Unassignment
75 . ;by stuffing the Patient Team Position Unassignment Date into the Team
76 . ;Position Inactivation Date field.
77 . ;
78 . I $G(ADJDATE),SCUDATE]"",$P(DATA,U,10)="" S $P(DATA,U,10)=SCUDATE
79 . ;
80 . ;Continue only if the Act/Inact dates fall within Assign/Unassign
81 . ;dates
82 . ;
83 . I $G(ADJDATE),'$$DTCHK^SCAPU1(@SCDATES@("BEGIN"),@SCDATES@("END"),0,$P(DATA,U,9),$P(DATA,U,10)) Q
84 . ;
85 . ;alb/rpm Patch 212 end
86 . ;
87 . ;Adjust dates
88 . I $G(ADJDATE) D ;
89 . . I $P(DATA,U,9)<@SCDATES@("BEGIN") D ;Begin Date
90 . . . S $P(DATA,U,9)=@SCDATES@("BEGIN")
91 . . I @SCDATES@("END"),$P(DATA,U,10)>@SCDATES@("END") D ;End Date
92 . . . S $P(DATA,U,10)=@SCDATES@("END")
93 . ;
94 . ;Add Patient Team Position Assign pointer to ID.
95 . S ID1=PTTMPOS_"-"_ID
96 . ;Mark subscript as AP or PCP
97 . S TYPE1=$S(ID["AP":"AP",1:"PCP")
98 . ;Build return array
99 . S @SCLIST@(PTTMPOS,TYPE1,ID1)=DATA
100 . Q
101 Q
102 ;
103PROV(PTTMPOS,SCDATE,SCTYPE,SCPIECE) ;Return a single node/piece for AP/PCP
104 ;
105 ;Input:
106 ; PTTMPOS - Pointer to entry in PATIENT TEAM POSITION
107 ; ASSIGNMENT file (#404.43).
108 ; SCDATE - A single date.
109 ; SCTYPE - AP: Associate Provider
110 ; PCP: Primary Care Provider
111 ; Default=PCP
112 ; SCPIECE - Enter number of piece of string you want displayed.
113 ; If null, return entire string.
114 ; See PRTP^SCAPMC8 for a description of the string
115 ; pieces.
116 ;Return: Data specified by SCPIECE. See PRTP^SCAPMC8 for a
117 ; description of the string pieces.
118 ;
119 NEW DATA,ERR,I,ID,IEN,PROV,RESULT,TMP,TYPE,ZDATE
120 ;
121 ;Initialize variables
122 I '$G(PTTMPOS) Q ""
123 I '$D(^SCPT(404.43,PTTMPOS,0)) Q ""
124 I '$G(SCDATE) Q ""
125 S ZDATE("BEGIN")=SCDATE
126 S ZDATE("END")=SCDATE
127 S ZDATE("INCL")=0
128 S:$G(SCTYPE)'="AP" SCTYPE="PCP"
129 S TYPE=$S(SCTYPE="PCP":"AP",1:"PCP")
130 S SCPIECE=$G(SCPIECE)
131 ;
132 S RESULT=$$PRPTTPC^SCAPMC(PTTMPOS,"ZDATE","PROV","ERR",1)
133 I 'RESULT Q ""
134 ;
135 ;Build temp array subscripted by 404.52 IEN
136 S PTTMPOS=0
137 F S PTTMPOS=$O(PROV(PTTMPOS)) Q:'PTTMPOS D ;
138 . S ID=""
139 . F S ID=$O(PROV(PTTMPOS,SCTYPE,ID)) Q:ID="" D ;
140 . . S IEN=$P(PROV(PTTMPOS,SCTYPE,ID),"^",11)
141 . . S TMP(IEN)=PTTMPOS_U_SCTYPE_U_ID
142 ;
143 ;If more than one node, delete all but one with highest 404.52 IEN.
144 S IEN=$O(TMP(""),-1) I 'IEN Q ""
145 S DATA=$G(TMP(IEN))
146 S DATA=$G(PROV($P(DATA,U,1),$P(DATA,U,2),$P(DATA,U,3)))
147 I SCPIECE S DATA=$P(DATA,U,SCPIECE)
148 Q DATA
Note: See TracBrowser for help on using the repository browser.