source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPV1A.m@ 1375

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

initial load of FOIAVistA 6/30/08 version

File size: 6.2 KB
Line 
1SCRPV1A ; bp/djb - PCMM Inconsistency Rpt - Get Data ; 8/25/99 9:57am
2 ;;5.3;Scheduling;**177**;AUG 13, 1993
3 ;
4 ;Return:
5 ; Inconsistency array in format:
6 ; ^TMP("PCMM POSITION",$J,#,Tm,TmPos,)=""
7 ; ^TMP("PCMM PATIENT",$J,Name,DFN,#,Tm,Pos)=""
8 ;
9 ;For a list of inconsistencies, see bottom of routine SCRPV1B.
10 ;
11EN ;
12 D POSITION
13 D PATIENT
14 Q
15 ;
16POSITION ;Check for position inconsistencies.
17 ;
18 NEW POSI,POSN,TMI,TMN
19 ;
20 ;Look at each team
21 S TMN=""
22 F S TMN=$O(^SCTM(404.51,"B",TMN)) Q:TMN="" D ;
23 . S TMI=0
24 . F S TMI=$O(^SCTM(404.51,"B",TMN,TMI)) Q:'TMI D ;
25 .. Q:'$D(^SCTM(404.51,TMI,0))
26 .. ;If user selected teams, quit if this one isn't on list.
27 .. I SCTYPE("TM")="S" Q:'$D(SCTM(TMI))
28 .. ;Look at each position for this team
29 .. S POSI=0
30 .. F S POSI=$O(^SCTM(404.57,"C",TMI,POSI)) Q:'POSI D ;
31 ... S POSN=$P($G(^SCTM(404.57,POSI,0)),U,1) Q:POSN']""
32 ... D CHECK45(TMI,POSI) ;..Check for inconsistencies 4 & 5.
33 ... Q:'$D(^SCPT(404.43,"APTPA",POSI))
34 ... D CHECK1(TMI,POSI) ;...Check for inconsistency 1.
35 Q
36 ;
37PATIENT ;Check for patient inconsistencies.
38 D CHECK28
39 D CHECK367
40 Q
41 ;
42CHECK1(TMI,POSI) ;Check positions for inconsistency 1.
43 ;Input:
44 ; TMI - Team IEN
45 ; POSI - Team Position IEN
46 ;
47 NEW POSN,TMN
48 Q:+$$GETPRTP^SCAPMCU2(POSI,DT) ;Current provider. Fld 304 in 404.57.
49 Q:+$$ACTTM^SCMCTMU(TMI,DT)'=1 ;Team inactive
50 Q:+$$ACTTP^SCMCTPU(POSI,DT)'=1 ;Position inactive
51 S TMN=$$TMNAME(TMI)
52 S POSN=$$POSNAME(POSI)
53 S ^TMP("PCMM POSITION",$J,1,TMN,POSN)="" ;.........................#1
54 Q
55 ;
56CHECK28 ;Check patients for inconsistencies 2 & 8.
57 ;
58 ;Loop thru 404.43 for each patient.
59 ;Use "ACTDFN" xref. Active entries sorted by patient IEN.
60 ;
61 NEW DATA,DFN,DFNNAM,NUM,POSI,POSN,PTI,PTPI,TMI,TMN
62 ;
63 S DFN=0
64 F S DFN=$O(^SCPT(404.43,"ACTDFN",DFN)) Q:'DFN D ;
65 . S PTPI=0
66 . F S PTPI=$O(^SCPT(404.43,"ACTDFN",DFN,PTPI)) Q:'PTPI D ;
67 .. S DATA=$G(^SCPT(404.43,PTPI,0)) ;Team Position Assign zero node
68 .. Q:$P(DATA,U,4)]"" ;.............Inactive
69 .. S PTI=$P(DATA,U,1) Q:'PTI ;.....Team Assign IEN
70 .. S POSI=$P(DATA,U,2) Q:'POSI ;...Position
71 .. S DATA=$G(^SCPT(404.42,PTI,0)) ;.Team Assign zero node
72 .. S TMI=$P(DATA,U,3) Q:'TMI ;.....Team IEN
73 .. ;
74 .. ;If user selected teams, quit if this one isn't on list.
75 .. I SCTYPE("TM")="S" Q:'$D(SCTM(TMI))
76 .. ;
77 .. S POSN=$$POSNAME(POSI)
78 .. S TMN=$$TMNAME(TMI)
79 .. S DFNNAM=$$PTNAME(DFN) ;Patient name
80 .. ;
81 .. D ;Check for nconsistency 8
82 ... I $P(DATA,U,9)]"" D ;...............Tm Pos Assign Inactive....#8
83 .... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,8.1,TMN,POSN)=PTPI
84 ... I +$$ACTTM^SCMCTMU(TMI,DT)'=1 D ;...Team inactive.............#8
85 .... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,8.2,TMN,POSN)=PTPI
86 ... I +$$ACTTP^SCMCTPU(POSI,DT)'=1 D ;..Position inactive.........#8
87 .... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,8.3,TMN,POSN)=PTPI
88 .. ;
89 .. Q:$P(DATA,U,8)'=1 ;..Team Assign not PC
90 .. Q:$P(DATA,U,9)]"" ;..Team Assign inactive
91 .. ;
92 .. Q:$D(^SCPT(404.43,"APCPOS",DFN,1))
93 .. S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,2,TMN,POSN)=PTPI ;..........#2
94 Q
95 ;
96CHECK367 ;Check patients for inconsistencies 3,6,7.
97 ;
98 ;Loop thru 404.43 for each patient.
99 ;Use "ACTPC" xref. Active entries sorted by patient IEN & PC ROLE.
100 ;
101 NEW CNT,DATA,DFN,DFNNAM,HLD,POSI,POSN,PTI,PTPI,TMI,TMN
102 ;
103 S DFN=0
104 F S DFN=$O(^SCPT(404.43,"ACTPC",DFN)) Q:'DFN D ;
105 . S CNT=0 KILL HLD ;Initialize for each DFN
106 . S PTPI=0
107 . F S PTPI=$O(^SCPT(404.43,"ACTPC",DFN,1,PTPI)) Q:'PTPI D ;
108 .. S DATA=$G(^SCPT(404.43,PTPI,0)) ;..Team Position Assign zero node
109 .. Q:$P(DATA,U,4)]"" ;...............Inactive
110 .. S PTI=$P(DATA,U,1) Q:'PTI ;.......Team Assign IEN
111 .. S POSI=$P(DATA,U,2) Q:'POSI ;.....Position
112 .. S DATA=$G(^SCPT(404.42,PTI,0)) ;...Team Assign zero node
113 .. S TMI=$P(DATA,U,3) Q:'TMI ;.......Team IEN
114 .. ;
115 .. ;If user selected teams, quit if this one isn't on list.
116 .. I SCTYPE("TM")="S" Q:'$D(SCTM(TMI))
117 .. ;
118 .. Q:$P(DATA,U,8)'=1 ;...............Team Assign not PC
119 .. Q:$P(DATA,U,9)]"" ;...............Team Assign inactive
120 .. S POSN=$$POSNAME(POSI)
121 .. S TMN=$$TMNAME(TMI)
122 .. S DFNNAM=$$PTNAME(DFN) ;Patient name
123 .. ;
124 .. D CHECK67
125 .. ;
126 .. S CNT=CNT+1
127 .. ;Save 1st occurance. Asingle occurance is not a problem.
128 .. I CNT=1 S HLD(DFNNAM,DFN,3,TMN,POSN)="" Q
129 .. ;
130 .. ;If there is a 2nd occurance, move 1st occurance into array.
131 .. I CNT=2 M ^TMP("PCMM PATIENT",$J)=HLD KILL HLD
132 .. S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,3,TMN,POSN)=PTPI ;..........#3
133 Q
134 ;
135CHECK45(TMI,POSI) ;Check positions for inconsistencies 4 & 5.
136 ;Input:
137 ; TMI - Team IEN
138 ; POSI - Team Position IEN
139 ;
140 NEW AP,DATA,PCP,POSN,PREHI,STAFFAP,STAFFPCP,TMN
141 ;
142 S PREHI=0
143 F S PREHI=$O(^SCTM(404.53,"B",POSI,PREHI)) Q:'PREHI D ;
144 . S DATA=$G(^SCTM(404.53,PREHI,0))
145 . Q:DATA']""
146 . S AP=$P(DATA,U,1) ;.....................Preceptee position
147 . S PCP=$P(DATA,U,6) ;....................Preceptor position
148 . S STAFFAP=+$$GETPRTP^SCAPMCU2(AP,DT) ;..Preceptee staff person
149 . S STAFFPCP=+$$GETPRTP^SCAPMCU2(PCP,DT) ;Preceptor staff person
150 . ;
151 . S TMN=$$TMNAME(TMI)
152 . S POSN=$$POSNAME(POSI)
153 . I STAFFAP,STAFFAP=STAFFPCP D ;
154 .. S ^TMP("PCMM POSITION",$J,4,TMN,POSN)="" ;......................#4
155 . I STAFFPCP="" D ;
156 .. S ^TMP("PCMM POSITION",$J,5,TMN,POSN)="" ;......................#5
157 Q
158 ;
159CHECK67 ;Check patients for inconsistencies 6 & 7.
160 NEW ERROR,ID,LIST,NUM,POS,RESULT,TYPE,ZDATE
161 ;
162 S ZDATE("BEGIN")=DT
163 S ZDATE("END")=DT
164 S ZDATE("INCL")=0
165 ;
166 S RESULT=$$PRPTTPC^SCAPMC(PTPI,"ZDATE","LIST","ERROR",1)
167 ;
168 S NUM=0
169 F S NUM=$O(LIST(NUM)) Q:'NUM D ;
170 . S TYPE=""
171 . F S TYPE=$O(LIST(NUM,TYPE)) Q:TYPE="" D ;
172 .. S ID=""
173 .. F S ID=$O(LIST(NUM,TYPE,ID)) Q:ID="" D ;
174 ... S POS=$P(LIST(NUM,TYPE,ID),U,3) Q:'POS
175 ... ;See if field 4, POSSIBLE PRIMARY PRACTITIONER, equals 1.
176 ... Q:$P($G(^SCTM(404.57,POS,0)),U,4)=1
177 ... I TYPE="AP" D Q
178 .... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,6,TMN,POSN)=PTPI ;........#6
179 ... I TYPE="PCP" D Q
180 .... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,7,TMN,POSN)=PTPI ;........#7
181 Q
182 ;
183TMNAME(TMI) ;Return team name
184 NEW NAME
185 S NAME=$P($G(^SCTM(404.51,TMI,0)),U,1)
186 S:NAME="" NAME="UNKNOWN"
187 Q NAME
188 ;
189POSNAME(POSI) ;Return position name
190 NEW NAME
191 S NAME=$P($G(^SCTM(404.57,POSI,0)),U,1)
192 S:NAME="" NAME="UNKNOWN"
193 Q NAME
194 ;
195PTNAME(DFN) ;Return patient name
196 NEW NAME
197 S NAME=$P($G(^DPT(DFN,0)),U,1)
198 S:NAME="" NAME="UNKNOWN"
199 Q NAME
Note: See TracBrowser for help on using the repository browser.